diff --git a/ChangeLog.md b/ChangeLog.md --- a/ChangeLog.md +++ b/ChangeLog.md @@ -6,6 +6,28 @@ and this project adheres to the [Haskell Package Versioning Policy](https://pvp.haskell.org/). +## v0.10.0 — 2026-07-15 + +This release replaces the typechecker's internal term representation and makes checking roughly nine times faster. There are no surface-language changes; for users the release is a performance release, plus one new option. For packagers and library users it is a major version: the library API is reorganised, **GHC 9.8 or newer is now required** to build rzk, and the GHCJS-built browser playground is not rebuilt for this release (see below). + +Changed: + +- **The core representation moved to free-foil** (see [#289](https://github.com/rzk-lang/rzk/pull/289), [#292](https://github.com/rzk-lang/rzk/pull/292)). The typechecker now uses [free-foil](https://github.com/fizruk/free-foil) scope-safe names (integer identifiers with type-level scope indexing) instead of the previous well-scoped de Bruijn representation, whose depth-relative variables made every comparison walk successor chains. The library module layout is reorganised accordingly (`Language.Rzk.Foil.*`, `Rzk.TypeCheck.*`), which is what makes this a major version under the PVP. This raises the compiler floor: **building rzk now requires GHC ≥ 9.8**. The surface language, CLI, and LSP behaviour are unchanged. + +- **The browser playground cannot be built from this release** (a consequence of the free-foil migration). The playground is compiled with GHCJS from miso's pinned 2019-era package set, which does not carry free-foil, so the GHCJS lane no longer builds and the playground is not rebuilt or redeployed for v0.10.0; the deployed playground remains the v0.9.2 one. The library itself builds under the GHC WebAssembly backend (the `wasm` CI lane), and the planned replacement is a Miso playground on that backend rather than packaging free-foil for GHCJS. + +- **The overhang hint is now opt-in** (see [#295](https://github.com/rzk-lang/rzk/pull/295)). The non-fatal hint that a restriction face or `#!rzk recOR` guard overhangs the local tope context required a solver query per face just to decide whether to print; it is now off by default and enabled with `#!rzk #set-option "warn-overhang" = "yes"`. A face *disjoint* from the context is still a hard error. + +Performance: + +- A full check of the sHoTT corpus goes from ~13.4 s (v0.9.2) to **~1.5 s**, and maximum residency from 2.1 GB to **233 MB**. The pieces, each measured separately: + + - The free-foil representation itself removes the dominant cost of v0.9.2, variable comparison along de Bruijn successor chains (see [#289](https://github.com/rzk-lang/rzk/pull/289)). + - The runtime is configured with a 64 MB nursery (`-A64m`), letting the checker's short-lived allocation die young: GC time drops by two thirds (see [#290](https://github.com/rzk-lang/rzk/pull/290)). + - Beta reduction is spine-batched: a curried application peels the head's lambda chain into a single substitution instead of one per argument, which alone cut wall time by 28% and halved peak residency at its merge point (see [#291](https://github.com/rzk-lang/rzk/pull/291)). + - **Conversion checking gets a normalisation-by-evaluation fast path** (see [#293](https://github.com/rzk-lang/rzk/pull/293)). Both sides of a comparison are evaluated call-by-need into a value domain with closures and compared structurally; anything context-sensitive falls back to the ordinary unification unchanged, so the fast path cannot change what typechecks. Besides its share of the sHoTT win, this repairs a cliff on computation-heavy code: checking `#!rzk cmul c16 c16 = cadd c128 c128` for Church numerals took 177 seconds (and unbalanced variants did not finish); it now checks in 0.05 seconds. + - The hole-recording channel uses the CPS writer, removing an allocation on every bind of the typechecking monad (see [#294](https://github.com/rzk-lang/rzk/pull/294)); the judgement stack tracks its depth instead of measuring it (see [#288](https://github.com/rzk-lang/rzk/pull/288)). + ## v0.9.2 — 2026-07-13 Added: diff --git a/app/Main.hs b/app/Main.hs --- a/app/Main.hs +++ b/app/Main.hs @@ -75,7 +75,7 @@ putStrLn "An error occurred when typechecking!" putStrLn $ unlines [ "Type Error:" - , ppTypeErrorInScopedContext' BottomUp err + , ppTypeErrorInScopedContext BottomUp err ] if jsonFlag -- Machine-readable mode: emit every diagnostic (type errors as errors, @@ -84,21 +84,21 @@ then do let diagnostics = case typecheckModulesWithHoles modules of Left err -> [diagnoseTypeError BottomUp err] - Right (_decls, errors, holes) -> + Right (Checked _ctx _decls errors, holes) -> map (diagnoseTypeError BottomUp) errors ++ map diagnoseHole holes BL8.putStrLn (encode diagnostics) when (any ((== SeverityError) . diagnosticSeverity) diagnostics) exitFailure else if allowHolesFlag then case typecheckModulesWithHoles modules of Left err -> reportError err >> exitFailure - Right (_decls, errors, holes) -> do + Right (Checked _ctx _decls errors, holes) -> do forM_ holes (putStr . ppHoleInfo) case errors of [] -> putStrLn ("Everything is ok! (" <> show (length holes) <> " hole(s))") _ -> do forM_ errors reportError; exitFailure - else case defaultTypeCheck (typecheckModulesWithLocation modules) of + else case typecheckModules modules of Left err -> reportError err >> exitFailure - Right _decls -> putStrLn "Everything is ok!" + Right _checked -> putStrLn "Everything is ok!" Lsp -> #ifdef LSP_ENABLED diff --git a/rzk.cabal b/rzk.cabal --- a/rzk.cabal +++ b/rzk.cabal @@ -5,7 +5,7 @@ -- see: https://github.com/sol/hpack name: rzk -version: 0.9.2 +version: 0.10.0 synopsis: An experimental proof assistant for synthetic ∞-categories description: Please see the README on GitHub at category: Dependent Types @@ -32,12 +32,14 @@ test/typecheck/cases/happy-modal-tope-unwrap.rzk test/typecheck/cases/happy-modal-topes.rzk test/typecheck/cases/happy-multivar-binder.rzk + test/typecheck/cases/happy-nbe-church-conversion.rzk test/typecheck/cases/happy-op-hom-to-hom.rzk test/typecheck/cases/happy-recbot-term-wellformed.rzk test/typecheck/cases/happy-recor-guard-exceeds-context.rzk test/typecheck/cases/happy-recor-split-simplex-overhang.rzk test/typecheck/cases/happy-refl-path.rzk test/typecheck/cases/happy-restrict-face-not-contained.rzk + test/typecheck/cases/happy-set-option-warn-overhang.rzk test/typecheck/cases/happy-shott-simplicial-subcomplexes.rzk test/typecheck/cases/happy-subtype-variance-pi-shape-domain.rzk test/typecheck/cases/happy-subtype-variance-restriction-faces.rzk @@ -77,6 +79,7 @@ test/typecheck/cases/ill-modal-sharp-under-flat.rzk test/typecheck/cases/ill-modal-sharp-under-op.rzk test/typecheck/cases/ill-modal-tope-cross-modality.rzk + test/typecheck/cases/ill-nbe-church-unequal.rzk test/typecheck/cases/ill-not-function.rzk test/typecheck/cases/ill-not-pair-first-unit.rzk test/typecheck/cases/ill-not-pair-second-unit.rzk @@ -142,12 +145,14 @@ test/typecheck/cases/happy-modal-tope-unwrap.expect.yaml test/typecheck/cases/happy-modal-topes.expect.yaml test/typecheck/cases/happy-multivar-binder.expect.yaml + test/typecheck/cases/happy-nbe-church-conversion.expect.yaml test/typecheck/cases/happy-op-hom-to-hom.expect.yaml test/typecheck/cases/happy-recbot-term-wellformed.expect.yaml test/typecheck/cases/happy-recor-guard-exceeds-context.expect.yaml test/typecheck/cases/happy-recor-split-simplex-overhang.expect.yaml test/typecheck/cases/happy-refl-path.expect.yaml test/typecheck/cases/happy-restrict-face-not-contained.expect.yaml + test/typecheck/cases/happy-set-option-warn-overhang.expect.yaml test/typecheck/cases/happy-shott-simplicial-subcomplexes.expect.yaml test/typecheck/cases/happy-subtype-variance-pi-shape-domain.expect.yaml test/typecheck/cases/happy-subtype-variance-restriction-faces.expect.yaml @@ -187,6 +192,7 @@ test/typecheck/cases/ill-modal-sharp-under-flat.expect.yaml test/typecheck/cases/ill-modal-sharp-under-op.expect.yaml test/typecheck/cases/ill-modal-tope-cross-modality.expect.yaml + test/typecheck/cases/ill-nbe-church-unequal.expect.yaml test/typecheck/cases/ill-not-function.expect.yaml test/typecheck/cases/ill-not-pair-first-unit.expect.yaml test/typecheck/cases/ill-not-pair-second-unit.expect.yaml @@ -255,9 +261,10 @@ library exposed-modules: - Free.Scoped - Free.Scoped.TH - Language.Rzk.Free.Syntax + Language.Rzk.Foil.Convert + Language.Rzk.Foil.Names + Language.Rzk.Foil.Print + Language.Rzk.Foil.Syntax Language.Rzk.Syntax Language.Rzk.Syntax.Abs Language.Rzk.Syntax.Layout @@ -269,7 +276,19 @@ Rzk.Format Rzk.Main Rzk.Project.Config + Rzk.Render.Geometry Rzk.TypeCheck + Rzk.TypeCheck.BinderTypes + Rzk.TypeCheck.Context + Rzk.TypeCheck.Decl + Rzk.TypeCheck.Display + Rzk.TypeCheck.Error + Rzk.TypeCheck.Eval + Rzk.TypeCheck.Judgements + Rzk.TypeCheck.Monad + Rzk.TypeCheck.NbE + Rzk.TypeCheck.Render + Rzk.TypeCheck.Unify other-modules: Paths_rzk autogen-modules: @@ -286,10 +305,15 @@ , base >=4.7 && <5 , bifunctors >=5.5.3 && <6 , bytestring >=0.10.8.2 && <1 + , containers >=0.6 && <1 , directory >=1.2.7.0 && <2 + , free-foil >=0.3.2 && <0.4 + , kind-generics >=0.5 && <1 + , kind-generics-th >=0.2 && <1 , mtl >=2.2.2 && <3 , template-haskell >=2.14.0.0 && <3 , text >=1.2.3.1 && <3 + , transformers >=0.5 && <1 , yaml >=0.11.0.0 && <1 default-language: Haskell2010 if flag(lsp) && !impl(ghcjs) @@ -307,7 +331,6 @@ aeson >=2.0.0.0 && <3 , async >=2.2 && <3 , co-log-core >=0.3.2.0 && <1 - , containers >=0.6 && <1 , data-default-class >=0.1.2.0 && <1 , filepath >=1.4.100.0 && <2 , lens >=5.0.1 && <6 @@ -326,7 +349,7 @@ app default-extensions: DeriveDataTypeable - ghc-options: -Wall -Wcompat -Widentities -Werror=missing-fields -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -optP-Wno-nonportable-include-path -threaded -rtsopts -with-rtsopts=-N + ghc-options: -Wall -Wcompat -Widentities -Werror=missing-fields -Wincomplete-record-updates -Wincomplete-uni-patterns -Wmissing-home-modules -Wpartial-fields -Wredundant-constraints -optP-Wno-nonportable-include-path -threaded -rtsopts "-with-rtsopts=-N -A64m" build-depends: Glob >=0.9.3 && <1 , aeson >=1.4 && <3 @@ -334,11 +357,16 @@ , base >=4.7 && <5 , bifunctors >=5.5.3 && <6 , bytestring >=0.10.8.2 && <1 + , containers >=0.6 && <1 , directory >=1.2.7.0 && <2 + , free-foil >=0.3.2 && <0.4 + , kind-generics >=0.5 && <1 + , kind-generics-th >=0.2 && <1 , mtl >=2.2.2 && <3 , rzk , template-haskell >=2.14.0.0 && <3 , text >=1.2.3.1 && <3 + , transformers >=0.5 && <1 , yaml >=0.11.0.0 && <1 default-language: Haskell2010 if flag(lsp) && !impl(ghcjs) @@ -364,12 +392,17 @@ , base >=4.11.0.0 && <5.0 , bifunctors >=5.5.3 && <6 , bytestring >=0.10.8.2 && <1 + , containers >=0.6 && <1 , directory >=1.2.7.0 && <2 , doctest-parallel >=0.3 && <1 + , free-foil >=0.3.2 && <0.4 + , kind-generics >=0.5 && <1 + , kind-generics-th >=0.2 && <1 , mtl >=2.2.2 && <3 , rzk , template-haskell >=2.14.0.0 && <3 , text >=1.2.3.1 && <3 + , transformers >=0.5 && <1 , yaml >=0.11.0.0 && <1 default-language: Haskell2010 if flag(lsp) && !impl(ghcjs) @@ -381,6 +414,7 @@ other-modules: Rzk.BinderTypesSpec Rzk.DiagnosticSpec + Rzk.FoilCoreSpec Rzk.FormatSpec Rzk.HolesSpec Rzk.RefIndexSpec @@ -403,14 +437,19 @@ , base >=4.7 && <5 , bifunctors >=5.5.3 && <6 , bytestring >=0.10.8.2 && <1 + , containers >=0.6 && <1 , directory >=1.2.7.0 && <2 , filepath >=1.4 && <2 + , free-foil >=0.3.2 && <0.4 , hspec >=2.7 && <3 , hspec-discover >=2.7 && <3 + , kind-generics >=0.5 && <1 + , kind-generics-th >=0.2 && <1 , mtl >=2.2.2 && <3 , rzk , template-haskell >=2.14.0.0 && <3 , text >=1.2.3.1 && <3 + , transformers >=0.5 && <1 , yaml >=0.11.0.0 && <1 default-language: Haskell2010 if flag(lsp) && !impl(ghcjs) diff --git a/src/Free/Scoped.hs b/src/Free/Scoped.hs deleted file mode 100644 --- a/src/Free/Scoped.hs +++ /dev/null @@ -1,123 +0,0 @@ -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveGeneric #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE QuantifiedConstraints #-} -{-# LANGUAGE RankNTypes #-} -{-# LANGUAGE StandaloneDeriving #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeOperators #-} -{-# LANGUAGE UndecidableInstances #-} -module Free.Scoped where - -import Control.Monad (ap) -import Data.Bifoldable -import Data.Bifunctor -import Data.Bifunctor.TH -import Data.Bitraversable -import Data.Function (on) -import qualified GHC.Generics as GHC - -data Inc var = Z | S var - deriving (Eq, Show, Functor, Foldable, Traversable) - -type Scope term var = term (Inc var) - -instantiate :: Monad f => f a -> f (Inc a) -> f a -instantiate e f = f >>= g - where - g Z = e - g (S x) = return x - -abstract :: (Eq a, Functor f) => a -> f a -> f (Inc a) -abstract x e = k <$> e - where - k y | x == y = Z - | otherwise = S y - -data FS t a - = Pure a - | Free (t (Scope (FS t) a) (FS t a)) - -deriving instance (Eq a, forall x y. (Eq x, Eq y) => Eq (t x y)) => Eq (FS t a) - -instance Bifunctor t => Functor (FS t) where - fmap f (Pure x) = Pure (f x) - fmap f (Free t) = Free - (bimap (fmap (fmap f)) (fmap f) t) - -instance Bifoldable t => Foldable (FS t) where - foldMap f (Pure x) = f x - foldMap f (Free t) = bifoldMap (foldMap (foldMap f)) (foldMap f) t - -instance Bitraversable t => Traversable (FS t) where - traverse f (Pure x) = Pure <$> f x - traverse f (Free t) = Free <$> - bitraverse (traverse (traverse f)) (traverse f) t - -instance Bifunctor t => Applicative (FS t) where - pure = Pure - (<*>) = ap - -instance Bifunctor t => Monad (FS t) where - return = pure - Pure x >>= f = f x - Free t >>= f = Free - (bimap ((>>= traverse f)) (>>= f) t) - -data Sum f g scope term - = InL (f scope term) - | InR (g scope term) - deriving (Functor, Foldable, Traversable, GHC.Generic) -deriveBifunctor ''Sum -deriveBifoldable ''Sum -deriveBitraversable ''Sum - -type (:+:) = Sum - -data Empty scope term - deriving (Functor, Foldable, Traversable) -deriveBifunctor ''Empty -deriveBifoldable ''Empty -deriveBitraversable ''Empty - -data AnnF ann term scope typedTerm = AnnF - { annF :: ann typedTerm - , termF :: term scope typedTerm - } deriving (Show, Functor) - --- | Important: does not compare the `annF` component! -instance Eq (term scope typedTerm) => Eq (AnnF ann term scope typedTerm) where - (==) = (==) `on` termF - -instance (Functor ann, Bifunctor term) => Bifunctor (AnnF ann term) where - bimap f g (AnnF t x) = AnnF (fmap g t) (bimap f g x) - --- | Important: does not fold over the 'annF' component! -instance Bifoldable term => Bifoldable (AnnF ann term) where - bifoldMap f g (AnnF _ty x) = {- g ty <> -} bifoldMap f g x - -instance (Traversable ann, Bitraversable term) => Bitraversable (AnnF ann term) where - bitraverse f g (AnnF t x) = AnnF <$> traverse g t <*> bitraverse f g x - -transFS - :: (Bifunctor term) - => (forall s t. term s t -> term' s t) - -> FS term a -> FS term' a -transFS phi = \case - Pure x -> Pure x - Free t -> Free (phi (bimap (transFS phi) (transFS phi) t)) - -untyped :: (Functor ann, Bifunctor term) => FS (AnnF ann term) a -> FS term a -untyped = transFS termF - -pattern ExtE :: ext (Scope (FS (t :+: ext)) a) (FS (t :+: ext) a) -> FS (t :+: ext) a -pattern ExtE t = Free (InR t) - -substitute :: Bifunctor t => FS t a -> Scope (FS t) a -> FS t a -substitute t = (>>= f) - where - f Z = t - f (S y) = Pure y diff --git a/src/Free/Scoped/TH.hs b/src/Free/Scoped/TH.hs deleted file mode 100644 --- a/src/Free/Scoped/TH.hs +++ /dev/null @@ -1,120 +0,0 @@ -{-# LANGUAGE CPP #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE TemplateHaskell #-} -module Free.Scoped.TH where - -import Control.Monad (replicateM) -import Free.Scoped -import Language.Haskell.TH - -mkConP :: Name -> [Pat] -> Pat -#if __GLASGOW_HASKELL__ >= 902 -mkConP name pats = ConP name [] pats -#else -mkConP name pats = ConP name pats -#endif - -makePatternsAll :: Name -> Q [Dec] -makePatternsAll ty = do - TyConI tyCon <- reify ty - case tyCon of - DataD _ _ _ _ cs _ -> concat <$> do - xs <- mapM makePatternFor cs - xs' <- makeCompletePragma cs - ys <- mapM makePatternEFor cs - ys' <- makeCompletePragmaE cs - zs <- mapM makePatternTFor cs - zs' <- makeCompletePragmaT cs - ws <- mapM makePatternTEFor cs - ws' <- makeCompletePragmaTE cs - return (xs ++ [xs'] ++ ys ++ [ys'] ++ zs ++ [zs'] ++ ws ++ [ws']) - - _ -> fail "Can only make patterns for data types." - - -makeCompletePragma :: [Con] -> Q [Dec] -makeCompletePragma cs = do - DataConI varName _ _ <- reify 'Pure - let names = [mkName (removeF (nameBase name)) | NormalC name _ <- cs] - return [PragmaD (CompleteP (varName : names) Nothing)] - where - removeF s = take (length s - 1) s - -makeCompletePragmaE :: [Con] -> Q [Dec] -makeCompletePragmaE cs = do - DataConI varName _ _ <- reify 'Pure - PatSynI extName _ <- reify 'ExtE - let names = [mkName (removeF (nameBase name)) | NormalC name _ <- cs] - return [PragmaD (CompleteP (varName : extName : names) Nothing)] - where - removeF s = take (length s - 1) s <> "E" - -makeCompletePragmaT :: [Con] -> Q [Dec] -makeCompletePragmaT cs = do - DataConI varName _ _ <- reify 'Pure - let names = [mkName (removeF (nameBase name)) | NormalC name _ <- cs] - return [PragmaD (CompleteP (varName : names) Nothing)] - where - removeF s = take (length s - 1) s <> "T" - -makeCompletePragmaTE :: [Con] -> Q [Dec] -makeCompletePragmaTE cs = do - DataConI varName _ _ <- reify 'Pure - let names = [mkName (removeF (nameBase name)) | NormalC name _ <- cs] - return [PragmaD (CompleteP (varName : names) Nothing)] - where - removeF s = take (length s - 1) s <> "TE" - -makePatternFor :: Con -> Q [Dec] -makePatternFor = \case - NormalC name xs -> do - args <- replicateM (length xs) (newName "x") - let patName = mkName (removeF (nameBase name)) - patArgs = PrefixPatSyn args - dir = ImplBidir - pat <- [p| Free $(pure (mkConP name (VarP <$> args))) |] - return [PatSynD patName patArgs dir pat] - _ -> fail "Can only make patterns for NormalC constructors" - where - removeF s = take (length s - 1) s - -makePatternEFor :: Con -> Q [Dec] -makePatternEFor = \case - NormalC name xs -> do - args <- replicateM (length xs) (newName "x") - let patName = mkName (removeF (nameBase name)) - patArgs = PrefixPatSyn args - dir = ImplBidir - pat <- [p| Free (InL $(pure (mkConP name (VarP <$> args)))) |] - return [PatSynD patName patArgs dir pat] - _ -> fail "Can only make patterns for NormalC constructors" - where - removeF s = take (length s - 1) s <> "E" - -makePatternTFor :: Con -> Q [Dec] -makePatternTFor = \case - NormalC name xs -> do - t <- newName "type_" - args <- replicateM (length xs) (newName "x") - let patName = mkName (removeF (nameBase name)) - patArgs = PrefixPatSyn (t : args) - dir = ImplBidir - pat <- [p| Free (AnnF $(pure (VarP t)) $(pure (mkConP name (VarP <$> args)))) |] - return [PatSynD patName patArgs dir pat] - _ -> fail "Can only make patterns for NormalC constructors" - where - removeF s = take (length s - 1) s <> "T" - -makePatternTEFor :: Con -> Q [Dec] -makePatternTEFor = \case - NormalC name xs -> do - t <- newName "type_" - args <- replicateM (length xs) (newName "x") - let patName = mkName (removeF (nameBase name)) - patArgs = PrefixPatSyn (t : args) - dir = ImplBidir - pat <- [p| Free (InL (AnnF $(pure (VarP t)) $(pure (mkConP name (VarP <$> args))))) |] - return [PatSynD patName patArgs dir pat] - _ -> fail "Can only make patterns for NormalC constructors" - where - removeF s = take (length s - 1) s <> "TE" diff --git a/src/Language/Rzk/Foil/Convert.hs b/src/Language/Rzk/Foil/Convert.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rzk/Foil/Convert.hs @@ -0,0 +1,356 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Surface syntax to the free-foil core. +-- +-- A transcription of @toTerm@ from "Language.Rzk.Foil.Names", with the variable +-- handling replaced. The environment is still a function from a surface +-- identifier to a term, as before; what changes is what happens at a binder: +-- +-- * a binder is a fresh 'Foil.NameBinder' rather than the de Bruijn @Z@; +-- * the environment is carried into the binder's scope with 'Foil.sink', which +-- is a coercion, where the old representation shifted every entry with +-- @S \<$\>@ and so rebuilt every term it held. +-- +-- A pattern binder still binds exactly /one/ variable, as before: the components +-- of @\\ (t , s) -> …@ are projections of it, and 'Binder' records the names so +-- they can be shown back to the user. +module Language.Rzk.Foil.Convert where + +import Control.Monad.Foil (Distinct, NameBinder, NameMap, Scope) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Foil.Internal (NameMap (..)) +import Control.Monad.Free.Foil (AST (..), ScopedAST (..)) +import Data.Data (Data, cast, gmapQ) +import Data.Functor (void) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import qualified Data.Set as Set +import Debug.Trace (trace) -- FIXME: use proper mechanisms for warnings + +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), Display, TModality (..), + VarIdent, holeName, toBinder, varIdent) +import qualified Language.Rzk.Foil.Names as Free +import qualified Language.Rzk.Syntax as Rzk + +-- | The environment: what a surface identifier stands for in the current scope. +-- A pattern binder maps its leaves to projections of the single variable it +-- binds, which is why this is a map to /terms/ and not to names. +type Env n = VarIdent -> Term n + +-- | Translate a closed surface term. +toTermClosed :: Rzk.Term -> Term Foil.VoidS +toTermClosed = toTerm Foil.emptyScope unbound + where + unbound x = error ("undefined variable: " <> show x) + +-- | Enter a pattern binder: bind one fresh name, map the pattern's leaves to +-- projections of it, and carry the rest of the environment in with 'Foil.sink'. +toScopedPattern + :: Distinct n + => Scope n -> Rzk.Pattern -> Env n -> Rzk.Term -> ScopedAST NameBinder TermSig n +toScopedPattern scope pat env body = + Foil.withFresh scope $ \binder -> + let scope' = Foil.extendScope binder scope + bound = bindings pat (Var (Foil.nameOf binder)) + env' x = case lookup x bound of + Just t -> t + Nothing -> Foil.sink (env x) -- O(1): the old representation shifted every node + in ScopedAST binder (toTerm scope' env' body) + +-- | Enter an anonymous binder (a non-dependent function type binds nothing). +toScopedAnon + :: Distinct n + => Scope n -> Env n -> Rzk.Term -> ScopedAST NameBinder TermSig n +toScopedAnon scope env body = + Foil.withFresh scope $ \binder -> + let scope' = Foil.extendScope binder scope + in ScopedAST binder (toTerm scope' (Foil.sink . env) body) + +-- | What each leaf of a pattern stands for: a projection chain over the single +-- variable the pattern binds. +bindings :: Rzk.Pattern -> Term n -> [(VarIdent, Term n)] +bindings (Rzk.PatternUnit _loc) _ = [] +bindings (Rzk.PatternVar _loc (Rzk.VarIdent _ "_")) _ = [] +bindings (Rzk.PatternVar _loc x) t = [(varIdent x, t)] +bindings (Rzk.PatternPair _loc l r) t = bindings l (First t) <> bindings r (Second t) +bindings (Rzk.PatternTuple loc p1 p2 ps) t = + bindings (Free.desugarTuple loc (reverse ps) p2 p1) t + +toTerm :: forall n. Distinct n => Scope n -> Env n -> Rzk.Term -> Term n +toTerm scope env = go + where + -- Desugar a deprecated notation, telling the user what to write instead. + deprecated t t' = trace msg (go t') + where + msg = unlines + [ "[DEPRECATED]:" <> ppBNFC'Position (Rzk.hasPosition t) + , "the following notation is deprecated and will be removed from future version of rzk:" + , " " <> Rzk.printTree t + , "instead consider using the following notation:" + , " " <> Rzk.printTree t' + ] + + ppBNFC'Position Nothing = "" + ppBNFC'Position (Just (line_, col)) = " at line " <> show line_ <> " column " <> show col + + -- A notation that is fine, but that a simpler one says as well. + lint orig suggestion = trace $ unlines + [ "[HINT]:" <> ppBNFC'Position (Rzk.hasPosition orig) <> " consider replacing" + , " " <> Rzk.printTree orig + , "with the following" + , " " <> Rzk.printTree suggestion + ] + + go :: Rzk.Term -> Term n + go = \case + -- ASCII aliases and deprecations are desugared exactly as before. + t@(Rzk.RecOrDeprecated loc psi phi a_psi a_phi) -> deprecated t + (Rzk.RecOr loc [Rzk.Restriction loc psi a_psi, Rzk.Restriction loc phi a_phi]) + t@(Rzk.TypeExtensionDeprecated loc shape type_) -> deprecated t + (Rzk.TypeFun loc shape type_) + t@(Rzk.TypeFun loc (Rzk.ParamTermTypeDeprecated loc' pat type_) ret) -> deprecated t + (Rzk.TypeFun loc (Rzk.ParamTermType loc' (Free.patternToTerm pat) type_) ret) + t@(Rzk.TypeFun loc (Rzk.ParamVarShapeDeprecated loc' pat cube tope) ret) -> deprecated t + (Rzk.TypeFun loc (Rzk.ParamTermShape loc' (Free.patternToTerm pat) cube tope) ret) + t@(Rzk.Lambda loc (Rzk.ParamPatternShapeDeprecated loc' pat cube tope : params) body) -> deprecated t + (Rzk.Lambda loc (Rzk.ParamPatternShape loc' [pat] cube tope : params) body) + + Rzk.ASCII_CubeUnitStar loc -> go (Rzk.CubeUnitStar loc) + Rzk.ASCII_Cube2_0 loc -> go (Rzk.Cube2_0 loc) + Rzk.ASCII_Cube2_1 loc -> go (Rzk.Cube2_1 loc) + Rzk.ASCII_TopeTop loc -> go (Rzk.TopeTop loc) + Rzk.ASCII_TopeBottom loc -> go (Rzk.TopeBottom loc) + Rzk.ASCII_TopeEQ loc l r -> go (Rzk.TopeEQ loc l r) + Rzk.ASCII_TopeLEQ loc l r -> go (Rzk.TopeLEQ loc l r) + Rzk.ASCII_TopeAnd loc l r -> go (Rzk.TopeAnd loc l r) + Rzk.ASCII_TopeOr loc l r -> go (Rzk.TopeOr loc l r) + Rzk.ASCII_TypeFun loc param ret -> go (Rzk.TypeFun loc param ret) + Rzk.ASCII_TypeSigma loc pat ty ret -> go (Rzk.TypeSigma loc pat ty ret) + Rzk.ASCII_TypeSigmaTuple loc p ps tN -> go (Rzk.TypeSigmaTuple loc p ps tN) + Rzk.ASCII_Lambda loc pat ret -> go (Rzk.Lambda loc pat ret) + Rzk.ASCII_TypeExtensionDeprecated loc shape type_ -> + go (Rzk.TypeExtensionDeprecated loc shape type_) + Rzk.ASCII_First loc term -> go (Rzk.First loc term) + Rzk.ASCII_Second loc term -> go (Rzk.Second loc term) + Rzk.ASCII_CubeI loc -> go (Rzk.CubeI loc) + Rzk.ASCII_CubeI_0 loc -> go (Rzk.CubeI_0 loc) + Rzk.ASCII_CubeI_1 loc -> go (Rzk.CubeI_1 loc) + + Rzk.Var _loc x -> env (varIdent x) + Rzk.Universe _loc -> Universe + Rzk.UniverseCube _loc -> UniverseCube + Rzk.UniverseTope _loc -> UniverseTope + Rzk.CubeUnit _loc -> CubeUnit + Rzk.CubeUnitStar _loc -> CubeUnitStar + Rzk.Cube2 _loc -> Cube2 + Rzk.Cube2_0 _loc -> Cube2_0 + Rzk.Cube2_1 _loc -> Cube2_1 + Rzk.CubeI _loc -> CubeI + Rzk.CubeI_0 _loc -> CubeI_0 + Rzk.CubeI_1 _loc -> CubeI_1 + Rzk.CubeProduct _loc l r -> CubeProduct (go l) (go r) + Rzk.TopeTop _loc -> TopeTop + Rzk.TopeBottom _loc -> TopeBottom + Rzk.TopeEQ _loc l r -> TopeEQ (go l) (go r) + Rzk.TopeLEQ _loc l r -> TopeLEQ (go l) (go r) + Rzk.TopeAnd _loc l r -> TopeAnd (go l) (go r) + Rzk.TopeOr _loc l r -> TopeOr (go l) (go r) + Rzk.TopeInv _loc t -> TopeInv (go t) + Rzk.TopeUninv _loc t -> TopeUninv (go t) + Rzk.CubeFlip _loc t -> CubeFlip (go t) + Rzk.CubeUnflip _loc t -> CubeUnflip (go t) + Rzk.RecBottom _loc -> RecBottom + Rzk.RecOr _loc rs -> RecOr (map restriction rs) + Rzk.TypeId _loc x tA y -> TypeId (go x) (Just (go tA)) (go y) + Rzk.TypeIdSimple _loc x y -> TypeId (go x) Nothing (go y) + Rzk.TypeUnit _loc -> TypeUnit + Rzk.Unit _loc -> Unit + Rzk.App _loc f x -> App (go f) (go x) + Rzk.Pair _loc l r -> Pair (go l) (go r) + Rzk.Tuple loc p1 p2 (p : ps) -> go (Rzk.Tuple loc (Rzk.Pair loc p1 p2) p ps) + Rzk.Tuple loc p1 p2 [] -> go (Rzk.Pair loc p1 p2) + Rzk.First _loc term -> First (go term) + Rzk.Second _loc term -> Second (go term) + Rzk.Refl _loc -> Refl Nothing + Rzk.ReflTerm _loc term -> Refl (Just (go term, Nothing)) + Rzk.ReflTermType _loc x tA -> Refl (Just (go x, Just (go tA))) + Rzk.IdJ _loc a b c d e f -> IdJ (go a) (go b) (go c) (go d) (go e) (go f) + Rzk.TypeAsc _loc x t -> TypeAsc (go x) (go t) + + -- A binder may name several variables sharing a type, e.g. @(x y : A)@, + -- which parses as an application spine; desugar into nested one-variable + -- binders, as before. + Rzk.TypeFun loc (Rzk.ParamTermType loc' patTerm arg) ret + | _ : _ : _ <- vars -> + go (foldr (\v -> Rzk.TypeFun loc (Rzk.ParamTermType loc' v arg)) ret vars) + where vars = Free.flattenBinderApp patTerm + Rzk.TypeFun loc (Rzk.ParamTermModalType loc' patTerm mc ty) ret + | _ : _ : _ <- vars -> + go (foldr (\v -> Rzk.TypeFun loc (Rzk.ParamTermModalType loc' v mc ty)) ret vars) + where vars = Free.flattenBinderApp patTerm + + Rzk.TypeFun _loc (Rzk.ParamTermModalType _loc' patTerm mc ty) ret -> + let pat = Free.unsafeTermToPattern patTerm + md = Free.modalColonToTModality mc + in TypeFun (toBinder pat) md (go ty) Nothing (toScopedPattern scope pat env ret) + Rzk.TypeFun _loc (Rzk.ParamTermModalShape _loc' patTerm mc cube tope) ret -> + let pat = Free.unsafeTermToPattern patTerm + md = Free.modalColonToTModality mc + in TypeFun (toBinder pat) md (go cube) + (Just (toScopedPattern scope pat env tope)) + (toScopedPattern scope pat env ret) + Rzk.TypeFun _loc (Rzk.ParamTermType _ patTerm arg) ret -> + let pat = Free.unsafeTermToPattern patTerm + in TypeFun (toBinder pat) Id (go arg) Nothing (toScopedPattern scope pat env ret) + t@(Rzk.TypeFun loc (Rzk.ParamTermShape loc' patTerm cube tope) ret) -> + let lint' = case tope of + -- a shape whose tope is a predicate applied to exactly the binder + -- is the type of that predicate, and says so more directly + Rzk.App _loc fun arg | void arg == void patTerm -> + lint t (Rzk.TypeFun loc (Rzk.ParamTermType loc' patTerm fun) ret) + _ -> id + pat = Free.unsafeTermToPattern patTerm + in lint' $ TypeFun (toBinder pat) Id (go cube) + (Just (toScopedPattern scope pat env tope)) + (toScopedPattern scope pat env ret) + Rzk.TypeFun _loc (Rzk.ParamType _ arg) ret -> + TypeFun (BinderVar Nothing) Id (go arg) Nothing (toScopedAnon scope env ret) + + Rzk.TypeSigma _loc pat tA tB -> + TypeSigma (toBinder pat) Id (go tA) (toScopedPattern scope pat env tB) + Rzk.TypeSigmaModal _loc pat mc ty body -> + TypeSigma (toBinder pat) (Free.modalColonToTModality mc) (go ty) + (toScopedPattern scope pat env body) + Rzk.TypeSigmaTuple loc (Rzk.SigmaParamModal _loc' pat mc ty) rest body -> + let tailSigma = case rest of + [] -> body + [sp] -> Free.sigmaParamToTypeSigma loc sp body + (sp:sps) -> Rzk.TypeSigmaTuple loc sp sps body + in TypeSigma (toBinder pat) (Free.modalColonToTModality mc) (go ty) + (toScopedPattern scope pat env tailSigma) + Rzk.TypeSigmaTuple loc (Rzk.SigmaParam _ patA tA) (mp@Rzk.SigmaParamModal{} : rest) body -> + go (Rzk.TypeSigma loc patA tA (case rest of + [] -> Free.sigmaParamToTypeSigma loc mp body + _ -> Rzk.TypeSigmaTuple loc mp rest body)) + Rzk.TypeSigmaTuple loc (Rzk.SigmaParam _ patA tA) (Rzk.SigmaParam _ patB tB : ps) tN -> + go (Rzk.TypeSigmaTuple loc (Rzk.SigmaParam loc patX tX) ps tN) + where + patX = Rzk.PatternPair loc patA patB + tX = Rzk.TypeSigma loc patA tA tB + Rzk.TypeSigmaTuple loc (Rzk.SigmaParam _ pat tA) [] tB -> go (Rzk.TypeSigma loc pat tA tB) + + Rzk.Lambda loc (Rzk.ParamPatternModalType _ [] _mc _ty : params) body -> + go (Rzk.Lambda loc params body) + Rzk.Lambda loc (Rzk.ParamPatternModalType loc' (pat:pats) mc ty : params) body -> + Lambda (toBinder pat) (Just (LambdaParam (Free.modalColonToTModality mc) (go ty) Nothing)) + (toScopedPattern scope pat env + (Rzk.Lambda loc (if null pats then params else Rzk.ParamPatternModalType loc' pats mc ty : params) body)) + Rzk.Lambda loc (Rzk.ParamPatternModalShape _ [] _mc _cube _tope : params) body -> + go (Rzk.Lambda loc params body) + Rzk.Lambda loc (Rzk.ParamPatternModalShape loc' (pat:pats) mc cube tope : params) body -> + Lambda (toBinder pat) + (Just (LambdaParam (Free.modalColonToTModality mc) (go cube) + (Just (toScopedPattern scope pat env tope)))) + (toScopedPattern scope pat env + (Rzk.Lambda loc (if null pats then params else Rzk.ParamPatternModalShape loc' pats mc cube tope : params) body)) + Rzk.Lambda _loc [] body -> go body + Rzk.Lambda loc (Rzk.ParamPattern _ pat : params) body -> + Lambda (toBinder pat) Nothing + (toScopedPattern scope pat env (Rzk.Lambda loc params body)) + Rzk.Lambda loc (Rzk.ParamPatternType _ [] _ty : params) body -> + go (Rzk.Lambda loc params body) + Rzk.Lambda loc (Rzk.ParamPatternType loc' (pat:pats) ty : params) body -> + Lambda (toBinder pat) (Just (LambdaParam Id (go ty) Nothing)) + (toScopedPattern scope pat env + (Rzk.Lambda loc (Rzk.ParamPatternType loc' pats ty : params) body)) + Rzk.Lambda loc (Rzk.ParamPatternShape _ [] _cube _tope : params) body -> + go (Rzk.Lambda loc params body) + t@(Rzk.Lambda loc (Rzk.ParamPatternShape loc' (pat:pats) cube tope : params) body) -> + let lint' = case tope of + Rzk.App _loc fun arg + | null pats && void arg == void (Free.patternToTerm pat) -> + lint t (Rzk.Lambda loc (Rzk.ParamPatternType loc' [pat] fun : params) body) + _ -> id + in lint' $ Lambda (toBinder pat) + (Just (LambdaParam Id (go cube) (Just (toScopedPattern scope pat env tope)))) + (toScopedPattern scope pat env + (Rzk.Lambda loc (Rzk.ParamPatternShape loc' pats cube tope : params) body)) + + Rzk.Let _loc (Rzk.BindPattern _ pat) val expr -> + Let (toBinder pat) Nothing (go val) (toScopedPattern scope pat env expr) + Rzk.Let _loc (Rzk.BindPatternType _ pat ty) val expr -> + Let (toBinder pat) (Just (go ty)) (go val) (toScopedPattern scope pat env expr) + + Rzk.TypeRestricted _loc ty rs -> TypeRestricted (go ty) (map restriction rs) + Rzk.Hole _loc (Rzk.HoleIdent _ (Rzk.HoleIdentToken tok)) -> Hole (holeName tok) + Rzk.ModApp _loc md body -> ModApp (Free.toModality md) (go body) + Rzk.ModType _loc md ty -> TypeModal (Free.toModality md) (go ty) + Rzk.ModExtract{} -> error "$extract$ is an internal term and cannot appear in source" + Rzk.LetMod _loc comp (Rzk.BindPattern _ pat) val body -> + let (app, inn) = Free.modCompToMods comp + in LetMod (toBinder pat) app inn Nothing (go val) + (toScopedPattern scope pat env body) + Rzk.LetMod _loc comp (Rzk.BindPatternType _ pat ty) val body -> + let (app, inn) = Free.modCompToMods comp + in LetMod (toBinder pat) app inn (Just (go ty)) (go val) + (toScopedPattern scope pat env body) + + restriction = \case + Rzk.Restriction _loc tope term -> (go tope, go term) + Rzk.ASCII_Restriction _loc tope term -> (go tope, go term) + +-- * Open terms + +-- | Elaborate a surface term whose free identifiers are not known in advance. +-- +-- Each identifier occurring anywhere in the term gets a name in a fresh scope, so +-- an /open/ term (the annotation of a binder, say, taken out of its context) can be +-- put into the core, transformed, and printed back with the names it came in with. +-- The reference index needs this: it splits the annotation of a pair binder through +-- the core, and has no typing context to hand. +withOpenTerm + :: forall r. Rzk.Term + -> (forall n. Distinct n + => Foil.Scope n -> NameMap n Display -> Term n -> r) + -> r +withOpenTerm term k = go Foil.emptyScope [] Map.empty idents + where + idents = nubOrd (map varIdent (collectVarIdents term)) + + go :: forall n. Distinct n + => Foil.Scope n -> [(VarIdent, Foil.Name n)] -> Map VarIdent Display + -> [VarIdent] -> r + go scope bound names [] = + k scope (namesOf bound names) (toTerm scope (envOf bound) term) + go scope bound names (x : xs) = + Foil.withFresh scope $ \binder -> + let scope' = Foil.extendScope binder scope + bound' = (x, Foil.nameOf binder) : map (fmap Foil.sink) bound + in go scope' bound' (Map.insert x (x, BinderVar (Just x)) names) xs + + envOf bound x = case lookup x bound of + Just v -> Var v + -- unreachable: every identifier occurring in the term was given a name above + Nothing -> error ("withOpenTerm: uncollected identifier " <> show x) + + namesOf bound names = NameMap $ IntMap.fromList + [ (Foil.nameId v, display) + | (x, v) <- bound + , Just display <- [Map.lookup x names] + ] + +-- | Every identifier occurring in a piece of surface syntax, bound or free. +collectVarIdents :: Data a => a -> [Rzk.VarIdent] +collectVarIdents x = + maybe [] (:[]) (cast x) ++ concat (gmapQ collectVarIdents x) + +nubOrd :: Ord a => [a] -> [a] +nubOrd = Set.toList . Set.fromList diff --git a/src/Language/Rzk/Foil/Names.hs b/src/Language/Rzk/Foil/Names.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rzk/Foil/Names.hs @@ -0,0 +1,352 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Surface names, binders and modalities. +-- +-- These are what the checker shows the user, and they are independent of how a +-- term represents its variables: a 'VarIdent' is a surface identifier (with the +-- position of its defining occurrence), and a 'Binder' records the /names/ a binder +-- introduces — including a pair pattern, which still binds exactly one variable +-- whose components are projections of it. +module Language.Rzk.Foil.Names where + +import Data.Char (chr, ord) +import Data.Coerce (coerce) +import Data.List (intercalate) +import Data.Maybe (fromMaybe) +import Data.String (IsString (..)) +import Data.Set (Set) +import qualified Data.Set as Set +import qualified Data.Text as T + +import qualified Language.Rzk.Syntax as Rzk + +-- | An identifier that is not in scope becomes a hole under a /marked/ name. +-- +-- A free-foil term refers to a variable by name, and an unresolved identifier has +-- none — so the term cannot represent it. Elaboration marks it instead, and the +-- checker reports it when it reaches it, which is what keeps the error where the +-- identifier was used (inside the binders and topes it was written under) rather +-- than at the top of the declaration. +-- +-- The marker cannot be mistaken for a hole the user wrote: the grammar forbids @#@ +-- in an identifier. +markUnresolved :: VarIdent -> VarIdent +markUnresolved x = fromString ('#' : show x) + +unmarkUnresolved :: VarIdent -> Maybe VarIdent +unmarkUnresolved x = case show x of + '#' : name -> Just (fromString name) + _ -> Nothing + +-- | What a bound name is shown as: the display name standing for the variable +-- itself, and the (freshened) binder, which gives the pattern to print and the +-- component names to fold projections back to. +type Display = (VarIdent, Binder) + +-- | The annotation on every node of a typed term: its type, plus its memoised weak +-- head and normal forms. +data TypeInfo term = TypeInfo + { infoType :: term + , infoWHNF :: Maybe term + , infoNF :: Maybe term + } deriving (Functor, Foldable, Traversable) + +data RzkPosition = RzkPosition + { rzkFilePath :: Maybe FilePath + , rzkLineCol :: Rzk.BNFC'Position + } + +ppRzkPosition :: RzkPosition -> String +ppRzkPosition RzkPosition{..} = intercalate ":" $ concat + [ [fromMaybe "" rzkFilePath] + , foldMap (\(row, col) -> map show [row, col]) rzkLineCol] + +newtype VarIdent = VarIdent { getVarIdent :: Rzk.VarIdent' RzkPosition } + +instance Show VarIdent where + show = Rzk.printTree . getVarIdent + +-- | Identifiers are equal when they are spelled the same, whatever their source +-- positions. +-- +-- Written out rather than @(==) \`on\` (void . getVarIdent)@, which allocated a +-- position-free copy of the whole syntax node and compared that: identifier +-- equality is on the hot path (every name lookup, every refreshing of a display +-- name, every match of two terms that mention a hole), and profiling put it at 6% +-- of the checker's time. +instance Eq VarIdent where + VarIdent (Rzk.VarIdent _ x) == VarIdent (Rzk.VarIdent _ y) = x == y + +-- | Identifiers are ordered by name, ignoring the source position, so that the +-- order agrees with 'Eq'. Only used to key identifiers in a set or a map. +instance Ord VarIdent where + compare (VarIdent (Rzk.VarIdent _ x)) (VarIdent (Rzk.VarIdent _ y)) = compare x y + +instance IsString VarIdent where + fromString s = VarIdent (Rzk.VarIdent (RzkPosition Nothing Nothing) (fromString s)) + +ppVarIdentWithLocation :: VarIdent -> String +ppVarIdentWithLocation (VarIdent var@(Rzk.VarIdent pos _ident)) = + Rzk.printTree var <> " (" <> ppRzkPosition pos <> ")" + +varIdent :: Rzk.VarIdent -> VarIdent +varIdent = varIdentAt Nothing + +varIdentAt :: Maybe FilePath -> Rzk.VarIdent -> VarIdent +varIdentAt path (Rzk.VarIdent pos ident) = VarIdent (Rzk.VarIdent (RzkPosition path pos) ident) + +fromVarIdent :: VarIdent -> Rzk.VarIdent +fromVarIdent (VarIdent (Rzk.VarIdent (RzkPosition _file pos) ident)) = Rzk.VarIdent pos ident + +-- | The display name of a hole from its surface token text. The token includes +-- the leading @?@; an anonymous hole (bare @?@) has no name. +holeName :: T.Text -> Maybe VarIdent +holeName tok = + case T.drop 1 tok of + name | T.null name -> Nothing + | otherwise -> Just (fromString (T.unpack name)) + +-- | The surface token text (including the leading @?@) for a hole name. +holeIdentToken :: Maybe VarIdent -> T.Text +holeIdentToken Nothing = "?" +holeIdentToken (Just x) = "?" <> T.pack (show x) + +-- | The name(s) a binder introduces. A binder may name a single (possibly +-- anonymous) variable, or destructure a pair\/tuple via a pattern. The pattern +-- structure is kept around purely so that goals, holes and error messages can +-- show the user's original names (e.g. @t@ and @s@ for @\\ (t , s) -> …@) +-- instead of projections of a fresh variable (e.g. @π₁ x₄@ and @π₂ x₄@). +-- +-- Operationally a pair pattern still binds a /single/ variable; the components +-- are projections of it (see 'toScopePattern'). 'Binder' only records the names +-- so they can be restored when rendering. +data Binder + = BinderVar (Maybe VarIdent) -- ^ a single variable (@Nothing@ for @_@) + | BinderPair Binder Binder -- ^ a pair pattern @(l , r)@ + | BinderUnit -- ^ the unit pattern @unit@ + deriving (Eq) + +-- | The single name of a binder, if it binds exactly one named variable. +-- A pair\/unit pattern has no single name, so this is 'Nothing' for them. +-- Used wherever the old @Maybe VarIdent@ binder name is still sufficient. +binderName :: Binder -> Maybe VarIdent +binderName (BinderVar mname) = mname +binderName _ = Nothing + +data TModality = Sharp | Flat | Op | Id deriving (Eq, Show) + +toModality :: Rzk.Modality -> TModality +toModality Rzk.Sharp{} = Sharp +toModality Rzk.ASCII_Sharp{} = Sharp +toModality Rzk.Flat{} = Flat +toModality Rzk.ASCII_Flat{} = Flat +toModality Rzk.Op{} = Op +toModality Rzk.ASCII_Op{} = Op +toModality Rzk.Id{} = Id + +modCompToMods :: Rzk.ModComp -> (TModality, TModality) +modCompToMods (Rzk.Single _ m) = (Id, toModality m) +modCompToMods (Rzk.Comp _ ext inn) = (toModality ext, toModality inn) + +fromMod :: TModality -> Rzk.Modality +fromMod Sharp = Rzk.Sharp Nothing +fromMod Flat = Rzk.Flat Nothing +fromMod Op = Rzk.Op Nothing +fromMod Id = Rzk.Id Nothing + +modsToModComp :: TModality -> TModality -> Rzk.ModComp +modsToModComp Id inn = Rzk.Single Nothing (fromMod inn) +modsToModComp ext inn = Rzk.Comp Nothing (fromMod ext) (fromMod inn) + + +-- | A tuple pattern is sugar for nested pairs. +desugarTuple :: Rzk.BNFC'Position -> [Rzk.Pattern] -> Rzk.Pattern -> Rzk.Pattern -> Rzk.Pattern +desugarTuple loc ps p2 p1 = + case ps of + [] -> Rzk.PatternPair loc p1 p2 + pLast : ps' -> Rzk.PatternPair loc (desugarTuple loc ps' p2 p1) pLast + + +toBinder :: Rzk.Pattern -> Binder +toBinder (Rzk.PatternVar _loc (Rzk.VarIdent _ "_")) = BinderVar Nothing +toBinder (Rzk.PatternVar _loc x) = BinderVar (Just (varIdent x)) +toBinder (Rzk.PatternUnit _loc) = BinderUnit +toBinder (Rzk.PatternPair _loc l r) = BinderPair (toBinder l) (toBinder r) +toBinder (Rzk.PatternTuple loc p1 p2 ps) = toBinder (desugarTuple loc (reverse ps) p2 p1) + +patternToTerm :: Rzk.Pattern -> Rzk.Term +patternToTerm = ptt + where + ptt = \case + Rzk.PatternVar loc x -> Rzk.Var loc x + Rzk.PatternPair loc l r -> Rzk.Pair loc (ptt l) (ptt r) + Rzk.PatternUnit loc -> Rzk.Unit loc + Rzk.PatternTuple loc p1 p2 ps -> patternToTerm (desugarTuple loc (reverse ps) p2 p1) + + +modalColonModality :: Rzk.ModalColon -> Rzk.Modality +modalColonModality = \case + Rzk.ModalColonFlat loc -> Rzk.Flat loc + Rzk.ModalColonSharp loc -> Rzk.Sharp loc + Rzk.ModalColonOp loc -> Rzk.Op loc + Rzk.ModalColonId loc -> Rzk.Id loc + Rzk.ASCII_ModalColonFlat loc -> Rzk.Flat loc + Rzk.ASCII_ModalColonSharp loc -> Rzk.Sharp loc + Rzk.ASCII_ModalColonOp loc -> Rzk.Op loc + +modalColonToTModality :: Rzk.ModalColon -> TModality +modalColonToTModality = toModality . modalColonModality + +fromTModalityToModalColon :: TModality -> Rzk.ModalColon +fromTModalityToModalColon = \case + Sharp -> Rzk.ModalColonSharp Nothing + Flat -> Rzk.ModalColonFlat Nothing + Op -> Rzk.ModalColonOp Nothing + Id -> Rzk.ModalColonId Nothing + +-- | Split a binder term into the individual variables it names. A multi-variable +-- binder like @(x y : A)@ is parsed as the application spine @x y@; this returns +-- @[x, y]@ so each can become its own nested binder. A single binder term (a +-- variable, a pair pattern, …) is returned unchanged as a singleton. +flattenBinderApp :: Rzk.Term -> [Rzk.Term] +flattenBinderApp = \case + Rzk.App _loc f x -> flattenBinderApp f ++ [x] + t -> [t] + +unsafeTermToPattern :: Rzk.Term -> Rzk.Pattern +unsafeTermToPattern = ttp + where + ttp = \case + Rzk.Unit loc -> Rzk.PatternUnit loc + Rzk.Var loc x -> Rzk.PatternVar loc x + Rzk.Pair loc l r -> Rzk.PatternPair loc (ttp l) (ttp r) + Rzk.Tuple loc t1 t2 ts -> Rzk.PatternTuple loc (ttp t1) (ttp t2) (map ttp ts) + term -> error ("ERROR: expected a pattern but got\n " ++ Rzk.printTree term) + +sigmaParamToTypeSigma :: Rzk.BNFC'Position -> Rzk.SigmaParam -> Rzk.Term -> Rzk.Term +sigmaParamToTypeSigma loc sp body = case sp of + Rzk.SigmaParam _ pat ty -> Rzk.TypeSigma loc pat ty body + Rzk.SigmaParamModal _ pat mc ty -> Rzk.TypeSigmaModal loc pat mc ty body + +-- | A projection step: first (@π₁@) or second (@π₂@) component. +data Proj = PFst | PSnd + deriving (Eq) + +-- | Render a 'Binder' as a surface pattern (used to display the binder itself, +-- e.g. @(t , s)@). Anonymous variables become @_@. +binderToPattern :: Binder -> Rzk.Pattern +binderToPattern (BinderVar Nothing) = Rzk.PatternVar Nothing (fromVarIdent "_") +binderToPattern (BinderVar (Just x)) = Rzk.PatternVar Nothing (fromVarIdent x) +binderToPattern (BinderPair l r) = Rzk.PatternPair Nothing (binderToPattern l) (binderToPattern r) +binderToPattern BinderUnit = Rzk.PatternUnit Nothing + + + +-- | A 'VarIdent' that prints as the binder's surface pattern, e.g. @(t , s)@. +-- Used to display a pattern binder in a hole's local context as the pattern +-- itself rather than as the underlying single variable. +binderDisplayName :: Binder -> VarIdent +binderDisplayName = fromString . Rzk.printTree . binderToPattern + +-- | The named leaves of a binder, each paired with the projection path that +-- reaches it from the bound variable. For example @(t , (a , b))@ yields +-- @[([PFst], t), ([PSnd, PFst], a), ([PSnd, PSnd], b)]@. +binderPaths :: Binder -> [([Proj], VarIdent)] +binderPaths (BinderVar (Just x)) = [([], x)] +binderPaths (BinderVar Nothing) = [] +binderPaths BinderUnit = [] +binderPaths (BinderPair l r) = + [ (PFst : p, n) | (p, n) <- binderPaths l ] ++ + [ (PSnd : p, n) | (p, n) <- binderPaths r ] + +-- | The names appearing in a binder. +binderLeaves :: Binder -> [VarIdent] +binderLeaves = map snd . binderPaths + +-- | Does this binder destructure a pair\/tuple (as opposed to naming a single +-- variable or @_@)? +binderIsCompound :: Binder -> Bool +binderIsCompound BinderVar{} = False +binderIsCompound _ = True + +-- | Refresh the named leaves of a binder so they avoid the given names (and one +-- another). Anonymous leaves and the unit pattern are left unchanged. +freshenBinderLeaves :: [VarIdent] -> Binder -> Binder +freshenBinderLeaves used = snd . go used + where + go u (BinderVar (Just x)) = let x' = refreshVar u x in (x' : u, BinderVar (Just x')) + go u b@(BinderVar Nothing) = (u, b) + go u BinderUnit = (u, BinderUnit) + go u (BinderPair l r) = + let (u1, l') = go u l + (u2, r') = go u1 r + in (u2, BinderPair l' r') + +-- | Decompose a chain of projections applied to a variable into the projection +-- path /from the variable outwards/, matching 'binderPaths'. The outermost +-- projection is applied last, so it goes at the /end/ of the path: e.g. +-- @π₂ (π₁ x)@ (select @π₁@ first, then @π₂@) becomes @Just ([PFst, PSnd], x)@. + +defaultVarIdents :: [VarIdent] +defaultVarIdents = + [ fromString name + | n <- [1 :: Int ..] + , let name = "x" <> map digitToSub (show n) ] + where + digitToSub c = chr ((ord c - ord '0') + ord '₀') + +-- $setup +-- >>> :set -XOverloadedStrings +-- >>> import qualified Data.Text as T +-- >>> import qualified Data.Set as Set + +-- | Given a list of used variable names in the current context, +-- generate a unique fresh name based on a given one. +-- +-- >>> print $ refreshVar ["x", "y", "x₁", "z"] "x" +-- x₂ +refreshVar :: [VarIdent] -> VarIdent -> VarIdent +refreshVar vars x + | x `elem` vars = refreshVar vars (incVarIdentIndex x) + | otherwise = x + +-- | Refresh a name against a /set/ of taken ones. +-- +-- The list version above is O(taken) per call, and naming a whole context calls it +-- once per entry, which made reading the naming off a context with every top-level +-- definition of a project in it quadratic. +-- +-- >>> print $ refreshVarIn (Set.fromList ["x", "y", "x₁", "z"]) "x" +-- x₂ +refreshVarIn :: Set VarIdent -> VarIdent -> VarIdent +refreshVarIn taken x + | x `Set.member` taken = refreshVarIn taken (incVarIdentIndex x) + | otherwise = x + +incVarIdentIndex :: VarIdent -> VarIdent +incVarIdentIndex (VarIdent (Rzk.VarIdent loc token)) = + VarIdent (Rzk.VarIdent loc (coerce incIndex token)) + +-- | Increment the subscript number at the end of the indentifier. +-- +-- >>> putStrLn $ T.unpack $ incIndex "x" +-- x₁ +-- >>> putStrLn $ T.unpack $ incIndex "x₁₉" +-- x₂₀ +incIndex :: T.Text -> T.Text +incIndex s = T.pack $ name <> newIndex + where + digitsSub = "₀₁₂₃₄₅₆₇₈₉" :: String + isDigitSub = (`elem` digitsSub) + digitFromSub c = chr ((ord c - ord '₀') + ord '0') + digitToSub c = chr ((ord c - ord '0') + ord '₀') + (name, index) = break isDigitSub (T.unpack s) + oldIndexN = read ('0' : map digitFromSub index) :: Int -- FIXME: read + newIndex = map digitToSub (show (oldIndexN + 1)) diff --git a/src/Language/Rzk/Foil/Print.hs b/src/Language/Rzk/Foil/Print.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rzk/Foil/Print.hs @@ -0,0 +1,246 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The free-foil core back to surface syntax. +-- +-- A transcription of @fromTermWith'@ from "Language.Rzk.Foil.Names". The +-- structure is the same, and so are the display rules: +-- +-- * a binder's user-written name is kept, refreshed only against names already +-- in use; an anonymous binder draws from 'defaultVarIdents'; +-- * a pattern binder is shown as the pattern, and projections of the variable +-- it binds are folded back to the component names, so a goal reads +-- @\\ (t , s) -> …@ and not @\\ x -> … π₁ x …@; +-- * an anonymous binder the codomain does not use is not shown at all, so +-- @(x₁ : A) → B@ prints as @A → B@. +-- +-- What changes is the bookkeeping: a variable is a 'Foil.Name', so the display +-- names live in a 'Foil.NameMap' keyed by name, rather than being threaded +-- through de Bruijn shifts. +module Language.Rzk.Foil.Print where + +import Control.Monad.Foil (NameMap) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil (AST (..), ScopedAST (..)) +import Data.Bifoldable (bifoldMap) + +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), Display, Proj (..), + TModality (..), + VarIdent, binderIsCompound, + binderLeaves, binderPaths, + binderToPattern, defaultVarIdents, + fromTModalityToModalColon, + fromVarIdent, fromMod, holeIdentToken, + modsToModComp, patternToTerm, + refreshVar) +import qualified Language.Rzk.Syntax as Rzk + +-- | Print a closed term. +fromTermClosed :: Term Foil.VoidS -> Rzk.Term +fromTermClosed = fromTerm [] defaultVarIdents Foil.emptyNameMap + +fromTerm :: forall n. [VarIdent] -> [VarIdent] -> NameMap n Display -> Term n -> Rzk.Term +fromTerm used supply names = go + where + loc = Nothing + + goMod :: TModality -> Rzk.Modality + goMod = fromMod + + -- Enter a binder and print the scopes it binds over. + -- + -- A Pi-type and a lambda each bind /two/ scopes under one binder (the shape + -- tope and the body). In the old representation both were indexed by the + -- same de Bruijn Z; here each 'ScopedAST' carries its own 'NameBinder'. That + -- is operationally the same (the checker instantiates both with the same + -- argument), but they must be /shown/ under one name, so each scope's binder + -- is mapped to the same display name. + withBinder1 :: Binder -> ScopedTerm n -> ((Binder, Rzk.Term) -> r) -> r + withBinder1 z s k = withBinder z $ \z' printScope -> k (z', printScope s) + + withBinder2 :: Binder -> ScopedTerm n -> ScopedTerm n -> ((Binder, Rzk.Term, Rzk.Term) -> r) -> r + withBinder2 z s1 s2 k = + withBinder z $ \z' printScope -> k (z', printScope s1, printScope s2) + + withBinder + :: Binder + -> (Binder -> (ScopedTerm n -> Rzk.Term) -> r) + -> r + withBinder z k = k z' printScope + where + (z', supply') = freshenBinder used supply z + x = displayNameOf z' supply' + supply'' = case z' of + BinderVar (Just _) -> supply' + _ -> drop 1 supply' + used' = x : used <> binderLeaves z' + printScope (ScopedAST binder body) = + fromTerm used' supply'' (Foil.addNameBinder binder (x, z') names) body + + -- The name standing for the variable itself. A single-variable binder uses + -- its own name; a pattern binder needs a placeholder, which is only shown if + -- the whole point is used (in a shape tope, say), and then it is printed as + -- the pattern anyway. + displayNameOf (BinderVar (Just x)) _ = x + displayNameOf _ (x : _) = x + displayNameOf _ [] = error "not enough fresh variables!" + + -- Refresh a binder's named leaves against the names already in use; draw + -- fresh names for anonymous leaves from the remaining supply. + freshenBinder _ stream (BinderVar Nothing) = + case stream of + x : xs -> (BinderVar (Just x), xs) + _ -> error "not enough fresh variables!" + freshenBinder used' stream (BinderVar (Just z)) = + (BinderVar (Just z'), filter (/= z') stream) + where z' = refreshVar used' z + freshenBinder _ stream BinderUnit = (BinderUnit, stream) + freshenBinder used' stream (BinderPair l r) = + let (l', s1) = freshenBinder used' stream l + (r', s2) = freshenBinder (used' <> binderLeaves l') s1 r + in (BinderPair l' r', s2) + + -- A projection chain over a pattern binder's variable is shown as the + -- component's name: @π₁ x@ is @t@. + projChain :: Term n -> Maybe ([Proj], Foil.Name n) + projChain (First t) = fmap (\(ps, x) -> (PFst : ps, x)) (projChain t) + projChain (Second t) = fmap (\(ps, x) -> (PSnd : ps, x)) (projChain t) + projChain (Var x) = Just ([], x) + projChain _ = Nothing + + foldedProjection :: Term n -> Maybe Rzk.Term + foldedProjection t = do + (ps, x) <- projChain t + case ps of + [] -> Nothing + _ -> do + let (_, binder) = Foil.lookupName x names + leaf <- lookup (reverse ps) (binderPaths binder) + pure (Rzk.Var loc (fromVarIdent leaf)) + + go :: Term n -> Rzk.Term + go t | Just t' <- foldedProjection t = t' + go (Var x) = + case Foil.lookupName x names of + -- A bare use of a pattern binder's variable (the point itself) reads as + -- the pattern, not as the placeholder. + (_, binder) | binderIsCompound binder -> patternToTerm (binderToPattern binder) + (name, _) -> Rzk.Var loc (fromVarIdent name) + + go Universe = Rzk.Universe loc + go UniverseCube = Rzk.UniverseCube loc + go UniverseTope = Rzk.UniverseTope loc + go CubeUnit = Rzk.CubeUnit loc + go CubeUnitStar = Rzk.CubeUnitStar loc + go Cube2 = Rzk.Cube2 loc + go Cube2_0 = Rzk.Cube2_0 loc + go Cube2_1 = Rzk.Cube2_1 loc + go CubeI = Rzk.CubeI loc + go CubeI_0 = Rzk.CubeI_0 loc + go CubeI_1 = Rzk.CubeI_1 loc + go (CubeProduct l r) = Rzk.CubeProduct loc (go l) (go r) + go (CubeFlip t) = Rzk.CubeFlip loc (go t) + go (CubeUnflip t) = Rzk.CubeUnflip loc (go t) + go TopeTop = Rzk.TopeTop loc + go TopeBottom = Rzk.TopeBottom loc + go (TopeEQ l r) = Rzk.TopeEQ loc (go l) (go r) + go (TopeLEQ l r) = Rzk.TopeLEQ loc (go l) (go r) + go (TopeAnd l r) = Rzk.TopeAnd loc (go l) (go r) + go (TopeOr l r) = Rzk.TopeOr loc (go l) (go r) + go (TopeInv t) = Rzk.TopeInv loc (go t) + go (TopeUninv t) = Rzk.TopeUninv loc (go t) + go RecBottom = Rzk.RecBottom loc + go (RecOr rs) = Rzk.RecOr loc [Rzk.Restriction loc (go tope) (go term) | (tope, term) <- rs] + go (Hole mname) = Rzk.Hole loc (Rzk.HoleIdent loc (Rzk.HoleIdentToken (holeIdentToken mname))) + + -- An anonymous binder the codomain does not use is not shown: @(x₁ : A) → B@ + -- reads better as @A → B@. A user-written name is kept even when unused. + go (TypeFun z@(BinderVar Nothing) Id arg Nothing ret) + | not (scopeUsesItsBinder ret) = withBinder1 z ret $ \(_z', ret') -> + Rzk.TypeFun loc (Rzk.ParamType loc (go arg)) ret' + go (TypeFun z md arg Nothing ret) = withBinder1 z ret $ \(z', ret') -> + let pat = patternToTerm (binderToPattern z') + in case md of + Id -> Rzk.TypeFun loc (Rzk.ParamTermType loc pat (go arg)) ret' + _ -> Rzk.TypeFun loc (Rzk.ParamTermModalType loc pat (fromTModalityToModalColon md) (go arg)) ret' + go (TypeFun z md arg (Just tope) ret) = withBinder2 z tope ret $ \(z', tope', ret') -> + let pat = patternToTerm (binderToPattern z') + in case md of + Id -> Rzk.TypeFun loc (Rzk.ParamTermShape loc pat (go arg) tope') ret' + _ -> Rzk.TypeFun loc (Rzk.ParamTermModalShape loc pat (fromTModalityToModalColon md) (go arg) tope') ret' + + go (TypeSigma z md a b) = withBinder1 z b $ \(z', b') -> + case md of + Id -> Rzk.TypeSigma loc (binderToPattern z') (go a) b' + _ -> Rzk.TypeSigmaModal loc (binderToPattern z') (fromTModalityToModalColon md) (go a) b' + + go (TypeId l (Just tA) r) = Rzk.TypeId loc (go l) (go tA) (go r) + go (TypeId l Nothing r) = Rzk.TypeIdSimple loc (go l) (go r) + go (App l r) = Rzk.App loc (go l) (go r) + + go (Lambda z Nothing body) = withBinder1 z body $ \(z', body') -> + Rzk.Lambda loc [Rzk.ParamPattern loc (binderToPattern z')] body' + go (Lambda z (Just (LambdaParam md ty Nothing)) body) = withBinder1 z body $ \(z', body') -> + let pat = binderToPattern z' + param = case md of + Id -> Rzk.ParamPatternType loc [pat] (go ty) + _ -> Rzk.ParamPatternModalType loc [pat] (fromTModalityToModalColon md) (go ty) + in Rzk.Lambda loc [param] body' + go (Lambda z (Just (LambdaParam md cube (Just tope))) body) = + withBinder2 z tope body $ \(z', tope', body') -> + let pat = binderToPattern z' + param = case md of + Id -> Rzk.ParamPatternShape loc [pat] (go cube) tope' + _ -> Rzk.ParamPatternModalShape loc [pat] (fromTModalityToModalColon md) (go cube) tope' + in Rzk.Lambda loc [param] body' + + go (Let z mty val body) = withBinder1 z body $ \(z', body') -> + let bind = case mty of + Nothing -> Rzk.BindPattern loc (binderToPattern z') + Just ty -> Rzk.BindPatternType loc (binderToPattern z') (go ty) + in Rzk.Let loc bind (go val) body' + + go (Pair l r) = Rzk.Pair loc (go l) (go r) + go (First t) = Rzk.First loc (go t) + go (Second t) = Rzk.Second loc (go t) + go TypeUnit = Rzk.TypeUnit loc + go Unit = Rzk.Unit loc + go (Refl Nothing) = Rzk.Refl loc + go (Refl (Just (t, Nothing))) = Rzk.ReflTerm loc (go t) + go (Refl (Just (t, Just ty))) = Rzk.ReflTermType loc (go t) (go ty) + go (IdJ a b c d e f) = Rzk.IdJ loc (go a) (go b) (go c) (go d) (go e) (go f) + go (TypeAsc l r) = Rzk.TypeAsc loc (go l) (go r) + go (TypeRestricted ty rs) = + Rzk.TypeRestricted loc (go ty) [Rzk.Restriction loc (go tope) (go term) | (tope, term) <- rs] + go (TypeModal m ty) = Rzk.ModType loc (goMod m) (go ty) + go (ModApp m t) = Rzk.ModApp loc (goMod m) (go t) + go (ModExtract app inn t) = Rzk.ModExtract loc (Rzk.Comp loc (goMod app) (goMod inn)) (go t) + go (LetMod z app inn mty val body) = withBinder1 z body $ \(z', body') -> + let bind = case mty of + Nothing -> Rzk.BindPattern loc (binderToPattern z') + Just ty -> Rzk.BindPatternType loc (binderToPattern z') (go ty) + in Rzk.LetMod loc (modsToModComp app inn) bind (go val) body' + +-- | Does a scope actually use the variable it binds? +-- +-- Compares name /ids/ rather than names, which sidesteps having to unsink the +-- inner scopes' names back into this one. Ids are unique per binder, so a hit is +-- an occurrence of exactly this binder's variable. +-- +-- (free-foil's own @freeVarsOf@ would do, but it is not in the 0.2.0 release -- +-- it is one of the unreleased helpers on free-foil's @main@.) +scopeUsesItsBinder :: ScopedAST Foil.NameBinder TermSig n -> Bool +scopeUsesItsBinder (ScopedAST binder body) = + Foil.nameId (Foil.nameOf binder) `elem` nameIdsOf body + +-- | Every name id occurring in a term, bound or free. +nameIdsOf :: Term l -> [Int] +nameIdsOf (Var x) = [Foil.nameId x] +nameIdsOf (Node sig) = bifoldMap goScoped nameIdsOf sig + where + goScoped (ScopedAST _binder body) = nameIdsOf body diff --git a/src/Language/Rzk/Foil/Syntax.hs b/src/Language/Rzk/Foil/Syntax.hs new file mode 100644 --- /dev/null +++ b/src/Language/Rzk/Foil/Syntax.hs @@ -0,0 +1,750 @@ +-- The 'ZipMatchK' instances below are orphans: the class is free-foil's and the +-- constant types they cover ('TModality', 'VarIdent', 'Binder') are still the old +-- module's. They come home when the old core goes away. +{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -fno-warn-orphans #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE DeriveFoldable #-} +{-# LANGUAGE DeriveFunctor #-} +{-# LANGUAGE DeriveGeneric #-} +{-# LANGUAGE DeriveTraversable #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE FlexibleInstances #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE MultiParamTypeClasses #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} +{-# LANGUAGE TemplateHaskell #-} +{-# LANGUAGE TypeFamilies #-} +{-# LANGUAGE TypeOperators #-} +{-# LANGUAGE UndecidableInstances #-} + +-- | The core syntax on @free-foil@. +-- +-- This is the successor of "Language.Rzk.Free.Syntax"'s @TermF@ \/ @TermT@, +-- built on 'Foil.AST' instead of the vendored @Free.Scoped@. It is compiled but +-- not yet consumed: the checker still runs on the old representation, and the +-- two are swapped over in a later stage. +-- +-- Three things carry over unchanged, and are imported rather than duplicated: +-- 'VarIdent' (a surface identifier), 'Binder' (the /names/ a binder introduces, +-- including a pair pattern, which still binds exactly one variable), 'TModality', +-- and 'TypeInfo' (a node's type plus its memoised weak head and normal forms). +-- +-- What changes is the variable representation. A binder is a 'Foil.NameBinder', +-- a variable is a 'Foil.Name' (an @Int@), and weakening a term into a larger +-- scope is 'Foil.sink', a coercion rather than a traversal of every node. +module Language.Rzk.Foil.Syntax where + +import Control.Monad.Foil (NameBinder) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Foil.Internal (Substitution (..), + unsafeAssertFresh) +import Control.Monad.Free.Foil (AST (..), ScopedAST (..), + alphaEquiv, + substitute, unsafeEqAST) +import Data.ZipMatchK (Mappings (..), + ZipMatchK (..), + zipMatchViaChooseLeft, + zipMatchViaEq) +import Control.Monad.Free.Foil.Annotated (AnnSig (..)) +import Data.ZipMatchK.TH (deriveZipMatchK) +import Data.Bifoldable (Bifoldable (..)) +import Data.Bifunctor (Bifunctor (..)) +import Data.Bifunctor.TH (deriveBifoldable, + deriveBifunctor, + deriveBitraversable) +import qualified Data.IntMap as IntMap +import Generics.Kind.TH (deriveGenericK) +import qualified GHC.Generics as GHC +import Unsafe.Coerce (unsafeCoerce) + +import Language.Rzk.Foil.Names (Binder (..), TModality (..), + TypeInfo (..), VarIdent) + +-- * The signature +-- +-- A transliteration of @TermF@: same constructors, same fields, same order. The +-- @scope@ positions are the ones that bind, and there are seven of them across +-- five constructors ('TypeFunF' and 'LambdaF' each carry a tope scope as well as +-- a body scope, under the same binder). + +-- | The optional domain annotation of a λ: its modality, its parameter type, +-- and (for a shape) the tope the parameter is restricted by. It was an anonymous +-- triple in the old signature; the generic machinery needs a named type here, and +-- it reads better anyway. +data LambdaParam scope term = LambdaParam TModality term (Maybe scope) + deriving (Eq, Functor, Foldable, Traversable, GHC.Generic) + +data TermSig scope term + = UniverseF + | UniverseCubeF + | UniverseTopeF + | CubeUnitF + | CubeUnitStarF + | Cube2F + | Cube2_0F + | Cube2_1F + | CubeIF + | CubeI_0F + | CubeI_1F + | CubeProductF term term + | CubeFlipF term + | CubeUnflipF term + | TopeTopF + | TopeBottomF + | TopeEQF term term + | TopeLEQF term term + | TopeAndF term term + | TopeOrF term term + | TopeInvF term + | TopeUninvF term + | RecBottomF + | RecOrF [(term, term)] + | TypeFunF Binder TModality term (Maybe scope) scope + | TypeSigmaF Binder TModality term scope + | TypeIdF term (Maybe term) term + | AppF term term + | LetF Binder (Maybe term) term scope + | LambdaF Binder (Maybe (LambdaParam scope term)) scope + | PairF term term + | FirstF term + | SecondF term + | ReflF (Maybe (term, Maybe term)) + | IdJF term term term term term term + | UnitF + | TypeUnitF + | TypeAscF term term + | TypeRestrictedF term [(term, term)] + | TypeModalF TModality term + | ModAppF TModality term + | ModExtractF TModality TModality term + | LetModF Binder TModality TModality (Maybe term) term scope + | HoleF (Maybe VarIdent) + deriving (Eq, Functor, Foldable, Traversable, GHC.Generic) + +deriveBifunctor ''LambdaParam +deriveBifoldable ''LambdaParam +deriveBitraversable ''LambdaParam +deriveGenericK ''LambdaParam + +deriveBifunctor ''TermSig +deriveBifoldable ''TermSig +deriveBitraversable ''TermSig +deriveGenericK ''TermSig + +-- | Matching the non-recursive fields of the signature. +-- +-- A modality and a hole's name are part of the term: they must agree. A 'Binder' +-- is /not/: it records the names a binder introduces, purely so that goals and +-- error messages can show the user's own names, and two terms that differ only +-- in them are the same term. The old representation compared them (its 'Eq' was +-- derived), so @\ x -> x@ and @\ y -> y@ compared unequal; on the new one they +-- are α-equivalent, as they should be. +instance ZipMatchK TModality where + zipMatchWithK = zipMatchViaEq + +instance ZipMatchK VarIdent where + zipMatchWithK = zipMatchViaEq + +instance ZipMatchK Binder where + zipMatchWithK = zipMatchViaChooseLeft + +-- | A hole's name is a whole field ('HoleF'), so it is matched as a constant +-- rather than through the 'Maybe' functor. +instance ZipMatchK (Maybe VarIdent) where + zipMatchWithK = zipMatchViaEq + +instance ZipMatchK LambdaParam + +-- | The node matcher, TH-derived: an explicit instance, so no @Generics.Kind@ +-- view is rebuilt per comparison. It drives 'Control.Monad.Free.Foil.alphaEquiv' +-- and 'Control.Monad.Free.Foil.unsafeEqAST', run on every comparison of two +-- terms, which in a dependent checker is most of the work. This replaced a +-- hand-written 44-constructor matcher carried on free-foil 0.2.0 (which had no +-- deriver); the deriver is the point of moving to this free-foil. +deriveZipMatchK ''TermSig + + +-- * Annotations +-- +-- 'AnnSig' is @Control.Monad.Free.Foil.Annotated@'s: the annotation is a functor +-- of the signature's /term/ parameter, so a node's type is a term in the node's +-- own scope. free-foil provides it with a /derived/ (explicit) 'ZipMatchK', its +-- 'Bifunctor' (recurses into the annotation, for substitution) and its +-- 'Bifoldable' (does not, so a term's free variables exclude those only in its +-- type). All rzk adds is how its own annotation, 'TypeInfo', matches. + +-- | The annotation is ignored in matching, so two terms differing only in their +-- types are α-equivalent. The 'ZipMatchK' API makes an annotation holding terms +-- construct its result through the mapping, so it cannot be dropped from the +-- match — but it is made lazy: 'infoType' below is a thunk never forced, because +-- 'AnnSig's 'Bifoldable' does not visit the annotation. So the 30-deep universe +-- tower inside a type is never walked. The memoised forms are dropped (every +-- consumer of the zipped result discards them). This is the annotation-blind +-- pattern from the 'Control.Monad.Free.Foil.Annotated' haddock. +instance ZipMatchK TypeInfo where + zipMatchWithK (f :^: M0) (TypeInfo t1 _ _) (TypeInfo t2 _ _) = + Just (TypeInfo (maybe (error "ZipMatchK TypeInfo: annotation forced") id (f t1 t2)) Nothing Nothing) + +-- * Terms + +-- | An untyped term: the surface syntax, elaborated but without annotations. +type Term = AST NameBinder TermSig + +-- | A typed term: every node carries its type. The successor of @TermT@. +type TermT = AST NameBinder (AnnSig TypeInfo TermSig) + +-- | A scope: a binder together with the term it binds over. +type ScopedTermT = ScopedAST NameBinder (AnnSig TypeInfo TermSig) + +-- | A scope of an untyped term. +type ScopedTerm = ScopedAST NameBinder TermSig + +-- | The annotation of a node: its type, and its memoised normal forms. A +-- variable carries none — its type lives in the context. +typeInfoOf :: TermT n -> Maybe (TypeInfo (TermT n)) +typeInfoOf (Var _) = Nothing +typeInfoOf (Node (AnnSig info _)) = Just info + +-- | Drop every annotation, for printing and for the surface-facing API. +untyped :: TermT n -> Term n +untyped (Var name) = Var name +untyped (Node (AnnSig _ann sig)) = Node (bimap untypedScoped untyped sig) + where + untypedScoped (ScopedAST binder body) = ScopedAST binder (untyped body) + +-- | Memoise a node's own weak head normal form (the self-referential knot of the +-- old representation, unchanged). +termIsWHNF :: TermT n -> TermT n +termIsWHNF t@Var{} = t +termIsWHNF (Node (AnnSig info sig)) = t' + where t' = Node (AnnSig info { infoWHNF = Just t' } sig) + +termIsNF :: TermT n -> TermT n +termIsNF t@Var{} = t +termIsNF (Node (AnnSig info sig)) = t' + where t' = Node (AnnSig info { infoWHNF = Just t', infoNF = Just t' } sig) + +-- * Equality + +-- | Syntactic equality of two terms of the same scope. +-- +-- Annotation-blind, as the old derived 'Eq' was, but it also requires the two to +-- bind the same names, so it is /conservative/: two α-equivalent terms whose +-- binders differ are not equal. That is what the tope-context scans want — the +-- terms there come from the same context — and it is cheaper than 'alphaEqT', +-- which walks the scope. +eqT :: Foil.Distinct n => TermT n -> TermT n -> Bool +eqT = unsafeEqAST + +-- | α-equivalence: name-blind and annotation-blind. The old representation's 'Eq' +-- compared binder names, so @\\ x -> x@ and @\\ y -> y@ were unequal; they are the +-- same term, and this says so. +alphaEqT :: Foil.Distinct n => Foil.Scope n -> TermT n -> TermT n -> Bool +alphaEqT = alphaEquiv + +elemT :: Foil.Distinct n => TermT n -> [TermT n] -> Bool +elemT t = any (eqT t) + +notElemT :: Foil.Distinct n => TermT n -> [TermT n] -> Bool +notElemT t = not . elemT t + +nubT :: Foil.Distinct n => [TermT n] -> [TermT n] +nubT [] = [] +nubT (t : ts) = t : nubT (filter (not . eqT t) ts) + +-- * Free variables + +-- | The free variables of a term. +-- +-- free-foil has @freeVarsOf@ only on its unreleased @main@, so this is written +-- here. A name bound on the way down is dropped from the result, which is what +-- makes the coercion back to the outer scope right. +freeVarsOfTerm :: Term n -> [Foil.Name n] +freeVarsOfTerm (Var x) = [x] +freeVarsOfTerm (Node sig) = bifoldMap freeVarsOfScoped freeVarsOfTerm sig + where + freeVarsOfScoped :: ScopedTerm n' -> [Foil.Name n'] + freeVarsOfScoped (ScopedAST binder body) = + unsafeCoerce + [ x + | x <- freeVarsOfTerm body + , Foil.nameId x /= Foil.nameId (Foil.nameOf binder) + ] + +-- | The free variables of a typed term, not counting those that occur only in the +-- types of its nodes ('Bifoldable' skips the annotation, as it did before). +freeVarsOfTermT :: TermT n -> [Foil.Name n] +freeVarsOfTermT = freeVarsOfTerm . untyped + +-- * Holes + +isHoleT :: TermT n -> Bool +isHoleT HoleT{} = True +isHoleT _ = False + +-- | The name of every hole in a term. +holeNamesOf :: Term n -> [Maybe VarIdent] +holeNamesOf (Hole mname) = [mname] +holeNamesOf (Var _) = [] +holeNamesOf (Node sig) = bifoldr (\scoped acc -> holeNamesOfScoped scoped <> acc) + (\t acc -> holeNamesOf t <> acc) [] sig + where + holeNamesOfScoped (ScopedAST _ body) = holeNamesOf body + +-- | Does the term contain a hole anywhere (including nested, e.g. @f ?@)? +containsHole :: TermT n -> Bool +containsHole HoleT{} = True +containsHole (Var _) = False +containsHole (Node (AnnSig _ sig)) = + bifoldr (\scoped acc -> containsHoleScoped scoped || acc) (\t acc -> containsHole t || acc) False sig + where + containsHoleScoped (ScopedAST _ body) = containsHole body + +-- * Going under a binder, and substituting + +-- | Go under the binder of a scoped term. +-- +-- The binder is used as it stands when its name is free in the ambient scope, +-- which is the common case and costs nothing. It has to be renamed when the name +-- is taken — sinking a term into a scope that has grown since the term was built +-- can do that — and only then is the body traversed. +withScopedT + :: (Bifunctor sig, Foil.Distinct n) + => Foil.Scope n + -> ScopedAST NameBinder sig n + -> (forall l. Foil.DExt n l => NameBinder n l -> AST NameBinder sig l -> r) + -> r +withScopedT scope (ScopedAST binder body) k + | Foil.member (Foil.nameOf binder) scope = + Foil.withFresh scope $ \binder' -> + let scope' = Foil.extendScope binder' scope + rename = Foil.addRename (Foil.sink Foil.identitySubst) binder (Foil.nameOf binder') + in k binder' (substitute scope' rename body) + | otherwise = + -- The name is fresh here, so the body already /is/ a term of the extended + -- scope; the coercion says exactly that, and is the same one + -- 'Foil.withRefreshed' performs on its own fast path. + unsafeAssertFresh binder $ \binder' -> k binder' (unsafeCoerce body) + +-- | Go under two scoped terms that stand for /one/ variable. +-- +-- A Π-type and a λ over a shape each carry a tope scope beside the body, under +-- what the user wrote as a single binder. On free-foil each 'ScopedAST' has its +-- own 'NameBinder', so the second is instantiated with the first's name: they +-- behave as two abstractions over one argument, as they did before. +withScopedT2 + :: Foil.Distinct n + => Foil.Scope n + -> ScopedTermT n + -> ScopedTermT n + -> (forall l. Foil.DExt n l => NameBinder n l -> TermT l -> TermT l -> r) + -> r +withScopedT2 scope scoped1 scoped2 k = + withScopedT scope scoped1 $ \binder body1 -> + k binder body1 (openWith (Foil.extendScope binder scope) (Foil.nameOf binder) scoped2) + +-- | Open a scoped term with a name that is already in scope. +-- +-- Generic in the signature, so that a λ's (untyped) body and the codomain of the +-- Π it is checked against can be opened under one and the same binder. +openWith + :: (Bifunctor sig, Foil.DExt n l) + => Foil.Scope l -> Foil.Name l -> ScopedAST NameBinder sig n -> AST NameBinder sig l +openWith scope name (ScopedAST binder body) = + substitute scope (Foil.addRename (Foil.sink Foil.identitySubst) binder name) body + +-- | Replace a /free/ name by a term. +-- +-- A section's assumption is a free name at the top level, and closing the section +-- abstracts it out of the definitions that use it; this is how those definitions +-- are rewritten. free-foil's substitutions are keyed by a binder, so the map is +-- built directly. +substituteName + :: Foil.Distinct n + => Foil.Scope n -> Foil.Name n -> TermT n -> TermT n -> TermT n +substituteName scope name value = + substituteT scope (UnsafeSubstitution (IntMap.singleton (Foil.nameId name) value)) + +-- | Abstract a free name out of a term: the binder the continuation receives binds +-- what the name stood for. +-- +-- The name stays in the scope index (a scope only ever grows), but the term no +-- longer mentions it, which is what makes the resulting Π or λ closed over it. +abstractName + :: Foil.Distinct n + => Foil.Scope n + -> Foil.Name n + -> TermT n + -> (forall l. Foil.DExt n l => NameBinder n l -> TermT l -> r) + -> r +abstractName scope name term k = + Foil.withFresh scope $ \binder -> + let scope' = Foil.extendScope binder scope + term' = substituteName scope' (Foil.sink name) (Var (Foil.nameOf binder)) + (Foil.sink term) + in k binder term' + +-- | Instantiate a scoped term with a term: the successor of @substituteT x scope@. +instantiateT :: Foil.Distinct n => Foil.Scope n -> ScopedTermT n -> TermT n -> TermT n +instantiateT scope (ScopedAST binder body) arg = + substituteT scope (Foil.addSubst Foil.identitySubst binder arg) body + +-- | Instantiate a scoped /untyped/ term. There are no memoised normal forms to +-- invalidate, so this is free-foil's own substitution. +instantiateUntyped :: Foil.Distinct n => Foil.Scope n -> ScopedTerm n -> Term n -> Term n +instantiateUntyped scope (ScopedAST binder body) arg = + substitute scope (Foil.addSubst Foil.identitySubst binder arg) body + +-- | Substitution that invalidates the memoised normal forms of every node it +-- rebuilds, and substitutes into each node's type. +-- +-- A renaming ('substitute') keeps the memo, since a renamed term reduces exactly +-- as the original does. A real substitution does not: a variable is in weak head +-- normal form, and what replaces it need not be. This is one traversal, as +-- substituting and invalidating separately was two. +substituteT + :: Foil.Distinct o + => Foil.Scope o + -> Foil.Substitution TermT i o + -> TermT i + -> TermT o +substituteT scope subst term = go scope subst term + where + go + :: forall i' o'. Foil.Distinct o' + => Foil.Scope o' -> Foil.Substitution TermT i' o' -> TermT i' -> TermT o' + go _ subst' (Var name) = Foil.lookupSubst subst' name + go scope' subst' (Node (AnnSig info sig)) = Node (AnnSig info' sig') + where + info' = TypeInfo + { infoType = go scope' subst' (infoType info) + , infoWHNF = Nothing + , infoNF = Nothing + } + sig' = bimap goScoped (go scope' subst') sig + + goScoped (ScopedAST binder body) = + Foil.withRefreshed scope' (Foil.nameOf binder) $ \binder' -> + let scope'' = Foil.extendScope binder' scope' + subst'' = Foil.addRename (Foil.sink subst') binder (Foil.nameOf binder') + in ScopedAST binder' (go scope'' subst'' body) + +-- * Pattern synonyms +-- +-- One per constructor, as @makePatternsAll@ generated before. A @scope@ field is +-- a 'ScopedTermT', so going under a binder means matching on 'ScopedAST', which +-- is where the existential scope index appears. + +pattern UniverseT info = Node (AnnSig info UniverseF) +pattern UniverseCubeT info = Node (AnnSig info UniverseCubeF) +pattern UniverseTopeT info = Node (AnnSig info UniverseTopeF) +pattern CubeUnitT info = Node (AnnSig info CubeUnitF) +pattern CubeUnitStarT info = Node (AnnSig info CubeUnitStarF) +pattern Cube2T info = Node (AnnSig info Cube2F) +pattern Cube2_0T info = Node (AnnSig info Cube2_0F) +pattern Cube2_1T info = Node (AnnSig info Cube2_1F) +pattern CubeIT info = Node (AnnSig info CubeIF) +pattern CubeI_0T info = Node (AnnSig info CubeI_0F) +pattern CubeI_1T info = Node (AnnSig info CubeI_1F) +pattern CubeProductT info l r = Node (AnnSig info (CubeProductF l r)) +pattern CubeFlipT info t = Node (AnnSig info (CubeFlipF t)) +pattern CubeUnflipT info t = Node (AnnSig info (CubeUnflipF t)) +pattern TopeTopT info = Node (AnnSig info TopeTopF) +pattern TopeBottomT info = Node (AnnSig info TopeBottomF) +pattern TopeEQT info l r = Node (AnnSig info (TopeEQF l r)) +pattern TopeLEQT info l r = Node (AnnSig info (TopeLEQF l r)) +pattern TopeAndT info l r = Node (AnnSig info (TopeAndF l r)) +pattern TopeOrT info l r = Node (AnnSig info (TopeOrF l r)) +pattern TopeInvT info t = Node (AnnSig info (TopeInvF t)) +pattern TopeUninvT info t = Node (AnnSig info (TopeUninvF t)) +pattern RecBottomT info = Node (AnnSig info RecBottomF) +pattern RecOrT info rs = Node (AnnSig info (RecOrF rs)) +pattern TypeFunT info orig md param mtope ret = Node (AnnSig info (TypeFunF orig md param mtope ret)) +pattern TypeSigmaT info orig md a b = Node (AnnSig info (TypeSigmaF orig md a b)) +pattern TypeIdT info a mtA b = Node (AnnSig info (TypeIdF a mtA b)) +pattern AppT info f x = Node (AnnSig info (AppF f x)) +pattern LetT info orig mparam val body = Node (AnnSig info (LetF orig mparam val body)) +pattern LambdaT info orig mparam body = Node (AnnSig info (LambdaF orig mparam body)) +pattern PairT info l r = Node (AnnSig info (PairF l r)) +pattern FirstT info t = Node (AnnSig info (FirstF t)) +pattern SecondT info t = Node (AnnSig info (SecondF t)) +pattern ReflT info mx = Node (AnnSig info (ReflF mx)) +pattern IdJT info a b c d e f = Node (AnnSig info (IdJF a b c d e f)) +pattern UnitT info = Node (AnnSig info UnitF) +pattern TypeUnitT info = Node (AnnSig info TypeUnitF) +pattern TypeAscT info term ty = Node (AnnSig info (TypeAscF term ty)) +pattern TypeRestrictedT info ty rs = Node (AnnSig info (TypeRestrictedF ty rs)) +pattern TypeModalT info md ty = Node (AnnSig info (TypeModalF md ty)) +pattern ModAppT info md t = Node (AnnSig info (ModAppF md t)) +pattern ModExtractT info app inn t = Node (AnnSig info (ModExtractF app inn t)) +pattern LetModT info orig app inn mparam val body = Node (AnnSig info (LetModF orig app inn mparam val body)) +pattern HoleT info mname = Node (AnnSig info (HoleF mname)) + +{-# COMPLETE Var, UniverseT, UniverseCubeT, UniverseTopeT, CubeUnitT, + CubeUnitStarT, Cube2T, Cube2_0T, Cube2_1T, CubeIT, CubeI_0T, CubeI_1T, + CubeProductT, CubeFlipT, CubeUnflipT, TopeTopT, TopeBottomT, TopeEQT, TopeLEQT, + TopeAndT, TopeOrT, TopeInvT, TopeUninvT, RecBottomT, RecOrT, TypeFunT, + TypeSigmaT, TypeIdT, AppT, LetT, LambdaT, PairT, FirstT, SecondT, ReflT, IdJT, + UnitT, TypeUnitT, TypeAscT, TypeRestrictedT, TypeModalT, ModAppT, ModExtractT, + LetModT, HoleT #-} + +-- ** Untyped patterns +-- +-- The same constructors on 'Term' (no annotation), for the surface conversions +-- and the printer. + +pattern Universe = Node UniverseF +pattern UniverseCube = Node UniverseCubeF +pattern UniverseTope = Node UniverseTopeF +pattern CubeUnit = Node CubeUnitF +pattern CubeUnitStar = Node CubeUnitStarF +pattern Cube2 = Node Cube2F +pattern Cube2_0 = Node Cube2_0F +pattern Cube2_1 = Node Cube2_1F +pattern CubeI = Node CubeIF +pattern CubeI_0 = Node CubeI_0F +pattern CubeI_1 = Node CubeI_1F +pattern CubeProduct l r = Node (CubeProductF l r) +pattern CubeFlip t = Node (CubeFlipF t) +pattern CubeUnflip t = Node (CubeUnflipF t) +pattern TopeTop = Node TopeTopF +pattern TopeBottom = Node TopeBottomF +pattern TopeEQ l r = Node (TopeEQF l r) +pattern TopeLEQ l r = Node (TopeLEQF l r) +pattern TopeAnd l r = Node (TopeAndF l r) +pattern TopeOr l r = Node (TopeOrF l r) +pattern TopeInv t = Node (TopeInvF t) +pattern TopeUninv t = Node (TopeUninvF t) +pattern RecBottom = Node RecBottomF +pattern RecOr rs = Node (RecOrF rs) +pattern TypeFun orig md param mtope ret = Node (TypeFunF orig md param mtope ret) +pattern TypeSigma orig md a b = Node (TypeSigmaF orig md a b) +pattern TypeId a mtA b = Node (TypeIdF a mtA b) +pattern App f x = Node (AppF f x) +pattern Let orig mparam val body = Node (LetF orig mparam val body) +pattern Lambda orig mparam body = Node (LambdaF orig mparam body) +pattern Pair l r = Node (PairF l r) +pattern First t = Node (FirstF t) +pattern Second t = Node (SecondF t) +pattern Refl mx = Node (ReflF mx) +pattern IdJ a b c d e f = Node (IdJF a b c d e f) +pattern Unit = Node UnitF +pattern TypeUnit = Node TypeUnitF +pattern TypeAsc term ty = Node (TypeAscF term ty) +pattern TypeRestricted ty rs = Node (TypeRestrictedF ty rs) +pattern TypeModal md ty = Node (TypeModalF md ty) +pattern ModApp md t = Node (ModAppF md t) +pattern ModExtract app inn t = Node (ModExtractF app inn t) +pattern LetMod orig app inn mparam val body = Node (LetModF orig app inn mparam val body) +pattern Hole mname = Node (HoleF mname) + +{-# COMPLETE Var, Universe, UniverseCube, UniverseTope, CubeUnit, CubeUnitStar, + Cube2, Cube2_0, Cube2_1, CubeI, CubeI_0, CubeI_1, CubeProduct, CubeFlip, + CubeUnflip, TopeTop, TopeBottom, TopeEQ, TopeLEQ, TopeAnd, TopeOr, TopeInv, + TopeUninv, RecBottom, RecOr, TypeFun, TypeSigma, TypeId, App, Let, Lambda, + Pair, First, Second, Refl, IdJ, Unit, TypeUnit, TypeAsc, TypeRestricted, + TypeModal, ModApp, ModExtract, LetMod, Hole #-} + +-- * Closed constants +-- +-- They are closed, so they generalise over the scope index: no shifting, no +-- per-scope construction. (The universe is still the 30-deep chain of the old +-- representation, ending in a bottom; making it a real level-polymorphic +-- universe is a separate FIXME.) + +universeT :: TermT n +universeT = iterate f (error "going too high up the universe levels") !! 30 + where + f t = UniverseT TypeInfo { infoType = t, infoWHNF = Just universeT, infoNF = Just universeT } + +cubeT :: TermT n +cubeT = UniverseCubeT TypeInfo + { infoType = universeT, infoWHNF = Just cubeT, infoNF = Just cubeT } + +topeT :: TermT n +topeT = UniverseTopeT TypeInfo + { infoType = universeT, infoWHNF = Just topeT, infoNF = Just topeT } + +cubeUnitT :: TermT n +cubeUnitT = CubeUnitT TypeInfo + { infoType = cubeT, infoWHNF = Just cubeUnitT, infoNF = Just cubeUnitT } + +cubeUnitStarT :: TermT n +cubeUnitStarT = CubeUnitStarT TypeInfo + { infoType = cubeUnitT, infoWHNF = Just cubeUnitStarT, infoNF = Just cubeUnitStarT } + +cube2T :: TermT n +cube2T = Cube2T TypeInfo + { infoType = cubeT, infoWHNF = Just cube2T, infoNF = Just cube2T } + +cube2_0T :: TermT n +cube2_0T = Cube2_0T TypeInfo + { infoType = cube2T, infoWHNF = Just cube2_0T, infoNF = Just cube2_0T } + +cube2_1T :: TermT n +cube2_1T = Cube2_1T TypeInfo + { infoType = cube2T, infoWHNF = Just cube2_1T, infoNF = Just cube2_1T } + +cubeIT :: TermT n +cubeIT = CubeIT TypeInfo + { infoType = cubeT, infoWHNF = Just cubeIT, infoNF = Just cubeIT } + +cubeI_0T :: TermT n +cubeI_0T = CubeI_0T TypeInfo + { infoType = cubeIT, infoWHNF = Just cubeI_0T, infoNF = Just cubeI_0T } + +cubeI_1T :: TermT n +cubeI_1T = CubeI_1T TypeInfo + { infoType = cubeIT, infoWHNF = Just cubeI_1T, infoNF = Just cubeI_1T } + +topeTopT :: TermT n +topeTopT = TopeTopT TypeInfo + { infoType = topeT, infoWHNF = Just topeTopT, infoNF = Just topeTopT } + +topeBottomT :: TermT n +topeBottomT = TopeBottomT TypeInfo + { infoType = topeT, infoWHNF = Just topeBottomT, infoNF = Just topeBottomT } + +typeUnitT :: TermT n +typeUnitT = TypeUnitT TypeInfo + { infoType = universeT, infoWHNF = Just typeUnitT, infoNF = Just typeUnitT } + +unitT :: TermT n +unitT = UnitT TypeInfo + { infoType = typeUnitT, infoWHNF = Just unitT, infoNF = Just unitT } + +-- | @recBOT@ is its own type: it inhabits every type in a contradictory context. +recBottomT :: TermT n +recBottomT = RecBottomT TypeInfo + { infoType = recBottomT, infoWHNF = Just recBottomT, infoNF = Just recBottomT } + +-- * Smart constructors +-- +-- Each builds the 'TypeInfo' of the node it makes, so the checker never writes a +-- raw @FooT@. A node whose head is already a value ('lambdaT', 'pairT', the type +-- formers) memoises itself as its own WHNF. + +-- ** The tope layer + +topeEQT :: TermT n -> TermT n -> TermT n +topeEQT l r = TopeEQT (topeInfo topeT) l r + +topeLEQT :: TermT n -> TermT n -> TermT n +topeLEQT l r = TopeLEQT (topeInfo topeT) l r + +topeOrT :: TermT n -> TermT n -> TermT n +topeOrT l r = TopeOrT (topeInfo topeT) l r + +topeAndT :: TermT n -> TermT n -> TermT n +topeAndT l r = TopeAndT (topeInfo topeT) l r + +topeInvT :: TermT n -> TermT n +topeInvT t = TopeInvT (topeInfo (typeModalT universeT Op topeT)) t + +topeUninvT :: TermT n -> TermT n +topeUninvT t = TopeUninvT (topeInfo topeT) t + +-- | An unreduced node of the given type. +topeInfo :: TermT n -> TypeInfo (TermT n) +topeInfo ty = TypeInfo { infoType = ty, infoWHNF = Nothing, infoNF = Nothing } + +-- ** Cubes + +cubeProductT :: TermT n -> TermT n -> TermT n +cubeProductT l r = CubeProductT (topeInfo cubeT) l r + +cubeFlipT :: TermT n -> TermT n -> TermT n +cubeFlipT cubeTy t = CubeFlipT (topeInfo (typeModalT cubeT Op cubeTy)) t + +cubeUnflipT :: TermT n -> TermT n -> TermT n +cubeUnflipT cubeTy t = CubeUnflipT (topeInfo cubeTy) t + +-- ** Types + +typeFunT + :: Binder -> TModality -> TermT n -> Maybe (ScopedTermT n) -> ScopedTermT n + -> TermT n +typeFunT orig md cube mtope ret = t + where t = TypeFunT (valueInfo t universeT) orig md cube mtope ret + +typeSigmaT :: Binder -> TModality -> TermT n -> ScopedTermT n -> TermT n +typeSigmaT orig md a b = t + where t = TypeSigmaT (valueInfo t universeT) orig md a b + +typeIdT :: TermT n -> Maybe (TermT n) -> TermT n -> TermT n +typeIdT x tA y = t + where t = TypeIdT (valueInfo t universeT) x tA y + +typeRestrictedT :: TermT n -> [(TermT n, TermT n)] -> TermT n +typeRestrictedT ty rs = TypeRestrictedT (topeInfo universeT) ty rs + +typeModalT :: TermT n -> TModality -> TermT n -> TermT n +typeModalT ty md te = TypeModalT (topeInfo ty) md te + +typeAscT :: TermT n -> TermT n -> TermT n +typeAscT x ty = TypeAscT (topeInfo ty) x ty + +-- | A node that is already a value: it is its own weak head normal form. +valueInfo :: TermT n -> TermT n -> TypeInfo (TermT n) +valueInfo t ty = TypeInfo { infoType = ty, infoWHNF = Just t, infoNF = Nothing } + +-- ** Terms + +lambdaT + :: TermT n -> Binder -> Maybe (LambdaParam (ScopedTermT n) (TermT n)) + -> ScopedTermT n -> TermT n +lambdaT ty orig mparam body = t + where t = LambdaT (valueInfo t ty) orig mparam body + +pairT :: TermT n -> TermT n -> TermT n -> TermT n +pairT ty l r = t + where t = PairT (valueInfo t ty) l r + +appT :: TermT n -> TermT n -> TermT n -> TermT n +appT ty f x = AppT (topeInfo ty) f x + +firstT :: TermT n -> TermT n -> TermT n +firstT ty arg = FirstT (topeInfo ty) arg + +secondT :: TermT n -> TermT n -> TermT n +secondT ty arg = SecondT (topeInfo ty) arg + +letT :: TermT n -> Binder -> Maybe (TermT n) -> TermT n -> ScopedTermT n -> TermT n +letT ty orig mparam val body = LetT (topeInfo ty) orig mparam val body + +letModT + :: TermT n -> Binder -> TModality -> TModality -> Maybe (TermT n) -> TermT n + -> ScopedTermT n -> TermT n +letModT ty orig app inn mparam val body = + LetModT (topeInfo ty) orig app inn mparam val body + +-- | @refl@ normalises to a bare @refl@: its endpoints are recoverable from the +-- type, so they are dropped from the normal form. +reflT :: TermT n -> Maybe (TermT n, Maybe (TermT n)) -> TermT n +reflT ty mx = ReflT info mx + where + info = TypeInfo + { infoType = ty + , infoWHNF = Just (ReflT info Nothing) + , infoNF = Just (ReflT info Nothing) + } + +idJT + :: TermT n -> TermT n -> TermT n -> TermT n -> TermT n -> TermT n -> TermT n + -> TermT n +idJT ty tA a tC d x p = IdJT (topeInfo ty) tA a tC d x p + +recOrT :: TermT n -> [(TermT n, TermT n)] -> TermT n +recOrT ty rs = RecOrT (topeInfo ty) rs + +modAppT :: TermT n -> TModality -> TermT n -> TermT n +modAppT ty md term = ModAppT (topeInfo ty) md term + +modExtractT :: TermT n -> TModality -> TModality -> TermT n -> TermT n +modExtractT ty app inn term = ModExtractT (topeInfo ty) app inn term + +holeT :: TermT n -> Maybe VarIdent -> TermT n +holeT ty mname = HoleT (topeInfo ty) mname diff --git a/src/Language/Rzk/Free/Syntax.hs b/src/Language/Rzk/Free/Syntax.hs deleted file mode 100644 --- a/src/Language/Rzk/Free/Syntax.hs +++ /dev/null @@ -1,885 +0,0 @@ -{-# OPTIONS_GHC -fno-warn-missing-pattern-synonym-signatures -fno-warn-missing-signatures -fno-warn-type-defaults #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE DeriveTraversable #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE PatternSynonyms #-} -{-# LANGUAGE RecordWildCards #-} -{-# LANGUAGE TemplateHaskell #-} -{-# LANGUAGE TypeSynonymInstances #-} -module Language.Rzk.Free.Syntax where - -import Data.Bifunctor (bimap) -import Data.Bifunctor.TH -import Data.Char (chr, ord) -import Data.Coerce -import Data.Function (on) -import Data.Functor (void) -import Data.List (intercalate, nub, (\\)) -import Data.Maybe (fromMaybe) -import Data.String -import qualified Data.Text as T - -import Free.Scoped -import Free.Scoped.TH - --- FIXME: use proper mechanisms for warnings -import Debug.Trace - -import qualified Language.Rzk.Syntax as Rzk - -data RzkPosition = RzkPosition - { rzkFilePath :: Maybe FilePath - , rzkLineCol :: Rzk.BNFC'Position - } - -ppRzkPosition :: RzkPosition -> String -ppRzkPosition RzkPosition{..} = intercalate ":" $ concat - [ [fromMaybe "" rzkFilePath] - , foldMap (\(row, col) -> map show [row, col]) rzkLineCol] - -newtype VarIdent = VarIdent { getVarIdent :: Rzk.VarIdent' RzkPosition } - -instance Show VarIdent where - show = Rzk.printTree . getVarIdent - -instance Eq VarIdent where - (==) = (==) `on` (void . getVarIdent) - -instance IsString VarIdent where - fromString s = VarIdent (Rzk.VarIdent (RzkPosition Nothing Nothing) (fromString s)) - -ppVarIdentWithLocation :: VarIdent -> String -ppVarIdentWithLocation (VarIdent var@(Rzk.VarIdent pos _ident)) = - Rzk.printTree var <> " (" <> ppRzkPosition pos <> ")" - -varIdent :: Rzk.VarIdent -> VarIdent -varIdent = varIdentAt Nothing - -varIdentAt :: Maybe FilePath -> Rzk.VarIdent -> VarIdent -varIdentAt path (Rzk.VarIdent pos ident) = VarIdent (Rzk.VarIdent (RzkPosition path pos) ident) - -fromVarIdent :: VarIdent -> Rzk.VarIdent -fromVarIdent (VarIdent (Rzk.VarIdent (RzkPosition _file pos) ident)) = Rzk.VarIdent pos ident - --- | The display name of a hole from its surface token text. The token includes --- the leading @?@; an anonymous hole (bare @?@) has no name. -holeName :: T.Text -> Maybe VarIdent -holeName tok = - case T.drop 1 tok of - name | T.null name -> Nothing - | otherwise -> Just (fromString (T.unpack name)) - --- | The surface token text (including the leading @?@) for a hole name. -holeIdentToken :: Maybe VarIdent -> T.Text -holeIdentToken Nothing = "?" -holeIdentToken (Just x) = "?" <> T.pack (show x) - --- | The name(s) a binder introduces. A binder may name a single (possibly --- anonymous) variable, or destructure a pair\/tuple via a pattern. The pattern --- structure is kept around purely so that goals, holes and error messages can --- show the user's original names (e.g. @t@ and @s@ for @\\ (t , s) -> …@) --- instead of projections of a fresh variable (e.g. @π₁ x₄@ and @π₂ x₄@). --- --- Operationally a pair pattern still binds a /single/ variable; the components --- are projections of it (see 'toScopePattern'). 'Binder' only records the names --- so they can be restored when rendering. -data Binder - = BinderVar (Maybe VarIdent) -- ^ a single variable (@Nothing@ for @_@) - | BinderPair Binder Binder -- ^ a pair pattern @(l , r)@ - | BinderUnit -- ^ the unit pattern @unit@ - deriving (Eq) - --- | The single name of a binder, if it binds exactly one named variable. --- A pair\/unit pattern has no single name, so this is 'Nothing' for them. --- Used wherever the old @Maybe VarIdent@ binder name is still sufficient. -binderName :: Binder -> Maybe VarIdent -binderName (BinderVar mname) = mname -binderName _ = Nothing - -data TModality = Sharp | Flat | Op | Id deriving (Eq, Show) - -toModality :: Rzk.Modality -> TModality -toModality Rzk.Sharp{} = Sharp -toModality Rzk.ASCII_Sharp{} = Sharp -toModality Rzk.Flat{} = Flat -toModality Rzk.ASCII_Flat{} = Flat -toModality Rzk.Op{} = Op -toModality Rzk.ASCII_Op{} = Op -toModality Rzk.Id{} = Id - -modCompToMods :: Rzk.ModComp -> (TModality, TModality) -modCompToMods (Rzk.Single _ m) = (Id, toModality m) -modCompToMods (Rzk.Comp _ ext inn) = (toModality ext, toModality inn) - -fromMod :: TModality -> Rzk.Modality -fromMod Sharp = Rzk.Sharp Nothing -fromMod Flat = Rzk.Flat Nothing -fromMod Op = Rzk.Op Nothing -fromMod Id = Rzk.Id Nothing - -modsToModComp :: TModality -> TModality -> Rzk.ModComp -modsToModComp Id inn = Rzk.Single Nothing (fromMod inn) -modsToModComp ext inn = Rzk.Comp Nothing (fromMod ext) (fromMod inn) - -data TermF scope term - = UniverseF - | UniverseCubeF - | UniverseTopeF - | CubeUnitF - | CubeUnitStarF - | Cube2F - | Cube2_0F - | Cube2_1F - | CubeIF - | CubeI_0F - | CubeI_1F - | CubeProductF term term - | CubeFlipF term - | CubeUnflipF term - | TopeTopF - | TopeBottomF - | TopeEQF term term - | TopeLEQF term term - | TopeAndF term term - | TopeOrF term term - | TopeInvF term - | TopeUninvF term - | RecBottomF - | RecOrF [(term, term)] - | TypeFunF Binder TModality term (Maybe scope) scope - | TypeSigmaF Binder TModality term scope - | TypeIdF term (Maybe term) term - | AppF term term - | LetF Binder (Maybe term) term scope - | LambdaF Binder (Maybe (TModality, term, Maybe scope)) scope - | PairF term term - | FirstF term - | SecondF term - | ReflF (Maybe (term, Maybe term)) - | IdJF term term term term term term - | UnitF - | TypeUnitF - | TypeAscF term term - | TypeRestrictedF term [(term, term)] - | TypeModalF TModality term - | ModAppF TModality term - | ModExtractF TModality TModality term - | LetModF Binder TModality TModality (Maybe term) term scope - | HoleF (Maybe VarIdent) - deriving (Eq, Functor, Foldable, Traversable) -deriveBifunctor ''TermF -deriveBifoldable ''TermF -deriveBitraversable ''TermF -makePatternsAll ''TermF -- declare all patterns using Template Haskell - -newtype Type term = Type { getType :: term } - deriving (Eq, Functor, Foldable, Traversable) - -data TypeInfo term = TypeInfo - { infoType :: term - , infoWHNF :: Maybe term - , infoNF :: Maybe term - } deriving (Eq, Functor, Foldable, Traversable) - -type Term = FS TermF -type TermT = FS (AnnF TypeInfo TermF) - -termIsWHNF :: TermT var -> TermT var -termIsWHNF t@Pure{} = t -termIsWHNF (Free (AnnF info f)) = t' - where - t' = Free (AnnF info { infoWHNF = Just t' } f) - -termIsNF :: TermT var -> TermT var -termIsNF t@Pure{} = t -termIsNF (Free (AnnF info f)) = t' - where - t' = Free (AnnF info { infoWHNF = Just t', infoNF = Just t' } f) - -invalidateWHNF :: TermT var -> TermT var -invalidateWHNF = transFS $ \(AnnF info f) -> - AnnF info { infoWHNF = Nothing, infoNF = Nothing } f - -substituteT :: TermT var -> Scope TermT var -> TermT var -substituteT x = substitute x . invalidateWHNF - -type Term' = Term VarIdent -type TermT' = TermT VarIdent - -freeVars :: Term a -> [a] -freeVars = foldMap pure - --- FIXME: should be cached in TypeInfo? -partialFreeVarsT :: TermT a -> [a] -partialFreeVarsT (Pure x) = [x] -partialFreeVarsT UniverseT{} = [] -partialFreeVarsT term@(Free (AnnF info _)) = - -- FIXME: check correctness (is it ok to use untyped here?) - foldMap (freeVars . untyped) [term, infoType info] - --- FIXME: should be cached in TypeInfo? -freeVarsT :: Eq a => (a -> TermT a) -> TermT a -> [a] -freeVarsT typeOfVar t = go [] (partialFreeVarsT t) - where - go vars latest - | null new = vars - | otherwise = - go (new <> vars) - (foldMap (partialFreeVarsT . typeOfVar) new) - where - new = nub latest \\ vars - -toTerm' :: Rzk.Term -> Term' -toTerm' = toTerm Pure - -toScope :: VarIdent -> (VarIdent -> Term a) -> Rzk.Term -> Scope Term a -toScope x bvars = toTerm $ \z -> if x == z then Pure Z else S <$> bvars z - -toScopePattern :: Rzk.Pattern -> (VarIdent -> Term a) -> Rzk.Term -> Scope Term a -toScopePattern pat bvars = toTerm $ \z -> - case lookup z (bindings pat (Pure Z)) of - Just t -> t - Nothing -> S <$> bvars z - where - bindings (Rzk.PatternUnit _loc) _ = [] - bindings (Rzk.PatternVar _loc (Rzk.VarIdent _ "_")) _ = [] - bindings (Rzk.PatternVar _loc x) t = [(varIdent x, t)] - bindings (Rzk.PatternPair _loc l r) t = bindings l (First t) <> bindings r (Second t) - bindings (Rzk.PatternTuple loc p1 p2 ps) t = bindings (desugarTuple loc (reverse ps) p2 p1) t - -desugarTuple loc ps p2 p1 = - case ps of - [] -> Rzk.PatternPair loc p1 p2 - pLast : ps' -> Rzk.PatternPair loc (desugarTuple loc ps' p2 p1) pLast - -toTerm :: (VarIdent -> Term a) -> Rzk.Term -> Term a -toTerm bvars = go - where - deprecated t t' = trace msg (go t') - where - msg = unlines - [ "[DEPRECATED]:" <> ppBNFC'Position (Rzk.hasPosition t) - , "the following notation is deprecated and will be removed from future version of rzk:" - , " " <> Rzk.printTree t - , "instead consider using the following notation:" - , " " <> Rzk.printTree t' - ] - - ppBNFC'Position Nothing = "" - ppBNFC'Position (Just (line_, col)) = " at line " <> show line_ <> " column " <> show col - - lint orig suggestion = trace $ unlines - [ "[HINT]:" <> ppBNFC'Position (Rzk.hasPosition orig) <> " consider replacing" - , " " <> Rzk.printTree orig - , "with the following" - , " " <> Rzk.printTree suggestion - ] - - go = \case - -- Depracations - t@(Rzk.RecOrDeprecated loc psi phi a_psi a_phi) -> deprecated t - (Rzk.RecOr loc [Rzk.Restriction loc psi a_psi, Rzk.Restriction loc phi a_phi]) - t@(Rzk.TypeExtensionDeprecated loc shape type_) -> deprecated t - (Rzk.TypeFun loc shape type_) - t@(Rzk.TypeFun loc (Rzk.ParamTermTypeDeprecated loc' pat type_) ret) -> deprecated t - (Rzk.TypeFun loc (Rzk.ParamTermType loc' (patternToTerm pat) type_) ret) - t@(Rzk.TypeFun loc (Rzk.ParamVarShapeDeprecated loc' pat cube tope) ret) -> deprecated t - (Rzk.TypeFun loc (Rzk.ParamTermShape loc' (patternToTerm pat) cube tope) ret) - t@(Rzk.Lambda loc ((Rzk.ParamPatternShapeDeprecated loc' pat cube tope):params) body) -> deprecated t - (Rzk.Lambda loc ((Rzk.ParamPatternShape loc' [pat] cube tope):params) body) - -- ASCII versions - Rzk.ASCII_CubeUnitStar loc -> go (Rzk.CubeUnitStar loc) - Rzk.ASCII_Cube2_0 loc -> go (Rzk.Cube2_0 loc) - Rzk.ASCII_Cube2_1 loc -> go (Rzk.Cube2_1 loc) - Rzk.ASCII_TopeTop loc -> go (Rzk.TopeTop loc) - Rzk.ASCII_TopeBottom loc -> go (Rzk.TopeBottom loc) - Rzk.ASCII_TopeEQ loc l r -> go (Rzk.TopeEQ loc l r) - Rzk.ASCII_TopeLEQ loc l r -> go (Rzk.TopeLEQ loc l r) - Rzk.ASCII_TopeAnd loc l r -> go (Rzk.TopeAnd loc l r) - Rzk.ASCII_TopeOr loc l r -> go (Rzk.TopeOr loc l r) - - Rzk.ASCII_TypeFun loc param ret -> go (Rzk.TypeFun loc param ret) - Rzk.ASCII_TypeSigma loc pat ty ret -> go (Rzk.TypeSigma loc pat ty ret) - Rzk.ASCII_TypeSigmaTuple loc p ps tN -> go (Rzk.TypeSigmaTuple loc p ps tN) - Rzk.ASCII_Lambda loc pat ret -> go (Rzk.Lambda loc pat ret) - Rzk.ASCII_TypeExtensionDeprecated loc shape type_ -> go (Rzk.TypeExtensionDeprecated loc shape type_) - Rzk.ASCII_First loc term -> go (Rzk.First loc term) - Rzk.ASCII_Second loc term -> go (Rzk.Second loc term) - - - Rzk.Var _loc x -> bvars (varIdent x) - Rzk.Universe _loc -> Universe - - Rzk.UniverseCube _loc -> UniverseCube - Rzk.UniverseTope _loc -> UniverseTope - Rzk.CubeUnit _loc -> CubeUnit - Rzk.CubeUnitStar _loc -> CubeUnitStar - Rzk.Cube2 _loc -> Cube2 - Rzk.Cube2_0 _loc -> Cube2_0 - Rzk.Cube2_1 _loc -> Cube2_1 - Rzk.CubeI _loc -> CubeI - Rzk.CubeI_0 _loc -> CubeI_0 - Rzk.CubeI_1 _loc -> CubeI_1 - Rzk.ASCII_CubeI _loc -> CubeI - Rzk.ASCII_CubeI_0 _loc -> CubeI_0 - Rzk.ASCII_CubeI_1 _loc -> CubeI_1 - Rzk.CubeProduct _loc l r -> CubeProduct (go l) (go r) - Rzk.TopeTop _loc -> TopeTop - Rzk.TopeBottom _loc -> TopeBottom - Rzk.TopeEQ _loc l r -> TopeEQ (go l) (go r) - Rzk.TopeLEQ _loc l r -> TopeLEQ (go l) (go r) - Rzk.TopeAnd _loc l r -> TopeAnd (go l) (go r) - Rzk.TopeOr _loc l r -> TopeOr (go l) (go r) - Rzk.TopeInv _loc t -> TopeInv (go t) - Rzk.TopeUninv _loc t -> TopeUninv (go t) - Rzk.CubeFlip _loc t -> CubeFlip (go t) - Rzk.CubeUnflip _loc t -> CubeUnflip (go t) - Rzk.RecBottom _loc -> RecBottom - Rzk.RecOr _loc rs -> RecOr $ flip map rs $ \case - Rzk.Restriction _loc tope term -> (go tope, go term) - Rzk.ASCII_Restriction _loc tope term -> (go tope, go term) - Rzk.TypeId _loc x tA y -> TypeId (go x) (Just (go tA)) (go y) - Rzk.TypeIdSimple _loc x y -> TypeId (go x) Nothing (go y) - Rzk.TypeUnit _loc -> TypeUnit - Rzk.Unit _loc -> Unit - Rzk.App _loc f x -> App (go f) (go x) - Rzk.Pair _loc l r -> Pair (go l) (go r) - Rzk.Tuple _loc p1 p2 (p:ps) -> go (Rzk.Tuple _loc (Rzk.Pair _loc p1 p2) p ps) - Rzk.Tuple _loc p1 p2 [] -> go (Rzk.Pair _loc p1 p2) - Rzk.First _loc term -> First (go term) - Rzk.Second _loc term -> Second (go term) - Rzk.Refl _loc -> Refl Nothing - Rzk.ReflTerm _loc term -> Refl (Just (go term, Nothing)) - Rzk.ReflTermType _loc x tA -> Refl (Just (go x, Just (go tA))) - Rzk.IdJ _loc a b c d e f -> IdJ (go a) (go b) (go c) (go d) (go e) (go f) - Rzk.TypeAsc _loc x t -> TypeAsc (go x) (go t) - -- A binder may name several variables sharing a type, e.g. (x y : A), - -- which is parsed as the application spine `x y`. Desugar it into nested - -- one-variable binders ((x : A) → (y : A) → …) before translating, so the - -- pattern conversion never sees a juxtaposition. (Shape binders are left - -- alone: their tope refers to the single bound point.) - Rzk.TypeFun loc (Rzk.ParamTermType loc' patTerm arg) ret - | _ : _ : _ <- vars -> - go (foldr (\v -> Rzk.TypeFun loc (Rzk.ParamTermType loc' v arg)) ret vars) - where vars = flattenBinderApp patTerm - Rzk.TypeFun loc (Rzk.ParamTermModalType loc' patTerm mc ty) ret - | _ : _ : _ <- vars -> - go (foldr (\v -> Rzk.TypeFun loc (Rzk.ParamTermModalType loc' v mc ty)) ret vars) - where vars = flattenBinderApp patTerm - Rzk.TypeFun _loc (Rzk.ParamTermModalType _loc' patTerm mc ty) ret -> - let pat = unsafeTermToPattern patTerm - md = modalColonToTModality mc - in TypeFun (toBinder pat) md (go ty) Nothing (toScopePattern pat bvars ret) - Rzk.TypeFun _loc (Rzk.ParamTermModalShape _loc' patTerm mc cube tope) ret -> - let pat = unsafeTermToPattern patTerm - md = modalColonToTModality mc - in TypeFun (toBinder pat) md (go cube) (Just (toScopePattern pat bvars tope)) (toScopePattern pat bvars ret) - Rzk.TypeFun _loc (Rzk.ParamTermType _ patTerm arg) ret -> - let pat = unsafeTermToPattern patTerm - in TypeFun (toBinder pat) Id (go arg) Nothing (toScopePattern pat bvars ret) - t@(Rzk.TypeFun loc (Rzk.ParamTermShape loc' patTerm cube tope) ret) -> - let lint' = case tope of - Rzk.App _loc fun arg | void arg == void patTerm -> - lint t (Rzk.TypeFun loc (Rzk.ParamTermType loc' patTerm fun) ret) - _ -> id - pat = unsafeTermToPattern patTerm - in lint' $ TypeFun (toBinder pat) Id (go cube) (Just (toScopePattern pat bvars tope)) (toScopePattern pat bvars ret) - Rzk.TypeFun _loc (Rzk.ParamType _ arg) ret -> - TypeFun (BinderVar Nothing) Id (go arg) Nothing (toTerm (fmap S <$> bvars) ret) - - Rzk.TypeSigma _loc pat tA tB -> - TypeSigma (toBinder pat) Id (go tA) (toScopePattern pat bvars tB) - - Rzk.TypeSigmaModal _loc pat mc ty body -> - let md = modalColonToTModality mc - in TypeSigma (toBinder pat) md (go ty) (toScopePattern pat bvars body) - - Rzk.TypeSigmaTuple _loc (Rzk.SigmaParamModal _loc' pat mc ty) rest body -> - let md = modalColonToTModality mc - tailSigma = case rest of - [] -> body - [sp] -> sigmaParamToTypeSigma _loc sp body - (sp:sps) -> Rzk.TypeSigmaTuple _loc sp sps body - in TypeSigma (toBinder pat) md (go ty) (toScopePattern pat bvars tailSigma) - Rzk.TypeSigmaTuple _loc (Rzk.SigmaParam _ patA tA) (mp@(Rzk.SigmaParamModal{}) : rest) body -> - go (Rzk.TypeSigma _loc patA tA (case rest of - [] -> sigmaParamToTypeSigma _loc mp body - _ -> Rzk.TypeSigmaTuple _loc mp rest body)) - Rzk.TypeSigmaTuple _loc (Rzk.SigmaParam _ patA tA) ((Rzk.SigmaParam _ patB tB) : ps) tN -> - go (Rzk.TypeSigmaTuple _loc (Rzk.SigmaParam _loc patX tX) ps tN) - where - patX = Rzk.PatternPair _loc patA patB - tX = Rzk.TypeSigma _loc patA tA tB - Rzk.TypeSigmaTuple _loc (Rzk.SigmaParam _ pat tA) [] tB -> go (Rzk.TypeSigma _loc pat tA tB) - Rzk.Lambda _loc (Rzk.ParamPatternModalType _ [] _mc _ty : params) body -> - go (Rzk.Lambda _loc params body) - Rzk.Lambda _loc (Rzk.ParamPatternModalType loc' (pat:pats) mc ty : params) body -> - let md = modalColonToTModality mc - in Lambda (toBinder pat) (Just (md, go ty, Nothing)) - (toScopePattern pat bvars (Rzk.Lambda _loc (if null pats then params else Rzk.ParamPatternModalType loc' pats mc ty : params) body)) - Rzk.Lambda _loc (Rzk.ParamPatternModalShape _ [] _mc _cube _tope : params) body -> - go (Rzk.Lambda _loc params body) - Rzk.Lambda _loc (Rzk.ParamPatternModalShape loc' (pat:pats) mc cube tope : params) body -> - let md = modalColonToTModality mc - in Lambda (toBinder pat) (Just (md, go cube, Just (toScopePattern pat bvars tope))) - (toScopePattern pat bvars (Rzk.Lambda _loc (if null pats then params else Rzk.ParamPatternModalShape loc' pats mc cube tope : params) body)) - Rzk.Lambda _loc [] body -> go body - Rzk.Lambda _loc (Rzk.ParamPattern _ pat : params) body -> - Lambda (toBinder pat) Nothing (toScopePattern pat bvars (Rzk.Lambda _loc params body)) - Rzk.Lambda _loc (Rzk.ParamPatternType _ [] _ty : params) body -> - go (Rzk.Lambda _loc params body) - Rzk.Lambda _loc (Rzk.ParamPatternType _ (pat:pats) ty : params) body -> - Lambda (toBinder pat) (Just (Id, go ty, Nothing)) - (toScopePattern pat bvars (Rzk.Lambda _loc (Rzk.ParamPatternType _loc pats ty : params) body)) - Rzk.Lambda _loc (Rzk.ParamPatternShape _ [] _cube _tope : params) body -> - go (Rzk.Lambda _loc params body) - t@(Rzk.Lambda _loc (Rzk.ParamPatternShape _loc' (pat:pats) cube tope : params) body) -> - let lint' = case tope of - Rzk.App _loc fun arg - | null pats && void arg == void (patternToTerm pat) -> - lint t (Rzk.Lambda _loc (Rzk.ParamPatternType _loc' [pat] fun : params) body) - _ -> id - in lint' $ Lambda (toBinder pat) (Just (Id, go cube, Just (toScopePattern pat bvars tope))) - (toScopePattern pat bvars (Rzk.Lambda _loc (Rzk.ParamPatternShape _loc' pats cube tope : params) body)) - Rzk.Let _loc (Rzk.BindPattern _ pat) val expr -> - Let (toBinder pat) Nothing (go val) (toScopePattern pat bvars expr) - Rzk.Let _loc (Rzk.BindPatternType _ pat ty) val expr -> - Let (toBinder pat) (Just (go ty)) (go val) (toScopePattern pat bvars expr) - Rzk.TypeRestricted _loc ty rs -> - TypeRestricted (go ty) $ flip map rs $ \case - Rzk.Restriction _loc tope term -> (go tope, go term) - Rzk.ASCII_Restriction _loc tope term -> (go tope, go term) - - Rzk.Hole _loc (Rzk.HoleIdent _ (Rzk.HoleIdentToken tok)) -> - Hole (holeName tok) - Rzk.ModApp _loc md body -> ModApp (toModality md) (go body) - Rzk.ModType _loc md ty -> TypeModal (toModality md) (go ty) - Rzk.ModExtract{} -> error "$extract$ is an internal term and cannot appear in source" - Rzk.LetMod _loc comp (Rzk.BindPattern _ pat) val body -> - let (ext, inn) = modCompToMods comp - in LetMod (toBinder pat) ext inn Nothing (go val) (toScopePattern pat bvars body) - Rzk.LetMod _loc comp (Rzk.BindPatternType _ pat ty) val body -> - let (ext, inn) = modCompToMods comp - in LetMod (toBinder pat) ext inn (Just (go ty)) (go val) (toScopePattern pat bvars body) - - -- Translate a surface pattern into a 'Binder', keeping the pair\/tuple - -- structure so the component names can be restored when rendering. - toBinder (Rzk.PatternVar _loc (Rzk.VarIdent _ "_")) = BinderVar Nothing - toBinder (Rzk.PatternVar _loc x) = BinderVar (Just (varIdent x)) - toBinder (Rzk.PatternUnit _loc) = BinderUnit - toBinder (Rzk.PatternPair _loc l r) = BinderPair (toBinder l) (toBinder r) - toBinder (Rzk.PatternTuple loc p1 p2 ps) = toBinder (desugarTuple loc (reverse ps) p2 p1) - -patternToTerm :: Rzk.Pattern -> Rzk.Term -patternToTerm = ptt - where - ptt = \case - Rzk.PatternVar loc x -> Rzk.Var loc x - Rzk.PatternPair loc l r -> Rzk.Pair loc (ptt l) (ptt r) - Rzk.PatternUnit loc -> Rzk.Unit loc - Rzk.PatternTuple loc p1 p2 ps -> patternToTerm (desugarTuple loc (reverse ps) p2 p1) - - -modalColonModality :: Rzk.ModalColon -> Rzk.Modality -modalColonModality = \case - Rzk.ModalColonFlat loc -> Rzk.Flat loc - Rzk.ModalColonSharp loc -> Rzk.Sharp loc - Rzk.ModalColonOp loc -> Rzk.Op loc - Rzk.ModalColonId loc -> Rzk.Id loc - Rzk.ASCII_ModalColonFlat loc -> Rzk.Flat loc - Rzk.ASCII_ModalColonSharp loc -> Rzk.Sharp loc - Rzk.ASCII_ModalColonOp loc -> Rzk.Op loc - -modalColonToTModality :: Rzk.ModalColon -> TModality -modalColonToTModality = toModality . modalColonModality - -fromTModalityToModalColon :: TModality -> Rzk.ModalColon -fromTModalityToModalColon = \case - Sharp -> Rzk.ModalColonSharp Nothing - Flat -> Rzk.ModalColonFlat Nothing - Op -> Rzk.ModalColonOp Nothing - Id -> Rzk.ModalColonId Nothing - --- | Split a binder term into the individual variables it names. A multi-variable --- binder like @(x y : A)@ is parsed as the application spine @x y@; this returns --- @[x, y]@ so each can become its own nested binder. A single binder term (a --- variable, a pair pattern, …) is returned unchanged as a singleton. -flattenBinderApp :: Rzk.Term -> [Rzk.Term] -flattenBinderApp = \case - Rzk.App _loc f x -> flattenBinderApp f ++ [x] - t -> [t] - -unsafeTermToPattern :: Rzk.Term -> Rzk.Pattern -unsafeTermToPattern = ttp - where - ttp = \case - Rzk.Unit loc -> Rzk.PatternUnit loc - Rzk.Var loc x -> Rzk.PatternVar loc x - Rzk.Pair loc l r -> Rzk.PatternPair loc (ttp l) (ttp r) - Rzk.Tuple loc t1 t2 ts -> Rzk.PatternTuple loc (ttp t1) (ttp t2) (map ttp ts) - term -> error ("ERROR: expected a pattern but got\n " ++ Rzk.printTree term) - -sigmaParamToTypeSigma :: Rzk.BNFC'Position -> Rzk.SigmaParam -> Rzk.Term -> Rzk.Term -sigmaParamToTypeSigma loc sp body = case sp of - Rzk.SigmaParam _ pat ty -> Rzk.TypeSigma loc pat ty body - Rzk.SigmaParamModal _ pat mc ty -> Rzk.TypeSigmaModal loc pat mc ty body - --- | A projection step: first (@π₁@) or second (@π₂@) component. -data Proj = PFst | PSnd - deriving (Eq) - --- | Render a 'Binder' as a surface pattern (used to display the binder itself, --- e.g. @(t , s)@). Anonymous variables become @_@. -binderToPattern :: Binder -> Rzk.Pattern -binderToPattern (BinderVar Nothing) = Rzk.PatternVar Nothing (fromVarIdent "_") -binderToPattern (BinderVar (Just x)) = Rzk.PatternVar Nothing (fromVarIdent x) -binderToPattern (BinderPair l r) = Rzk.PatternPair Nothing (binderToPattern l) (binderToPattern r) -binderToPattern BinderUnit = Rzk.PatternUnit Nothing - --- | A term that prints as the binder's surface pattern, e.g. the point --- @(t , s)@. Used to render a /bare/ occurrence of a pattern binder's variable --- (one not under a projection, e.g. the point in a shape tope @Δ² (t , s)@) as --- the pattern itself rather than the underlying single variable. A --- single-variable binder yields that variable. -binderToTerm :: Binder -> Term VarIdent -binderToTerm (BinderVar Nothing) = Pure (fromString "_") -binderToTerm (BinderVar (Just x)) = Pure x -binderToTerm (BinderPair l r) = Pair (binderToTerm l) (binderToTerm r) -binderToTerm BinderUnit = Unit - --- | A 'VarIdent' that prints as the binder's surface pattern, e.g. @(t , s)@. --- Used to display a pattern binder in a hole's local context as the pattern --- itself rather than as the underlying single variable. -binderDisplayName :: Binder -> VarIdent -binderDisplayName = fromString . Rzk.printTree . binderToPattern - --- | The named leaves of a binder, each paired with the projection path that --- reaches it from the bound variable. For example @(t , (a , b))@ yields --- @[([PFst], t), ([PSnd, PFst], a), ([PSnd, PSnd], b)]@. -binderPaths :: Binder -> [([Proj], VarIdent)] -binderPaths (BinderVar (Just x)) = [([], x)] -binderPaths (BinderVar Nothing) = [] -binderPaths BinderUnit = [] -binderPaths (BinderPair l r) = - [ (PFst : p, n) | (p, n) <- binderPaths l ] ++ - [ (PSnd : p, n) | (p, n) <- binderPaths r ] - --- | The names appearing in a binder. -binderLeaves :: Binder -> [VarIdent] -binderLeaves = map snd . binderPaths - --- | Does this binder destructure a pair\/tuple (as opposed to naming a single --- variable or @_@)? -binderIsCompound :: Binder -> Bool -binderIsCompound BinderVar{} = False -binderIsCompound _ = True - --- | Refresh the named leaves of a binder so they avoid the given names (and one --- another). Anonymous leaves and the unit pattern are left unchanged. -freshenBinderLeaves :: [VarIdent] -> Binder -> Binder -freshenBinderLeaves used = snd . go used - where - go u (BinderVar (Just x)) = let x' = refreshVar u x in (x' : u, BinderVar (Just x')) - go u b@(BinderVar Nothing) = (u, b) - go u BinderUnit = (u, BinderUnit) - go u (BinderPair l r) = - let (u1, l') = go u l - (u2, r') = go u1 r - in (u2, BinderPair l' r') - --- | Decompose a chain of projections applied to a variable into the projection --- path /from the variable outwards/, matching 'binderPaths'. The outermost --- projection is applied last, so it goes at the /end/ of the path: e.g. --- @π₂ (π₁ x)@ (select @π₁@ first, then @π₂@) becomes @Just ([PFst, PSnd], x)@. -projChain :: Term a -> Maybe ([Proj], a) -projChain (First t) = (\(ps, r) -> (ps ++ [PFst], r)) <$> projChain t -projChain (Second t) = (\(ps, r) -> (ps ++ [PSnd], r)) <$> projChain t -projChain (Pure x) = Just ([], x) -projChain _ = Nothing - --- | Replace projection chains rooted at a pattern binder with the binder's --- component name. Given a map from a (bound) variable to the named leaves of --- its binder, every @π₁/π₂@ chain that reaches a named leaf is rewritten to --- that name. Ordinary projections (of variables not bound by a pattern, or --- chains that do not reach a named leaf) are left untouched. -foldBinderProjections :: Eq a => [(a, [([Proj], a)])] -> Term a -> Term a -foldBinderProjections m = go - where - go t - | Just (ps, root) <- projChain t - , not (null ps) - , Just leaves <- lookup root m - , Just nm <- lookup ps leaves - = Pure nm - go (Free f) = Free (bimap goScope go f) - go (Pure x) = Pure x - goScope = foldBinderProjections (map liftEntry m) - liftEntry (k, leaves) = (S k, map (fmap S) leaves) - --- | Replace bare uses of a pattern binder's variable with the pattern term --- (e.g. a whole point @(t , s)@ rather than the underlying single variable, in --- a tope @Δ² (t , s)@). Given a map from each (already display-named) variable --- to its binder, every free occurrence of a /compound/ binder's variable is --- expanded to its pattern. Complements 'foldBinderProjections', which folds --- /projections/ of such a variable; run this /after/ folding, so projections --- have already become component names and only bare uses remain. -restorePatternVars :: [(VarIdent, Binder)] -> Term VarIdent -> Term VarIdent -restorePatternVars binders = (>>= expand) - where - expand v = case lookup v binders of - Just b | binderIsCompound b -> binderToTerm b - _ -> Pure v - --- | Like 'projChain', but for type-annotated terms. -projChainT :: TermT a -> Maybe ([Proj], a) -projChainT (FirstT _ t) = (\(ps, r) -> (ps ++ [PFst], r)) <$> projChainT t -projChainT (SecondT _ t) = (\(ps, r) -> (ps ++ [PSnd], r)) <$> projChainT t -projChainT (Pure x) = Just ([], x) -projChainT _ = Nothing - --- | Like 'foldBinderProjections', but for type-annotated terms (e.g. those --- embedded in type errors). The annotation of a folded leaf is dropped, which --- is harmless: the result is only rendered, and a bare variable needs none. -foldBinderProjectionsT :: Eq a => [(a, [([Proj], a)])] -> TermT a -> TermT a -foldBinderProjectionsT m = go - where - go t - | Just (ps, root) <- projChainT t - , not (null ps) - , Just leaves <- lookup root m - , Just nm <- lookup ps leaves - = Pure nm - go (Free (AnnF info f)) = Free (AnnF (fmap go info) (bimap goScope go f)) - go (Pure x) = Pure x - goScope = foldBinderProjectionsT (map liftEntry m) - liftEntry (k, leaves) = (S k, map (fmap S) leaves) - -fromTerm' :: Term' -> Rzk.Term -fromTerm' t = fromTermWith' vars (defaultVarIdents \\ vars) t - where vars = freeVars t - -fromScope' :: VarIdent -> [VarIdent] -> [VarIdent] -> Scope Term VarIdent -> Rzk.Term -fromScope' x used xs = fromTermWith' (x : used) xs . (>>= f) - where - f Z = Pure x - f (S z) = Pure z - --- | Drop the binder of a scope that does not use it. The error is --- unreachable when 'Z' is not among the scope's free variables. -unusedScope :: Scope Term var -> Term var -unusedScope scope = scope >>= \case - Z -> error "unusedScope: the bound variable is used" - S z -> Pure z - --- | Like 'fromScope'', but additionally restores pattern-binder component names --- inside the scope: projections of the bound variable @x@ are folded back to --- the names recorded in @binder@ (e.g. @π₁ x@ becomes @t@). For a binder that --- names a single variable this is exactly 'fromScope''. -fromScopeBinder' :: Binder -> VarIdent -> [VarIdent] -> [VarIdent] -> Scope Term VarIdent -> Rzk.Term -fromScopeBinder' binder x used xs scope = - fromTermWith' (x : used) xs - (restorePattern (foldBinderProjections [(x, binderPaths binder)] (scope >>= f))) - where - f Z = Pure x - f (S z) = Pure z - -- After projection chains have been folded to their component names, a bare - -- use of a pattern binder's variable (the whole point, e.g. in a shape tope - -- @Δ² (t , s)@) still reads as the placeholder; show it as the pattern. - restorePattern - | binderIsCompound binder = (>>= \v -> if v == x then binderToTerm binder else Pure v) - | otherwise = id - -fromTermWith' :: [VarIdent] -> [VarIdent] -> Term' -> Rzk.Term -fromTermWith' used vars = go - where - -- Refresh a binder's named leaves against the names already in use and draw - -- fresh names for anonymous leaves from the remaining supply. - freshenBinder _ stream (BinderVar Nothing) = - case stream of - x:xs -> (BinderVar (Just x), xs) - _ -> error "not enough fresh variables!" - freshenBinder used' stream (BinderVar (Just z)) = - (BinderVar (Just z'), filter (/= z') stream) - where z' = refreshVar used' z - freshenBinder _ stream BinderUnit = (BinderUnit, stream) - freshenBinder used' stream (BinderPair l r) = - let (l', s1) = freshenBinder used' stream l - (r', s2) = freshenBinder (used' ++ binderLeaves l') s1 r - in (BinderPair l' r', s2) - - -- Pick fresh names for a binder. Yields the bound variable's display name - -- (used as the De Bruijn placeholder), the freshened binder (for the - -- displayed pattern and for projection folding), and the remaining supply. - withFreshBinder z f = - case binder' of - BinderVar (Just x) -> f (x, binder', stream) - _ -> case stream of - x:xs -> f (x, binder', xs) - _ -> error "not enough fresh variables!" - where - (binder', stream) = freshenBinder used vars z - - loc = Nothing - - goMod :: TModality -> Rzk.Modality - goMod Sharp = Rzk.Sharp loc - goMod Flat = Rzk.Flat loc - goMod Op = Rzk.Op loc - goMod Id = Rzk.Id loc - - - go :: Term' -> Rzk.Term - go = \case - Pure z -> Rzk.Var loc (fromVarIdent z) - - Universe -> Rzk.Universe loc - UniverseCube -> Rzk.UniverseCube loc - UniverseTope -> Rzk.UniverseTope loc - CubeUnit -> Rzk.CubeUnit loc - CubeUnitStar -> Rzk.CubeUnitStar loc - Cube2 -> Rzk.Cube2 loc - Cube2_0 -> Rzk.Cube2_0 loc - Cube2_1 -> Rzk.Cube2_1 loc - CubeI -> Rzk.CubeI loc - CubeI_0 -> Rzk.CubeI_0 loc - CubeI_1 -> Rzk.CubeI_1 loc - CubeProduct l r -> Rzk.CubeProduct loc (go l) (go r) - TopeTop -> Rzk.TopeTop loc - TopeBottom -> Rzk.TopeBottom loc - TopeEQ l r -> Rzk.TopeEQ loc (go l) (go r) - TopeLEQ l r -> Rzk.TopeLEQ loc (go l) (go r) - TopeAnd l r -> Rzk.TopeAnd loc (go l) (go r) - TopeOr l r -> Rzk.TopeOr loc (go l) (go r) - TopeInv t -> Rzk.TopeInv loc (go t) - TopeUninv t -> Rzk.TopeUninv loc (go t) - CubeFlip t -> Rzk.CubeFlip loc (go t) - CubeUnflip t -> Rzk.CubeUnflip loc (go t) - RecBottom -> Rzk.RecBottom loc - RecOr rs -> Rzk.RecOr loc [ Rzk.Restriction loc (go tope) (go term) | (tope, term) <- rs ] - - Hole mname -> Rzk.Hole loc (Rzk.HoleIdent loc (Rzk.HoleIdentToken (holeIdentToken mname))) - - -- An anonymous binder that the return type does not use is not shown: - -- @(x₁ : A) → B@ reads better as @A → B@. A user-written name is kept - -- even when unused. - TypeFun (BinderVar Nothing) Id arg Nothing ret - | Z `notElem` freeVars ret -> - Rzk.TypeFun loc (Rzk.ParamType loc (go arg)) (go (unusedScope ret)) - TypeFun z Id arg Nothing ret -> withFreshBinder z $ \(x, z', xs) -> - Rzk.TypeFun loc (Rzk.ParamTermType loc (patternToTerm (binderToPattern z')) (go arg)) (fromScopeBinder' z' x used xs ret) - TypeFun z Id arg (Just tope) ret -> withFreshBinder z $ \(x, z', xs) -> - Rzk.TypeFun loc (Rzk.ParamTermShape loc (patternToTerm (binderToPattern z')) (go arg) (fromScopeBinder' z' x used xs tope)) (fromScopeBinder' z' x used xs ret) - TypeFun z md arg Nothing ret -> withFreshBinder z $ \(x, z', xs) -> - Rzk.TypeFun loc (Rzk.ParamTermModalType loc (patternToTerm (binderToPattern z')) (fromTModalityToModalColon md) (go arg)) (fromScopeBinder' z' x used xs ret) - TypeFun z md arg (Just tope) ret -> withFreshBinder z $ \(x, z', xs) -> - Rzk.TypeFun loc (Rzk.ParamTermModalShape loc (patternToTerm (binderToPattern z')) (fromTModalityToModalColon md) (go arg) (fromScopeBinder' z' x used xs tope)) (fromScopeBinder' z' x used xs ret) - - TypeSigma z Id a b -> withFreshBinder z $ \(x, z', xs) -> - Rzk.TypeSigma loc (binderToPattern z') (go a) (fromScopeBinder' z' x used xs b) - TypeSigma z md a b -> withFreshBinder z $ \(x, z', xs) -> - Rzk.TypeSigmaModal loc (binderToPattern z') (fromTModalityToModalColon md) (go a) (fromScopeBinder' z' x used xs b) - TypeId l (Just tA) r -> Rzk.TypeId loc (go l) (go tA) (go r) - TypeId l Nothing r -> Rzk.TypeIdSimple loc (go l) (go r) - App l r -> Rzk.App loc (go l) (go r) - - Lambda z Nothing scope -> withFreshBinder z $ \(x, z', xs) -> - Rzk.Lambda loc [Rzk.ParamPattern loc (binderToPattern z')] (fromScopeBinder' z' x used xs scope) - Lambda z (Just (Id, ty, Nothing)) scope -> withFreshBinder z $ \(x, z', xs) -> - Rzk.Lambda loc [Rzk.ParamPatternType loc [binderToPattern z'] (go ty)] (fromScopeBinder' z' x used xs scope) - Lambda z (Just (Id, cube, Just tope)) scope -> withFreshBinder z $ \(x, z', xs) -> - Rzk.Lambda loc [Rzk.ParamPatternShape loc [binderToPattern z'] (go cube) (fromScopeBinder' z' x used xs tope)] (fromScopeBinder' z' x used xs scope) - Lambda z (Just (md, ty, Nothing)) scope -> withFreshBinder z $ \(x, z', xs) -> - Rzk.Lambda loc [Rzk.ParamPatternModalType loc [binderToPattern z'] (fromTModalityToModalColon md) (go ty)] (fromScopeBinder' z' x used xs scope) - Lambda z (Just (md, cube, Just tope)) scope -> withFreshBinder z $ \(x, z', xs) -> - Rzk.Lambda loc [Rzk.ParamPatternModalShape loc [binderToPattern z'] (fromTModalityToModalColon md) (go cube) (fromScopeBinder' z' x used xs tope)] (fromScopeBinder' z' x used xs scope) - -- Lambda (Maybe (term, Maybe scope)) scope -> Rzk.Lambda loc (Maybe (term, Maybe scope)) scope - Let z Nothing val scope -> withFreshBinder z $ \(x, z', xs) -> - Rzk.Let loc (Rzk.BindPattern loc (binderToPattern z')) (go val) (fromScopeBinder' z' x used xs scope) - Let z (Just ty) val scope -> withFreshBinder z $ \(x, z', xs) -> - Rzk.Let loc (Rzk.BindPatternType loc (binderToPattern z') (go ty)) (go val) (fromScopeBinder' z' x used xs scope) - Pair l r -> Rzk.Pair loc (go l) (go r) - First term -> Rzk.First loc (go term) - Second term -> Rzk.Second loc (go term) - TypeUnit -> Rzk.TypeUnit loc - Unit -> Rzk.Unit loc - Refl Nothing -> Rzk.Refl loc - Refl (Just (t, Nothing)) -> Rzk.ReflTerm loc (go t) - Refl (Just (t, Just ty)) -> Rzk.ReflTermType loc (go t) (go ty) - IdJ a b c d e f -> Rzk.IdJ loc (go a) (go b) (go c) (go d) (go e) (go f) - TypeAsc l r -> Rzk.TypeAsc loc (go l) (go r) - TypeRestricted ty rs -> - Rzk.TypeRestricted loc (go ty) (map (\(tope, term) -> (Rzk.Restriction loc (go tope) (go term))) rs) - TypeModal m ty -> Rzk.ModType loc (goMod m) (go ty) - ModApp m ty -> Rzk.ModApp loc (goMod m) (go ty) - ModExtract ma mb t -> Rzk.ModExtract loc (Rzk.Comp loc (goMod ma) (goMod mb)) (go t) - LetMod z ext inn Nothing val scope -> withFreshBinder z $ \(x, z', xs) -> - Rzk.LetMod loc (modsToModComp ext inn) - (Rzk.BindPattern loc (binderToPattern z')) - (go val) (fromScopeBinder' z' x used xs scope) - LetMod z ext inn (Just ty) val scope -> withFreshBinder z $ \(x, z', xs) -> - Rzk.LetMod loc (modsToModComp ext inn) - (Rzk.BindPatternType loc (binderToPattern z') (go ty)) - (go val) (fromScopeBinder' z' x used xs scope) - - -defaultVarIdents :: [VarIdent] -defaultVarIdents = - [ fromString name - | n <- [1..] - , let name = "x" <> map digitToSub (show n) ] - where - digitToSub c = chr ((ord c - ord '0') + ord '₀') - --- $setup --- >>> :set -XOverloadedStrings --- >>> import qualified Data.Text as T - --- | Given a list of used variable names in the current context, --- generate a unique fresh name based on a given one. --- --- >>> print $ refreshVar ["x", "y", "x₁", "z"] "x" --- x₂ -refreshVar :: [VarIdent] -> VarIdent -> VarIdent -refreshVar vars x - | x `elem` vars = refreshVar vars (incVarIdentIndex x) - | otherwise = x - -incVarIdentIndex :: VarIdent -> VarIdent -incVarIdentIndex (VarIdent (Rzk.VarIdent loc token)) = - VarIdent (Rzk.VarIdent loc (coerce incIndex token)) - --- | Increment the subscript number at the end of the indentifier. --- --- >>> putStrLn $ T.unpack $ incIndex "x" --- x₁ --- >>> putStrLn $ T.unpack $ incIndex "x₁₉" --- x₂₀ -incIndex :: T.Text -> T.Text -incIndex s = T.pack $ name <> newIndex - where - digitsSub = "₀₁₂₃₄₅₆₇₈₉" :: String - isDigitSub = (`elem` digitsSub) - digitFromSub c = chr ((ord c - ord '₀') + ord '0') - digitToSub c = chr ((ord c - ord '0') + ord '₀') - (name, index) = break isDigitSub (T.unpack s) - oldIndexN = read ('0' : map digitFromSub index) -- FIXME: read - newIndex = map digitToSub (show (oldIndexN + 1)) - -instance Show Term' where - show = Rzk.printTree . fromTerm' - -instance IsString Term' where - fromString = toTerm' . fromRight . Rzk.parseTerm . T.pack - where - fromRight (Left err) = error (T.unpack $ "Parse error: " <> err) - fromRight (Right t) = t - -instance Show TermT' where - show var@Pure{} = Rzk.printTree (fromTerm' (untyped var)) - show term@(Free (AnnF TypeInfo{..} _)) = termStr <> " : " <> typeStr - where - termStr = Rzk.printTree (fromTerm' (untyped term)) - typeStr = Rzk.printTree (fromTerm' (untyped infoType)) diff --git a/src/Language/Rzk/VSCode/Env.hs b/src/Language/Rzk/VSCode/Env.hs --- a/src/Language/Rzk/VSCode/Env.hs +++ b/src/Language/Rzk/VSCode/Env.hs @@ -8,16 +8,27 @@ import qualified Data.Map.Strict as Map import qualified Data.Text as T import Language.LSP.Server -import Language.Rzk.Free.Syntax (VarIdent) import Language.Rzk.Syntax (Module) import qualified Language.Rzk.VSCode.Config as RzkConfig import Language.Rzk.VSCode.Logging import qualified Language.Rzk.VSCode.ReferenceIndex as RefInd -import Rzk.TypeCheck (Decl', TypeErrorInScopedContext) +import Rzk.TypeCheck (Checked, DeclView, + TypeErrorInScopedContext) +-- | What checking one module produced. +-- +-- 'cachedModuleChecked' is the state of the whole run /after/ this module: the +-- top-level scope and every declaration elaborated so far. That is what a resume +-- starts from — a cached elaborated term names the definitions it uses by their +-- foil name, which only means anything in the scope that produced it, so the scope +-- has to be cached with them. +-- +-- 'cachedModuleDecls' is the rendered view of this module's own declarations, +-- which is all that completion, symbols and hover need. data RzkCachedModule = RzkCachedModule - { cachedModuleDecls :: [Decl'] - , cachedModuleErrors :: [TypeErrorInScopedContext VarIdent] + { cachedModuleChecked :: Checked + , cachedModuleDecls :: [DeclView] + , cachedModuleErrors :: [TypeErrorInScopedContext] } type RzkTypecheckCache = [(FilePath, RzkCachedModule)] diff --git a/src/Language/Rzk/VSCode/Handlers.hs b/src/Language/Rzk/VSCode/Handlers.hs --- a/src/Language/Rzk/VSCode/Handlers.hs +++ b/src/Language/Rzk/VSCode/Handlers.hs @@ -59,9 +59,8 @@ import System.FilePath.Glob (compile, globDir) import Data.Char (isDigit) -import Language.Rzk.Free.Syntax (RzkPosition (RzkPosition), - VarIdent (getVarIdent), - fromTerm') +import Language.Rzk.Foil.Names (RzkPosition (RzkPosition), + VarIdent (getVarIdent)) import Language.Rzk.Syntax (Module, Term, Term' (ASCII_TypeFun, TypeFun), VarIdent' (VarIdent), @@ -73,7 +72,6 @@ import Language.Rzk.VSCode.Logging import Language.Rzk.VSCode.Tokenize (mergeTokens, tokenizeModule, tokenizeSyntaxSymbols) -import Free.Scoped (untyped) import qualified Rzk.Diagnostic as Diag import Rzk.Format (format) import Rzk.Project.Config (ProjectConfig (include)) @@ -194,15 +192,15 @@ -- continues from there. unless (null parsedModules) $ withProgress "rzk typechecking" Nothing Cancellable $ \reportProgress -> - checkModules reportProgress rootPath cachedModules parsedModules + checkModulesInProject reportProgress rootPath cachedModules parsedModules where - checkModules + checkModulesInProject :: (ProgressAmount -> LSP ()) -> FilePath -- ^ Workspace root (for progress messages). -> RzkTypecheckCache -- ^ Cached results for the unchanged prefix. -> [(FilePath, Module)] -- ^ Modified modules, in project order. -> LSP () - checkModules reportProgress rootPath cache modules = go (0 :: Int) cache modules + checkModulesInProject reportProgress rootPath cache modules = go (0 :: Int) cache modules where total = length modules @@ -213,9 +211,13 @@ (Just (T.pack (makeRelative rootPath path)))) -- Run in lenient hole mode so holes are collected (and surfaced as -- hints) rather than reported as errors while editing. + -- Resume from the context of the last module that is still cached: it + -- /is/ the elaborated prefix, so nothing is replayed or re-elaborated. + let prefix = case reverse checked of + (_, entry) : _ -> cachedModuleChecked entry + [] -> emptyChecked tcResult <- liftIO $ tryTypecheck $ evaluate $ - defaultTypeCheckWithHoles $ typecheckModulesWithLocationIncremental - (map (fmap cachedModuleDecls) checked) [(path, module_)] + recheckFrom prefix [(path, module_)] case tcResult of Left (ex :: SomeException) -> do -- Just a warning to be logged in the "Output" panel and not shown to the user as an error message @@ -223,15 +225,17 @@ logWarning ("Encountered an exception while typechecking:\n" <> tshow ex) publishBlockedDiagnostics rootPath path (map fst rest) Right (Left err) -> do - logError ("An impossible error happened! Please report a bug:\n" <> T.pack (ppTypeErrorInScopedContext' BottomUp err)) + logError ("An impossible error happened! Please report a bug:\n" <> T.pack (ppTypeErrorInScopedContext BottomUp err)) publishModuleDiagnostics path [err] [] -- sort of impossible publishBlockedDiagnostics rootPath path (map fst rest) - Right (Right ((checkedModules, errors), holeInfos)) -> do + Right (Right (checkedNow, holeInfos)) -> do + let errors = checkedErrors checkedNow logDebug (T.pack path <> ": " <> tshow (length errors) <> " errors, " <> tshow (length holeInfos) <> " holes") - let decls = fromMaybe [] (lookup path checkedModules) + let decls = fromMaybe [] (lookup path (declViews checkedNow)) checked' = checked ++ - [(path, RzkCachedModule decls (filter ((== path) . filepathOfTypeError) errors))] + [(path, RzkCachedModule checkedNow decls + (filter ((== path) . filepathOfTypeError) errors))] cacheTypecheckedModules checked' publishModuleDiagnostics path errors holeInfos -- Stop at the first module with errors, like the batch checker @@ -253,7 +257,7 @@ -- per-source map over the old one, and @partitionBySource []@ has no -- "rzk" key, so the old diagnostics would survive and be re-sent. A -- max count of 0 forces an empty publish to the client, clearing it. - publishModuleDiagnostics :: FilePath -> [TypeErrorInScopedContext VarIdent] -> [HoleInfo] -> LSP () + publishModuleDiagnostics :: FilePath -> [TypeErrorInScopedContext] -> [HoleInfo] -> LSP () publishModuleDiagnostics path typeErrors holeInfos = do let errDiagnostics = [ (filepathOfTypeError err, [diagnosticOfTypeError err]) | err <- typeErrors ] @@ -291,12 +295,11 @@ (Just []) -- related information Nothing -- data that is preserved between different calls - filepathOfTypeError :: TypeErrorInScopedContext var -> FilePath - filepathOfTypeError (PlainTypeError err) = - case location (typeErrorContext err) >>= locationFilePath of + filepathOfTypeError :: TypeErrorInScopedContext -> FilePath + filepathOfTypeError (TypeErrorInScopedContext ctx _err) = + case ctxLocation ctx >>= locationFilePath of Just path -> path _ -> error "the impossible happened! Please contact Abdelrahman immediately!!!" - filepathOfTypeError (ScopedTypeError _orig err) = filepathOfTypeError err -- Map a structured library diagnostic to an LSP diagnostic. The range is -- line-level (whole line), reflecting the granularity rzk currently retains. @@ -324,7 +327,7 @@ Diag.SeverityInformation -> DiagnosticSeverity_Information Diag.SeverityHint -> DiagnosticSeverity_Hint - diagnosticOfTypeError :: TypeErrorInScopedContext VarIdent -> Diagnostic + diagnosticOfTypeError :: TypeErrorInScopedContext -> Diagnostic diagnosticOfTypeError = lspDiagnosticOf . Diag.diagnoseTypeError TopDown diagnosticOfHole :: HoleInfo -> Diagnostic @@ -389,10 +392,10 @@ logDebug ("Sending " <> T.pack (show (length items)) <> " completion items") res $ Right $ InL items where - declsToItems :: FilePath -> (FilePath, [Decl']) -> [CompletionItem] + declsToItems :: FilePath -> (FilePath, [DeclView]) -> [CompletionItem] declsToItems root (path, decls) = map (declToItem root path) decls - declToItem :: FilePath -> FilePath -> Decl' -> CompletionItem - declToItem rootDir path (Decl name type' _ _ _ _loc) = def + declToItem :: FilePath -> FilePath -> DeclView -> CompletionItem + declToItem rootDir path (DeclView name type' _ _loc) = def & label .~ T.pack (printTree $ getVarIdent name) & detail ?~ T.pack (show type') @@ -614,34 +617,36 @@ -- global's type). The surface annotation from the reference index is -- the fallback, e.g. for mid-edit or ill-typed code with no cache. defCol = RefInd.positionCharacter (RefInd.rangeStart (RefInd.locationRange (RefInd.bindingDef binding))) - -- All cached declarations go in scope, so that splitting a pair - -- binder can unfold defined Σ-types from any file of the project. - allDecls = concatMap (cachedModuleDecls . snd) cached + -- The whole checked project is in scope, so that splitting a pair binder + -- can unfold defined Σ-types from any file of it. + binderTypes = case reverse cached of + (_, entry) : _ -> binderTypesOfFile (cachedModuleChecked entry) file + [] -> [] elaboratedLocal = lookup (defLine, defCol) [ ((l - 1, c - 1), t) - | (v, t) <- binderTypesInScopeOf allDecls decls + | (v, t) <- binderTypes , let VarIdent (RzkPosition _path mpos) _ = getVarIdent v , Just (l, c) <- [mpos] ] signature = case elaboratedLocal of - Just (TypeView t) -> formatSignature (T.unpack name) (fromTerm' t) + Just (TypeView t) -> formatSignature (T.unpack name) (getRendered t) Just (ShapeView c tope) -> T.unpack name ++ " : " ++ show c ++ " | " ++ show tope Nothing -> case find declOnSameLine decls of - Just (Decl _ ty _ _ _ _) -> formatSignature (T.unpack name) (fromTerm' (untyped ty)) + Just d -> formatSignature (T.unpack name) (getRendered (declViewType d)) Nothing -> case RefInd.bindingType binding of Just ann -> T.unpack name ++ " : " ++ T.unpack ann Nothing -> case find declWithName decls of - Just (Decl _ ty _ _ _ _) -> formatSignature (T.unpack name) (fromTerm' (untyped ty)) - Nothing -> T.unpack name ++ " : ?" - declWithName (Decl v _ _ _ _ _) = + Just d -> formatSignature (T.unpack name) (getRendered (declViewType d)) + Nothing -> T.unpack name ++ " : ?" + declWithName (DeclView v _ _ _) = T.pack (printTree (getVarIdent v)) == name - declOnSameLine d@(Decl _ _ _ _ _ mloc) = + declOnSameLine d@(DeclView _ _ _ mloc) = declWithName d && (locationLine =<< mloc) == Just (defLine + 1) -- | The printed name of a declaration and the range of its defining -- occurrence, shared by the document and workspace symbol providers. -declNameRange :: Decl' -> (T.Text, Range) -declNameRange (Decl name _ _ _ _ _) = (T.pack (printTree ident), range) +declNameRange :: DeclView -> (T.Text, Range) +declNameRange (DeclView name _ _ _) = (T.pack (printTree ident), range) where ident = getVarIdent name VarIdent pos _ = ident @@ -659,10 +664,10 @@ let decls = maybe [] cachedModuleDecls (lookup currentFile cachedModules) res $ Right $ InR $ InL $ map declToSymbol decls where - declToSymbol :: Decl' -> DocumentSymbol - declToSymbol decl@(Decl _ type' _ _ _ _loc) = DocumentSymbol + declToSymbol :: DeclView -> DocumentSymbol + declToSymbol decl@(DeclView _ type' _ _loc) = DocumentSymbol { _name = symbolName - , _detail = Just (T.pack (show (untyped type'))) + , _detail = Just (T.pack (show type')) , _kind = SymbolKind_Function , _tags = Nothing , _deprecated = Nothing @@ -705,15 +710,18 @@ -- | Detects if the given path has changes in its declaration compared to what's in the cache isChanged :: RzkTypecheckCache -> FilePath -> LSP IsChanged isChanged cache path = toIsChanged $ do - let cacheWithoutErrors = map (fmap cachedModuleDecls) cache errors <- maybeToEitherLSP $ cachedModuleErrors <$> lookup path cache cachedDecls <- maybeToEitherLSP $ cachedModuleDecls <$> lookup path cache module' <- toExceptTLifted $ parseModuleFile path + -- Re-check this file from the context of the prefix before it. + let prefix = case reverse (takeWhile ((/= path) . fst) cache) of + (_, entry) : _ -> cachedModuleChecked entry + [] -> emptyChecked e <- toExceptTLifted $ try @SomeException $ evaluate $ - defaultTypeCheck (typecheckModulesWithLocationIncremental (takeWhile ((/= path) . fst) cacheWithoutErrors) [(path, module')]) - (checkedModules, errors') <- toExceptT $ return e - decls' <- maybeToEitherLSP $ lookup path checkedModules - return $ if null errors' && null errors && decls' == cachedDecls + recheckFrom prefix [(path, module')] + (checkedNow, _holes) <- toExceptT $ return e + decls' <- maybeToEitherLSP $ lookup path (declViews checkedNow) + return $ if null (checkedErrors checkedNow) && null errors && decls' == cachedDecls then NotChanged else HasChanged where diff --git a/src/Language/Rzk/VSCode/ReferenceIndex.hs b/src/Language/Rzk/VSCode/ReferenceIndex.hs --- a/src/Language/Rzk/VSCode/ReferenceIndex.hs +++ b/src/Language/Rzk/VSCode/ReferenceIndex.hs @@ -1,4 +1,5 @@ {-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} {-# LANGUAGE OverloadedStrings #-} module Language.Rzk.VSCode.ReferenceIndex ( @@ -15,13 +16,17 @@ ) where import Control.Applicative ((<|>)) -import Data.Bifunctor (bimap) import qualified Data.Map.Strict as Map import Data.Maybe (listToMaybe) import qualified Data.Text as T -import qualified Free.Scoped as Scoped -import qualified Language.Rzk.Free.Syntax as Free +import Language.Rzk.Foil.Convert (withOpenTerm) +import qualified Language.Rzk.Foil.Names as Free +import Language.Rzk.Foil.Print (fromTerm) +import Language.Rzk.Foil.Syntax (Term, instantiateUntyped, + pattern CubeProduct, pattern First, + pattern Pair, pattern Second, + pattern TypeSigma) import qualified Language.Rzk.Syntax as Rzk data Uri = Uri @@ -171,26 +176,35 @@ -- only inherit their cube. splitPairAnn :: Rzk.Term -> BinderAnn -> Maybe (BinderAnn, BinderAnn) splitPairAnn firstComp (AnnShape cube _tope) = splitPairAnn firstComp (AnnType cube) -splitPairAnn firstComp (AnnType ty) = case Free.toTerm' ty of - Free.CubeProduct a b -> Just (fromCore a, fromCore b) - Free.TypeSigma _ _ a scope -> - Just ( fromCore a - , fromCore (reduceProjections (Scoped.substitute (Free.toTerm' firstComp) scope)) - ) - _ -> Nothing +splitPairAnn firstComp (AnnType ty) = + -- The annotation is an open term (it mentions whatever is in scope where it was + -- written), so every identifier in it gets a name, and the names are mapped back + -- when it is printed. + withOpenTerm (Rzk.Pair Nothing ty firstComp) $ \scope names paired -> + case paired of + Pair ty' first' -> case ty' of + CubeProduct a b -> Just (render names a, render names b) + TypeSigma _ _ a scoped -> + Just ( render names a + , render names (reduceProjections (instantiateUntyped scope scoped first')) + ) + _ -> Nothing + _ -> Nothing where - fromCore = AnnType . Free.fromTerm' + render names = AnnType . fromTerm [] [] names --- | Reduce projections of literal pairs (π₁ (a, b) → a). A pattern binder --- refers to its components through projections, so substituting a pair for --- it leaves these redexes behind. -reduceProjections :: Scoped.FS Free.TermF a -> Scoped.FS Free.TermF a +-- | Reduce projections of literal pairs (π₁ (a, b) → a). A pattern binder refers to +-- its components through projections, so substituting a pair for it leaves these +-- redexes behind. +reduceProjections :: Term n -> Term n reduceProjections = \case - Scoped.Pure x -> Scoped.Pure x - Scoped.Free f -> case Scoped.Free (bimap reduceProjections reduceProjections f) of - Free.First (Free.Pair a _) -> a - Free.Second (Free.Pair _ b) -> b - t -> t + First t -> case reduceProjections t of + Pair a _ -> a + t' -> First t' + Second t -> case reduceProjections t of + Pair _ b -> b + t' -> Second t' + t -> t -- | A pattern as the term it matches. patternTerm :: Rzk.Pattern -> Rzk.Term diff --git a/src/Rzk/Diagnostic.hs b/src/Rzk/Diagnostic.hs --- a/src/Rzk/Diagnostic.hs +++ b/src/Rzk/Diagnostic.hs @@ -15,7 +15,6 @@ import Data.Aeson (ToJSON (..), Value (String), object, (.=)) -import Language.Rzk.Free.Syntax (VarIdent) import Rzk.TypeCheck -- | Diagnostic severity, mirroring the usual LSP levels. @@ -123,7 +122,7 @@ -- | A stable tag for a type error, used as its diagnostic code. Independent of -- the variable type, so it survives the scoped-error unfolding. -typeErrorTag :: TypeError var -> String +typeErrorTag :: TypeError n -> String typeErrorTag = \case TypeErrorOther{} -> "TypeErrorOther" TypeErrorUnify{} -> "TypeErrorUnify" @@ -151,27 +150,25 @@ TypeErrorUnusedUsedVariables{} -> "TypeErrorUnusedUsedVariables" TypeErrorImplicitAssumption{} -> "TypeErrorImplicitAssumption" --- | The tag of a scoped type error (peels the binder layers; the tag does not --- depend on the variable type). -typeErrorTagInScopedContext :: TypeErrorInScopedContext var -> String -typeErrorTagInScopedContext = \case - PlainTypeError e -> typeErrorTag (typeErrorError e) - ScopedTypeError _ e -> typeErrorTagInScopedContext e +-- | The tag of a type error. +-- +-- An error carries the context it was raised in, so there are no binder layers to +-- peel: the old representation nested the error one Inc deeper at every binder. +typeErrorTagInScopedContext :: TypeErrorInScopedContext -> String +typeErrorTagInScopedContext (TypeErrorInScopedContext _ctx err) = typeErrorTag err --- | The source location of a scoped type error (the enclosing command's line). -locationOfTypeError :: TypeErrorInScopedContext var -> Maybe LocationInfo -locationOfTypeError = \case - PlainTypeError e -> location (typeErrorContext e) - ScopedTypeError _ e -> locationOfTypeError e +-- | The source location of a type error (the enclosing command's line). +locationOfTypeError :: TypeErrorInScopedContext -> Maybe LocationInfo +locationOfTypeError (TypeErrorInScopedContext ctx _err) = ctxLocation ctx -- | A structured diagnostic for a type error. The message is the usual -- formatted error text; severity is always 'SeverityError'. -diagnoseTypeError :: OutputDirection -> TypeErrorInScopedContext VarIdent -> Diagnostic +diagnoseTypeError :: OutputDirection -> TypeErrorInScopedContext -> Diagnostic diagnoseTypeError dir err = Diagnostic { diagnosticSeverity = SeverityError , diagnosticCode = typeErrorTagInScopedContext err , diagnosticLocation = locationOfTypeError err - , diagnosticMessage = ppTypeErrorInScopedContext' dir err + , diagnosticMessage = ppTypeErrorInScopedContext dir err , diagnosticHole = Nothing } diff --git a/src/Rzk/Main.hs b/src/Rzk/Main.hs --- a/src/Rzk/Main.hs +++ b/src/Rzk/Main.hs @@ -93,13 +93,13 @@ typecheckString :: T.Text -> Either T.Text T.Text typecheckString moduleString = do rzkModule <- Rzk.parseModule moduleString - case defaultTypeCheck (typecheckModules [rzkModule]) of + case typecheckModules [("", rzkModule)] of Left err -> Left $ T.unlines [ "An error occurred when typechecking!" , "Rendering type error... (this may take a few seconds)" , T.unlines [ "Type Error:" - , T.pack $ ppTypeErrorInScopedContext' BottomUp err + , T.pack $ ppTypeErrorInScopedContext BottomUp err ] ] Right _ -> pure "Everything is ok!" diff --git a/src/Rzk/Render/Geometry.hs b/src/Rzk/Render/Geometry.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/Render/Geometry.hs @@ -0,0 +1,274 @@ +{-# LANGUAGE RecordWildCards #-} + +-- | The geometry behind the SVG rendering of cubes, and nothing else. +-- +-- Rzk renders a (sub)shape of a cube as an SVG diagram: the vertices, edges and +-- faces of the unit cube are projected to the plane through a camera, and each +-- of them is labelled with the term that inhabits it. This module holds the part +-- of that story which knows nothing about terms: the projection matrices, the +-- camera, and 'renderCube', which draws a cube given only a function saying what +-- (if anything) to draw on each of its parts. +-- +-- Nothing here mentions the type checker, so it is shared by both term +-- representations during the free-foil migration. +module Rzk.Render.Geometry where + +import Data.List (intercalate, tails) + +-- | The name of a vertex of the unit cube, as a string of coordinates +-- (e.g. @"010"@). +type PointId = String + +-- | The name of a subshape of the unit cube: its vertices, in order, joined by +-- dashes (e.g. @"000-011"@ for an edge, @"000"@ for a vertex). +type ShapeId = [PointId] + +type Point2D a = (a, a) +type Point3D a = (a, a, a) +type Edge3D a = (Point3D a, Point3D a) +type Face3D a = (Point3D a, Point3D a, Point3D a) +type Volume3D a = (Point3D a, Point3D a, Point3D a, Point3D a) + +data CubeCoords2D a b = CubeCoords2D + { vertices :: [(Point3D a, Point2D b)] + , edges :: [(Edge3D a, (Point2D b, Point2D b))] + , faces :: [(Face3D a, (Point2D b, Point2D b, Point2D b))] + , volumes :: [(Volume3D a, (Point2D b, Point2D b, Point2D b, Point2D b))] + } + +data Matrix3D a = Matrix3D + a a a + a a a + a a a + +data Matrix4D a = Matrix4D + a a a a + a a a a + a a a a + a a a a + +data Vector3D a = Vector3D a a a + +data Vector4D a = Vector4D a a a a + +rotateX :: Floating a => a -> Matrix3D a +rotateX theta = Matrix3D + 1 0 0 + 0 (cos theta) (- sin theta) + 0 (sin theta) (cos theta) + +rotateY :: Floating a => a -> Matrix3D a +rotateY theta = Matrix3D + (cos theta) 0 (sin theta) + 0 1 0 + (- sin theta) 0 (cos theta) + +rotateZ :: Floating a => a -> Matrix3D a +rotateZ theta = Matrix3D + (cos theta) (- sin theta) 0 + (sin theta) (cos theta) 0 + 0 0 1 + +data Camera a = Camera + { cameraPos :: Point3D a + , cameraFoV :: a + , cameraAspectRatio :: a + , cameraAngleY :: a + , cameraAngleX :: a + } + +viewRotateX :: Floating a => Camera a -> Matrix4D a +viewRotateX Camera{..} = matrix3Dto4D (rotateX cameraAngleX) + +viewRotateY :: Floating a => Camera a -> Matrix4D a +viewRotateY Camera{..} = matrix3Dto4D (rotateY cameraAngleY) + +viewTranslate :: Num a => Camera a -> Matrix4D a +viewTranslate Camera{..} = Matrix4D + 1 0 0 0 + 0 1 0 0 + 0 0 1 0 + (-x) (-y) (-z) 1 + where + (x, y, z) = cameraPos + +project2D :: Floating a => Camera a -> Matrix4D a +project2D Camera{..} = Matrix4D + (2 * n / (r - l)) 0 ((r + l) / (r - l)) 0 + 0 (2 * n / (t - b)) ((t + b) / (t - b)) 0 + 0 0 (- (f + n) / (f - n)) (- 2 * f * n / (f - n)) + 0 0 (-1) 0 + where + n = 1 + f = 2 + r = n * tan (cameraFoV / 2) + l = -r + t = r * cameraAspectRatio + b = -t + + +matrixVectorMult4D :: Num a => Matrix4D a -> Vector4D a -> Vector4D a +matrixVectorMult4D + (Matrix4D + a1 a2 a3 a4 + b1 b2 b3 b4 + c1 c2 c3 c4 + d1 d2 d3 d4) + (Vector4D a b c d) + = Vector4D a' b' c' d' + where + a' = sum (zipWith (*) [a1, b1, c1, d1] [a, b, c, d]) + b' = sum (zipWith (*) [a2, b2, c2, d2] [a, b, c, d]) + c' = sum (zipWith (*) [a3, b3, c3, d3] [a, b, c, d]) + d' = sum (zipWith (*) [a4, b4, c4, d4] [a, b, c, d]) + +matrix3Dto4D :: Num a => Matrix3D a -> Matrix4D a +matrix3Dto4D + (Matrix3D + a1 b1 c1 + a2 b2 c2 + a3 b3 c3) = Matrix4D + a1 b1 c1 0 + a2 b2 c2 0 + a3 b3 c3 0 + 0 0 0 1 + +fromAffine :: Fractional a => Vector4D a -> (Point2D a, a) +fromAffine (Vector4D a b c d) = ((x, y), zIndex) + where + x = a / d + y = b / d + zIndex = c / d + +point3Dto2D :: Floating a => Camera a -> a -> Point3D a -> (Point2D a, a) +point3Dto2D camera rotY (x, y, z) = fromAffine $ + foldr matrixVectorMult4D (Vector4D x y z 1) $ reverse + [ matrix3Dto4D (rotateY rotY) + , viewTranslate camera + , viewRotateY camera + , viewRotateX camera + , project2D camera + ] + +-- | What to draw on one part (vertex, edge or face) of a cube. +data RenderObjectData = RenderObjectData + { renderObjectDataLabel :: String + , renderObjectDataFullLabel :: String + , renderObjectDataColor :: String + } + +limitLength :: Int -> String -> String +limitLength n s + | length s > n = take (n - 1) s <> "…" + | otherwise = s + +-- | Apply the term-hiding policy to a cell's render data: drop the @\@ +-- (the full term) from every cell, and blank the visible label of a +-- proof-coloured (interior) cell. Boundary cells (coloured otherwise) keep +-- their given labels. A no-op when not hiding. +hideTermData :: Bool -> String -> RenderObjectData -> RenderObjectData +hideTermData False _ d = d +hideTermData True mainColor d + | renderObjectDataColor d == mainColor = + d { renderObjectDataLabel = "", renderObjectDataFullLabel = "" } + | otherwise = d { renderObjectDataFullLabel = "" } + +renderCube + :: (Floating a, Show a) + => Camera a + -> a + -> (String -> Maybe RenderObjectData) + -> String +renderCube camera rotY renderDataOf' = unlines $ filter (not . null) + [ "" + , intercalate "\n" + [ " show x1 <> " " <> show y1 + <> " L " <> show x2 <> " " <> show y2 + <> " L " <> show x3 <> " " <> show y3 + <> " Z\" style=\"fill: " <> renderObjectDataColor <> "; opacity: 0.2\">" <> renderObjectDataFullLabel <> "" <> "\n" <> + " show x <> "\" y=\"" <> show y <> "\" fill=\"" <> renderObjectDataColor <> "\">" <> renderObjectDataLabel <> "" + | (faceId, (((x1, y1), (x2, y2), (x3, y3)), _)) <- faces + , Just RenderObjectData{..} <- [renderDataOf faceId] + , let x = (x1 + x2 + x3) / 3 + , let y = (y1 + y2 + y3) / 3 ] + , intercalate "\n" + [ " show x1 <> "," <> show y1 <> " " <> show x2 <> "," <> show y2 + <> "\" stroke=\"" <> renderObjectDataColor <> "\" stroke-width=\"3\" marker-end=\"url(#arrow)\">" <> renderObjectDataFullLabel <> "" <> "\n" <> + " show x <> "\" y=\"" <> show y <> "\" fill=\"" <> renderObjectDataColor <> "\" stroke=\"white\" stroke-width=\"10\" stroke-opacity=\".8\" paint-order=\"stroke\">" <> renderObjectDataLabel <> "" + | (edge, (((x1, y1), (x2, y2)), _)) <- edges + , Just RenderObjectData{..} <- [renderDataOf edge] + , let x = (x1 + x2) / 2 + , let y = (y1 + y2) / 2 ] + , intercalate "\n" + [ " show x <> "\" y=\"" <> show y <> "\" fill=\"" <> renderObjectDataColor <> "\">" <> renderObjectDataLabel <> "" + | (v, ((x, y), _)) <- vertices + , Just RenderObjectData{..} <- [renderDataOf v]] + , "" ] + where + renderDataOf shapeId = + case renderDataOf' shapeId of + Nothing -> Nothing + Just RenderObjectData{..} -> Just RenderObjectData + -- FIXME: move constants to configurable parameters + { renderObjectDataLabel = hideWhenLargerThan shapeId 5 renderObjectDataLabel + , renderObjectDataFullLabel = limitLength 30 renderObjectDataFullLabel + , .. } + + hideWhenLargerThan shapeId n s + | null s || length s > n = if '-' `elem` shapeId then "" else "•" + | otherwise = s + + vertices = + [ (show x <> show y <> show z, ((500 * x'', 500 * y''), zIndex)) + | x <- [0,1] + , y <- [0,1] + , z <- [0,1] + , let f c = 2 * fromInteger c - 1 + , let x' = f x + , let y' = f (1-y) + , let z' = f z + , let ((x'', y''), zIndex) = point3Dto2D camera rotY (x', y', z') ] + + radius = 20 + + mkEdge r (x1, y1) (x2, y2) = ((x1 + dx, y1 + dy), ((x2 - dx), (y2 - dy))) + where + d = sqrt ((x2 - x1)^(2 :: Int) + (y2 - y1)^(2 :: Int)) + dx = r * (x2 - x1) / d + dy = r * (y2 - y1) / d + + scaleAround (cx, cy) s (x, y) = (cx + s * (x - cx), cy + s * (y - cy)) + + mkFace (x1, y1) (x2, y2) (x3, y3) = (p1, p2, p3) + where + cx = (x1 + x2 + x3) / 3 + cy = (y1 + y2 + y3) / 3 + p1 = scaleAround (cx, cy) 0.85 (x1, y1) + p2 = scaleAround (cx, cy) 0.85 (x2, y2) + p3 = scaleAround (cx, cy) 0.85 (x3, y3) + + edges = + [ (intercalate "-" [fromName, toName], (mkEdge radius from to, 0 :: Int)) + | (fromName, (from, _)) : vs <- tails vertices + , (toName, (to, _)) <- vs + , and (zipWith (<=) fromName toName) + ] + + faces = + [ (intercalate "-" [name1, name2, name3], (mkFace v1 v2 v3, 0 :: Int)) + | (name1, (v1, _)) : vs <- tails vertices + , (name2, (v2, _)) : vs' <- tails vs + , and (zipWith (<=) name1 name2) + , (name3, (v3, _)) <- vs' + , and (zipWith (<=) name2 name3) + ] + + +defaultCamera :: Floating a => Camera a +defaultCamera = Camera + { cameraPos = (0, 7, 10) + , cameraAngleY = pi + , cameraAngleX = pi/5 + , cameraFoV = pi/15 + , cameraAspectRatio = 1 + } diff --git a/src/Rzk/TypeCheck.hs b/src/Rzk/TypeCheck.hs --- a/src/Rzk/TypeCheck.hs +++ b/src/Rzk/TypeCheck.hs @@ -1,5507 +1,25 @@ -{-# OPTIONS_GHC -fno-warn-type-defaults -fno-warn-orphans #-} -{-# LANGUAGE DeriveFoldable #-} -{-# LANGUAGE DeriveFunctor #-} -{-# LANGUAGE FlexibleInstances #-} -{-# LANGUAGE LambdaCase #-} -{-# LANGUAGE OverloadedStrings #-} -{-# LANGUAGE RecordWildCards #-} -module Rzk.TypeCheck where - -import Control.Applicative ((<|>)) -import Control.Monad (forM, forM_, join, unless, when) -import Control.Monad.Except -import Control.Monad.Reader --- An explicit list: a bare 'Control.Monad.Writer' import also re-exports --- 'Data.Monoid' (incl. 'First'/'Last') on some mtl versions, which clashes with --- the 'First'/'Last' term patterns from 'Language.Rzk.Free.Syntax'. -import Control.Monad.Writer (WriterT, censor, runWriterT, tell) -import Data.Bifoldable (bifoldr) -import Data.Bifunctor (first) -import Data.List (intercalate, intersect, nub, partition, - tails, (\\)) -import Data.Maybe (catMaybes, fromMaybe, isNothing, - mapMaybe) -import Data.String (IsString (..)) -import Data.Tuple (swap) - -import Free.Scoped -import Language.Rzk.Free.Syntax -import qualified Language.Rzk.Syntax as Rzk - -import Debug.Trace -import Unsafe.Coerce - --- $setup --- >>> :set -XOverloadedStrings - - --- | Parse and 'unsafeInferStandalone''. -instance IsString TermT' where - fromString = unsafeInferStandalone' . fromString - -defaultTypeCheck - :: TypeCheck VarIdent a - -> Either (TypeErrorInScopedContext VarIdent) a -defaultTypeCheck = fmap fst . defaultTypeCheckWithHoles' emptyContext - --- | Like 'defaultTypeCheck', but runs in lenient hole mode ('allowHoles') and --- also returns the holes recorded during checking (with their goal and context). -defaultTypeCheckWithHoles - :: TypeCheck VarIdent a - -> Either (TypeErrorInScopedContext VarIdent) (a, [HoleInfo]) -defaultTypeCheckWithHoles = defaultTypeCheckWithHoles' (allowHoles emptyContext) - -defaultTypeCheckWithHoles' - :: Context var - -> TypeCheck var a - -> Either (TypeErrorInScopedContext var) (a, [HoleInfo]) -defaultTypeCheckWithHoles' ctx tc = - runExcept (runWriterT (runReaderT tc ctx)) - --- FIXME: merge with VarInfo -data Decl var = Decl - { declName :: var - , declType :: TermT var - , declValue :: Maybe (TermT var) - , declIsAssumption :: Bool - , declUsedVars :: [var] - , declLocation :: Maybe LocationInfo - } deriving Eq - -type Decl' = Decl VarIdent - -typecheckModulesWithLocationIncremental - :: [(FilePath, [Decl'])] -- ^ Cached declarations (only those that do not need rechecking). - -> [(FilePath, Rzk.Module)] -- ^ New modules to check - -> TypeCheck VarIdent ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent]) -typecheckModulesWithLocationIncremental cached modulesToTypecheck = do - let decls = foldMap snd cached - localDeclsPrepared decls $ do - (checked, errors) <- typecheckModulesWithLocation' modulesToTypecheck - return (cached <> checked, errors) - -typecheckModulesWithLocation' :: [(FilePath, Rzk.Module)] -> TypeCheck VarIdent ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent]) -typecheckModulesWithLocation' = \case - [] -> return ([], []) - m@(path, _) : ms -> do - (decls, errs) <- typecheckModuleWithLocation m - case errs of - _:_ -> return ([(path, decls)], errs) - _ -> do - localDeclsPrepared decls $ do - (decls', errors) <- typecheckModulesWithLocation' ms - return ((path, decls) : decls', errors) - --- | Typecheck modules in lenient hole mode, returning the elaborated --- declarations, any type errors, and the holes recorded (each with its goal and --- local context). This is the structured goal/context query consumed by the --- LSP and the game. Strict callers (the default CLI path, CI) keep using --- 'typecheckModulesWithLocation', where holes are 'TypeErrorUnsolvedHole'. -typecheckModulesWithHoles - :: [(FilePath, Rzk.Module)] - -> Either (TypeErrorInScopedContext VarIdent) - ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent], [HoleInfo]) -typecheckModulesWithHoles = typecheckModulesWithHolesAndLemmas [] - --- | Like 'typecheckModulesWithHoles', but additionally offers the given named --- top-level definitions as hole candidates (each applied to holes when its type --- fits the goal). The game passes a level's allow-list of relevant lemmas so --- they surface as moves; an empty list reproduces 'typecheckModulesWithHoles'. -typecheckModulesWithHolesAndLemmas - :: [VarIdent] - -> [(FilePath, Rzk.Module)] - -> Either (TypeErrorInScopedContext VarIdent) - ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent], [HoleInfo]) -typecheckModulesWithHolesAndLemmas lemmas modules = - flatten <$> defaultTypeCheckWithHoles' - (withHintLemmas lemmas (allowHoles emptyContext)) - (typecheckModulesWithLocation' modules) - where - flatten ((decls, errs), holes) = (decls, errs, holes) - -typecheckModulesWithLocation :: [(FilePath, Rzk.Module)] -> TypeCheck VarIdent [(FilePath, [Decl'])] -typecheckModulesWithLocation = \case - [] -> return [] - m@(path, _) : ms -> do - (decls, errs) <- typecheckModuleWithLocation m - case errs of - err : _ -> do - throwError err - [] -> localDeclsPrepared decls $ - ((path, decls) :) <$> typecheckModulesWithLocation ms - -typecheckModules :: [Rzk.Module] -> TypeCheck VarIdent [Decl'] -typecheckModules = \case - [] -> return [] - m : ms -> do - (decls, errs) <- typecheckModule Nothing m - case errs of - err : _ -> do - throwError err - _ -> do - localDeclsPrepared decls $ - (decls <>) <$> typecheckModules ms - -typecheckModuleWithLocation :: (FilePath, Rzk.Module) -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]) -typecheckModuleWithLocation (path, module_) = do - traceTypeCheck Normal ("Checking module from " <> path) $ do - withLocation (LocationInfo { locationFilePath = Just path, locationLine = Nothing }) $ - typecheckModule (Just path) module_ - -countCommands :: Integral a => [Rzk.Command] -> a -countCommands = fromIntegral . length - -typecheckModule :: Maybe FilePath -> Rzk.Module -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]) -typecheckModule path (Rzk.Module _moduleLoc _lang commands) = - withSection Nothing (go 1 commands) $ -- FIXME: use module name? or anonymous section? - return ([], []) - where - totalCommands = countCommands commands - - go :: Integer -> [Rzk.Command] -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]) - go _i [] = return ([], []) - - go i (command@(Rzk.CommandUnsetOption _loc optionName) : moreCommands) = do - traceTypeCheck Normal ("[ " <> show i <> " out of " <> show totalCommands <> " ]" - <> " Unsetting option " <> optionName) $ do - withCommand command $ do - unsetOption optionName $ - go (i + 1) moreCommands - - go i (command@(Rzk.CommandSetOption _loc optionName optionValue) : moreCommands) = do - traceTypeCheck Normal ("[ " <> show i <> " out of " <> show totalCommands <> " ]" - <> " Setting option " <> optionName <> " = " <> optionValue ) $ do - withCommand command $ do - setOption optionName optionValue $ - go (i + 1) moreCommands - - go i (command@(Rzk.CommandDefine _loc name (Rzk.DeclUsedVars _ vars) params ty term) : moreCommands) = - traceTypeCheck Normal ("[ " <> show i <> " out of " <> show totalCommands <> " ]" - <> " Checking #define " <> Rzk.printTree name ) $ do - withCommand command $ do - mapM_ checkDefinedVar (varIdentAt path <$> vars) - paramDecls <- concat <$> mapM paramToParamDecl params - -- Store the elaborated type and term unreduced, but memoise their - -- WHNF on the top node (see 'memoizeWHNF'). Reducing in place would - -- discard or expose a variable occurrence, so the section - -- unused/implicit-assumption checks (run over the stored type and - -- value) would disagree with the term the user wrote; keeping the - -- WHNF cached preserves the original one-shot reduction. - ty' <- memoizeWHNF =<< typecheck (toTerm' (addParamDecls paramDecls ty)) universeT - term' <- memoizeWHNF =<< typecheck (toTerm' (addParams params term)) ty' - loc <- asks location - let decl = Decl (varIdentAt path name) ty' (Just term') False (varIdentAt path <$> vars) loc - fmap (first (decl :)) $ - localDeclPrepared decl $ do - Context{..} <- ask - termSVG <- - case renderBackend of - Just RenderSVG -> renderTermSVG (Pure (varIdentAt path name)) - Just RenderLaTeX -> issueTypeError $ TypeErrorOther "\"latex\" rendering is not yet supported" - Nothing -> pure Nothing - maybe id trace termSVG $ do - go (i + 1) moreCommands - - go i (command@(Rzk.CommandPostulate _loc name (Rzk.DeclUsedVars _ vars) params ty) : moreCommands) = - traceTypeCheck Normal ("[ " <> show i <> " out of " <> show totalCommands <> " ]" - <> " Checking #postulate " <> Rzk.printTree name) $ do - withCommand command $ do - mapM_ checkDefinedVar (varIdentAt path <$> vars) - paramDecls <- concat <$> mapM paramToParamDecl params - ty' <- memoizeWHNF =<< typecheck (toTerm' (addParamDecls paramDecls ty)) universeT - loc <- asks location - let decl = Decl (varIdentAt path name) ty' Nothing False (varIdentAt path <$> vars) loc - fmap (first (decl :)) $ - localDeclPrepared decl $ - go (i + 1) moreCommands - - go i (command@(Rzk.CommandCheck _loc term ty) : moreCommands) = - traceTypeCheck Normal ("[ " <> show i <> " out of " <> show totalCommands <> " ]" - <> " Checking " <> Rzk.printTree term <> " : " <> Rzk.printTree ty ) $ do - withCommand command $ do - ty' <- typecheck (toTerm' ty) universeT >>= whnfT - _term' <- typecheck (toTerm' term) ty' - go (i + 1) moreCommands - - go i (Rzk.CommandCompute loc term : moreCommands) = - go i (Rzk.CommandComputeWHNF loc term : moreCommands) - - go i (command@(Rzk.CommandComputeNF _loc term) : moreCommands) = - traceTypeCheck Normal ("[ " <> show i <> " out of " <> show totalCommands <> " ]" - <> " Computing NF for " <> Rzk.printTree term) $ do - withCommand command $ do - term' <- infer (toTerm' term) >>= nfT - traceTypeCheck Normal (" " <> show (untyped term')) $ do - go (i + 1) moreCommands - - go i (command@(Rzk.CommandComputeWHNF _loc term) : moreCommands) = - traceTypeCheck Normal ("[ " <> show i <> " out of " <> show totalCommands <> " ]" - <> " Computing WHNF for " <> Rzk.printTree term) $ do - withCommand command $ do - term' <- infer (toTerm' term) >>= whnfT - traceTypeCheck Normal (" " <> show (untyped term')) $ do - go (i + 1) moreCommands - - go i (command@(Rzk.CommandAssume _loc names ty) : moreCommands) = - traceTypeCheck Normal ("[ " <> show i <> " out of " <> show totalCommands <> " ]" - <> " Checking #assume " <> intercalate " " [ Rzk.printTree name | name <- names ] ) $ do - withCommand command $ do - ty' <- typecheck (toTerm' ty) universeT - loc <- asks location - let decls = [ Decl (varIdentAt path name) ty' Nothing True [] loc | name <- names ] - fmap (first (decls <>)) $ - localDeclsPrepared decls $ - go (i + 1) moreCommands - - go i (command@(Rzk.CommandSection _loc name) : moreCommands) = do - withCommand command $ do - (sectionCommands, moreCommands') <- splitSectionCommands name moreCommands - withSection (Just name) (go i sectionCommands) $ do - go (i + countCommands sectionCommands) moreCommands' - - go _i (command@(Rzk.CommandSectionEnd _loc endName) : _moreCommands) = do - withCommand command $ - issueTypeError $ TypeErrorOther $ - "unexpected #end " <> Rzk.printTree endName <> ", no section was declared!" - - -splitSectionCommands :: Rzk.SectionName -> [Rzk.Command] -> TypeCheck var ([Rzk.Command], [Rzk.Command]) -splitSectionCommands name [] = - issueTypeError (TypeErrorOther $ "Section " <> Rzk.printTree name <> " is not closed with an #end") -splitSectionCommands name (Rzk.CommandSection _loc name' : moreCommands) = do - (cs1, cs2) <- splitSectionCommands name' moreCommands - (cs3, cs4) <- splitSectionCommands name cs2 - return (cs1 <> cs3, cs4) -splitSectionCommands name (Rzk.CommandSectionEnd _loc endName : moreCommands) = do - when (Rzk.printTree name /= Rzk.printTree endName) $ - issueTypeError $ TypeErrorOther $ - "unexpected #end " <> Rzk.printTree endName <> ", expecting #end " <> Rzk.printTree name - return ([], moreCommands) -splitSectionCommands name (command : moreCommands) = do - (cs1, cs2) <- splitSectionCommands name moreCommands - return (command : cs1, cs2) - -setOption :: String -> String -> TypeCheck var a -> TypeCheck var a -setOption "verbosity" = \case - "debug" -> localVerbosity Debug - "normal" -> localVerbosity Normal - "silent" -> localVerbosity Silent - _ -> const $ - issueTypeError $ TypeErrorOther "unknown verbosity level (use \"debug\", \"normal\", or \"silent\")" -setOption "render" = \case - "svg" -> localRenderBackend (Just RenderSVG) - "latex" -> localRenderBackend (Just RenderLaTeX) - "none" -> localRenderBackend Nothing - _ -> const $ - issueTypeError $ TypeErrorOther "unknown render backend (use \"svg\", \"latex\", or \"none\")" --- | Render the shape only, hiding the proof term (drop the @\@ --- everywhere and blank interior labels), so a worked term can be shown as the --- cell it builds without giving the term away (see 'renderHideTerm'). -setOption "render-hide-term" = \case - "yes" -> localHideTerm True - "no" -> localHideTerm False - _ -> const $ - issueTypeError $ TypeErrorOther "unknown value for \"render-hide-term\" (use \"yes\" or \"no\")" -setOption optionName = const $ const $ - issueTypeError $ TypeErrorOther ("unknown option " <> show optionName) - -unsetOption :: String -> TypeCheck var a -> TypeCheck var a -unsetOption "verbosity" = localVerbosity (verbosity emptyContext) -unsetOption "render" = localRenderBackend (renderBackend emptyContext) -unsetOption "render-hide-term" = localHideTerm (renderHideTerm emptyContext) -unsetOption optionName = const $ - issueTypeError $ TypeErrorOther ("unknown option " <> show optionName) - -paramToParamDecl :: Rzk.Param -> TypeCheck var [Rzk.ParamDecl] -paramToParamDecl (Rzk.ParamPatternShapeDeprecated loc pat cube tope) = pure - [ Rzk.ParamTermShape loc (patternToTerm pat) cube tope ] -paramToParamDecl (Rzk.ParamPatternShape loc pats cube tope) = pure - [ Rzk.ParamTermShape loc (patternToTerm pat) cube tope | pat <- pats] -paramToParamDecl (Rzk.ParamPatternType loc pats ty) = pure - [ Rzk.ParamTermType loc (patternToTerm pat) ty | pat <- pats ] -paramToParamDecl Rzk.ParamPattern{} = issueTypeError $ - TypeErrorOther "untyped pattern in parameters" -paramToParamDecl (Rzk.ParamPatternModalType loc pats mc ty) = pure - [ Rzk.ParamTermModalType loc (patternToTerm pat) mc ty | pat <- pats ] -paramToParamDecl (Rzk.ParamPatternModalShape loc pats mc cube tope) = pure - [ Rzk.ParamTermModalShape loc (patternToTerm pat) mc cube tope | pat <- pats ] - -addParamDecls :: [Rzk.ParamDecl] -> Rzk.Term -> Rzk.Term -addParamDecls [] = id -addParamDecls (paramDecl : paramDecls) - = Rzk.TypeFun Nothing paramDecl . addParamDecls paramDecls - -addParams :: [Rzk.Param] -> Rzk.Term -> Rzk.Term -addParams [] = id -addParams params = Rzk.Lambda Nothing params - -data TypeError var - = TypeErrorOther String - | TypeErrorUnify (TermT var) (TermT var) (TermT var) - | TypeErrorUnifyTerms (TermT var) (TermT var) - | TypeErrorNotPair (TermT var) (TermT var) - | TypeErrorNotModal (Term var) TModality (TermT var) - | TypeErrorModalityMismatch TModality TModality (Term var) - | TypeErrorUnaccessibleVar var TModality TModality - | TypeErrorNotTypeInModal (TermT var) - | TypeErrorNotFunction (TermT var) (TermT var) - | TypeErrorUnexpectedLambda (Term var) (TermT var) - | TypeErrorUnexpectedPair (Term var) (TermT var) - | TypeErrorUnexpectedRefl (Term var) (TermT var) - | TypeErrorCannotInferBareLambda (Term var) - | TypeErrorCannotInferBareRefl (Term var) - | TypeErrorCannotInferHole (Term var) - | TypeErrorUnsolvedHole (Maybe VarIdent) (TermT var) - | TypeErrorUndefined var - | TypeErrorTopeNotSatisfied [TermT var] (TermT var) - | TypeErrorTopeContextDisjoint (TermT var) [TermT var] - | TypeErrorTopesNotEquivalent (TermT var) (TermT var) - | TypeErrorInvalidArgumentType (Term var) (TermT var) - | TypeErrorDuplicateTopLevel [VarIdent] VarIdent - | TypeErrorUnusedVariable var (TermT var) - | TypeErrorUnusedUsedVariables [var] var - | TypeErrorImplicitAssumption (var, TermT var) var - deriving (Functor, Foldable) - -data TypeErrorInContext var = TypeErrorInContext - { typeErrorError :: TypeError var - , typeErrorContext :: Context var - } deriving (Functor, Foldable) - -data TypeErrorInScopedContext var - = PlainTypeError (TypeErrorInContext var) - | ScopedTypeError (Maybe VarIdent) (TypeErrorInScopedContext (Inc var)) - deriving (Functor, Foldable) - -type TypeError' = TypeError VarIdent - -ppModality :: TModality -> String -ppModality = \case - Flat -> "♭" - Sharp -> "♯" - Op -> "ᵒᵖ" - Id -> "_id" - --- | Render a type error, folding pattern-binder projections (e.g. @π₁ x@ back to --- the user's @t@) and showing a bare pattern point as the pattern, using the --- context's freshened binders (see 'contextBinders'). -ppTypeError' :: [(VarIdent, Binder)] -> TypeError' -> String -ppTypeError' fbs = \case - TypeErrorOther msg -> msg - TypeErrorUnify term expected actual -> block TopDown - [ "cannot unify expected type" - , " " <> ppU (untyped expected) - , "with actual type" - , " " <> ppU (untyped actual) - , "for term" - , " " <> ppU (untyped term) ] - TypeErrorUnifyTerms expected actual -> block TopDown - [ "cannot unify term" - , " " <> ppU (untyped expected) - , "with term" - , " " <> ppU (untyped actual) ] - TypeErrorNotPair term ty -> block TopDown - [ "expected a cube product or dependent pair" - , "but got type" - , " " <> ppU (untyped ty) - , "for term" - , " " <> ppU (untyped term) - , case ty of - TypeFunT{} -> "\nPerhaps the term is applied to too few arguments?" - _ -> "" - ] - TypeErrorNotModal term m ty -> block TopDown - [ "expected modal type " <> ppModality m <> " ?" - , "but got type" - , " " <> ppU (untyped ty) - , "for term" - , " " <> ppU term - ] - TypeErrorModalityMismatch expected actual term -> block TopDown - [ "modality mismatch" - , " expected " <> ppModality expected - , " but got " <> ppModality actual - , "for term" - , " " <> ppU term - ] - TypeErrorUnaccessibleVar _var varMod locks -> block TopDown - [ "unaccessible var with modality " <> ppModality varMod - , " under locks " <> ppModality locks - ] - TypeErrorNotTypeInModal ty -> block TopDown - [ "expected a type inside modal type" - , "but got" - , " " <> ppU (untyped ty) - ] - - TypeErrorUnexpectedLambda term ty -> block TopDown - [ "unexpected lambda abstraction" - , " " <> ppU term - , "when typechecking against a non-function type" - , " " <> ppTyped ty - ] - TypeErrorUnexpectedPair term ty -> block TopDown - [ "unexpected pair" - , " " <> ppU term - , "when typechecking against a type that is not a product or a dependent sum" - , " " <> ppTyped ty - ] - TypeErrorUnexpectedRefl term ty -> block TopDown - [ "unexpected refl" - , " " <> ppU term - , "when typechecking against a type that is not an identity type" - , " " <> ppTyped ty - ] - - TypeErrorNotFunction term ty -> block TopDown - [ "expected a function or extension type" - , "but got type" - , " " <> ppU (untyped ty) - , "for term" - , " " <> ppU (untyped term) - , case term of - AppT _ty f _x -> "\nPerhaps the term\n " <> ppU (untyped f) <> "\nis applied to too many arguments?" - _ -> "" - ] - TypeErrorCannotInferBareLambda term -> block TopDown - [ "cannot infer the type of the argument" - , "in lambda abstraction" - , " " <> ppU term - ] - TypeErrorCannotInferBareRefl term -> block TopDown - [ "cannot infer the type of term" - , " " <> ppU term - ] - TypeErrorCannotInferHole term -> block TopDown - [ "cannot infer the type of a hole" - , " " <> ppU term - , "a hole is only allowed where its type is already known (checking position)" - ] - TypeErrorUnsolvedHole mname goal -> block TopDown - [ "found an unsolved hole" <> maybe "" (\name -> " ?" <> show name) mname - , "expected type (goal):" - , " " <> ppU (untyped goal) - ] - TypeErrorUndefined var -> block TopDown - [ "undefined variable: " <> show (Pure var :: Term') ] - TypeErrorTopeNotSatisfied topes tope -> block TopDown - [ "local context is not included in (does not entail) the tope" - , " " <> ppU (untyped tope) - , "in local context (normalised)" - , intercalate "\n" (map (" " <>) (map ppTyped topes))] -- FIXME: remove - TypeErrorTopeContextDisjoint tope topes -> block TopDown - [ "the tope" - , " " <> ppU (untyped tope) - , "is disjoint from the local tope context (their conjunction is the empty tope ⊥)," - , "so this restriction face or recOR branch is vacuous everywhere" - , "in local context (normalised)" - , intercalate "\n" (map (" " <>) (map ppTyped topes))] - TypeErrorTopesNotEquivalent expected actual -> block TopDown - [ "expected tope" - , " " <> ppU (untyped expected) - , "but got" - , " " <> ppU (untyped actual) ] - - TypeErrorInvalidArgumentType argType argKind -> block TopDown - [ "invalid function parameter type" - , " " <> ppU argType - , "function parameter can be a cube, a shape, or a type" - , "but given parameter type has type" - , " " <> ppU (untyped argKind) - ] - - TypeErrorDuplicateTopLevel previous lastName -> block TopDown - [ "duplicate top-level definition" - , " " <> ppVarIdentWithLocation lastName - , "previous top-level definitions found at" - , intercalate "\n" - [ " " <> ppVarIdentWithLocation name - | name <- previous ] - ] - - TypeErrorUnusedVariable name type_ -> block TopDown - [ "unused variable" - , " " <> Rzk.printTree (getVarIdent name) <> " : " <> ppU (untyped type_) - ] - - TypeErrorUnusedUsedVariables vars name -> block TopDown - [ "unused variables" - , " " <> intercalate " " (map (Rzk.printTree . getVarIdent) vars) - , "declared as used in definition of" - , " " <> Rzk.printTree (getVarIdent name) - ] - - TypeErrorImplicitAssumption (a, aType) name -> block TopDown - [ "implicit assumption" - , " " <> Rzk.printTree (getVarIdent a) <> " : " <> ppU (untyped aType) - , "used in definition of" - , " " <> Rzk.printTree (getVarIdent name) - ] - where - ppU :: Term' -> String - ppU = ppFoldU fbs - ppTyped :: TermT' -> String - ppTyped = ppFoldT fbs - - --- | The pattern binders in scope, freshened and keyed by their (current) name, --- together with the projection-folding map derived from them. Both share the --- same freshened component names, so a term's projections and the binder shown --- in the context agree. -contextBinders - :: Context VarIdent - -> ([(VarIdent, Binder)], [(VarIdent, [([Proj], VarIdent)])]) -contextBinders ctx = (fbs, binderProjMap id fbs) - where - mapping = [ (v, v) | (v, _) <- varTypes ctx ] - fbs = freshBinders id mapping (varBinders ctx) - --- | Render an (untyped) term for an error or diagnostic message, given the --- context's freshened pattern binders: fold a pattern-binder variable's --- projections to their component names, then expand a bare use of the variable --- to the pattern itself (see 'foldBinderProjections' and 'restorePatternVars'). --- An empty binder list renders the term as-is. -ppFoldU :: [(VarIdent, Binder)] -> Term' -> String -ppFoldU fbs = - show . restorePatternVars fbs . foldBinderProjections (binderProjMap id fbs) - --- | Like 'ppFoldU' for a type-annotated term, shown as @term : type@ with the --- same folding and pattern restoration applied to both halves. -ppFoldT :: [(VarIdent, Binder)] -> TermT' -> String -ppFoldT fbs t0 = - case foldBinderProjectionsT (binderProjMap id fbs) t0 of - t@Pure{} -> r t - t@(Free (AnnF info _)) -> r t <> " : " <> r (infoType info) - where - r :: TermT' -> String - r = show . restorePatternVars fbs . untyped - -ppTypeErrorInContext :: OutputDirection -> TypeErrorInContext VarIdent -> String -ppTypeErrorInContext dir TypeErrorInContext{..} = block dir - [ ppTypeError' fbs typeErrorError - , "" - , ppContext' dir typeErrorContext - ] - where - (fbs, _) = contextBinders typeErrorContext - -ppTypeErrorInScopedContextWith' - :: OutputDirection - -> [VarIdent] - -> [VarIdent] - -> TypeErrorInScopedContext VarIdent - -> String -ppTypeErrorInScopedContextWith' dir used vars = \case - PlainTypeError err -> ppTypeErrorInContext dir err - ScopedTypeError orig err -> withFresh orig $ \(x, xs) -> - ppTypeErrorInScopedContextWith' dir (x:used) xs $ fmap (g x) err - where - g x Z = x - g _ (S y) = y - - withFresh Nothing f = - case vars of - x:xs -> f (x, xs) - _ -> panicImpossible "not enough fresh variables" - withFresh (Just z) f = f (z', filter (/= z') vars) -- FIXME: very inefficient filter - where - z' = refreshVar used z -- FIXME: inefficient - -ppTypeErrorInScopedContext' :: OutputDirection -> TypeErrorInScopedContext VarIdent -> String -ppTypeErrorInScopedContext' dir err = - ppTypeErrorInScopedContextWith' dir vars (defaultVarIdents \\ vars) err - where - vars = nub (foldMap pure err) - -issueWarning :: String -> TypeCheck var () -issueWarning message = do - trace ("Warning: " <> message) $ - return () - -fromTypeError :: TypeError var -> TypeCheck var (TypeErrorInScopedContext var) -fromTypeError err = do - context <- ask - return $ PlainTypeError $ TypeErrorInContext - { typeErrorError = err - , typeErrorContext = context - } - -issueTypeError :: TypeError var -> TypeCheck var a -issueTypeError err = fromTypeError err >>= throwError - -panicImpossible :: String -> a -panicImpossible msg = error $ unlines - [ "PANIC! Impossible happened (" <> msg <> ")!" - , "Please, report a bug at https://github.com/rzk-lang/rzk/issues" - -- TODO: add details and/or instructions how to produce an artifact for reproducing - ] - -data Action var - = ActionTypeCheck (Term var) (TermT var) - | ActionUnify (TermT var) (TermT var) (TermT var) - | ActionUnifyTerms (TermT var) (TermT var) - | ActionInfer (Term var) - | ActionContextEntailedBy [TermT var] (TermT var) - | ActionContextEntails [TermT var] (TermT var) - | ActionContextEntailsUnion [TermT var] [TermT var] - | ActionWHNF (TermT var) - | ActionNF (TermT var) - | ActionCheckCoherence (TermT var, TermT var) (TermT var, TermT var) - | ActionCloseSection (Maybe Rzk.SectionName) - | ActionCheckLetValue (Maybe VarIdent) - deriving (Functor, Foldable) - -type Action' = Action VarIdent - --- | Freshen the compound (pattern) binders in scope so their component names --- avoid the display names already in use and one another. Returns each relevant --- variable paired with its freshened binder. Variables bound to a single name --- are omitted: they need no projection folding and are displayed normally. -freshBinders - :: Eq var - => (var -> VarIdent) - -> [(var, VarIdent)] - -> [(var, Binder)] - -> [(var, Binder)] -freshBinders name mapping binders = go (map (name . fst) mapping) compound - where - compound = [ (v, b) | (v, b) <- binders, binderIsCompound b, v `elem` map fst mapping ] - go _ [] = [] - go used ((v, b) : rest) = - let b' = freshenBinderLeaves used b - in (v, b') : go (binderLeaves b' ++ used) rest - --- | The projection-folding map for rendering: each pattern-binder variable's --- display name mapped to the projection paths of its component names (e.g. --- @π₁@ ↦ @t@, @π₂@ ↦ @s@). Ordinary projections (of non-pattern variables) are --- left untouched. -binderProjMap :: (var -> VarIdent) -> [(var, Binder)] -> [(VarIdent, [([Proj], VarIdent)])] -binderProjMap name fbs = [ (name v, binderPaths b) | (v, b) <- fbs ] - -ppTermInContext :: Eq var => TermT var -> TypeCheck var String -ppTermInContext term = do - vars <- freeVarsT_ term - let mapping = zip vars defaultVarIdents - toRzkVarIdent origs var = fromMaybe "_" $ - join (lookup var origs) <|> lookup var mapping - origs <- asks varOrigs - binders <- asks varBinders - let name = toRzkVarIdent origs - fbs = freshBinders name mapping binders - return (show (restorePatternVars [ (name v, b) | (v, b) <- fbs ] - (foldBinderProjections (binderProjMap name fbs) - (untyped (name <$> term))))) - --- | Classify a (WHNF) type as a cube, so cube variables (e.g. @t : 2@) are --- shown separately from ordinary term variables in a hole's context. -isCubeType :: TermT var -> Bool -isCubeType = \case - CubeUnitT{} -> True - Cube2T{} -> True - CubeIT{} -> True - CubeProductT{} -> True - UniverseCubeT{} -> True - _ -> False - --- | Is a (WHNF) goal type in the cube or tope layer, so a hole of this type is a --- cube point or a tope rather than a term? Used to suppress type-layer-specific --- hole candidates (@recOR@, @recBOT@), which cannot inhabit a cube or a tope. -isCubeOrTopeType :: TermT var -> Bool -isCubeOrTopeType t = isCubeType t || case t of - UniverseTopeT{} -> True - _ -> False - --- | Is this term a hole? Holes only exist in lenient mode (see 'allowHoles'); --- they are opaque placeholders standing for a term of the expected type. -isHoleT :: TermT var -> Bool -isHoleT HoleT{} = True -isHoleT _ = False - --- | Does this term contain a hole anywhere (including nested, e.g. @f ?@)? --- Used to keep unification lenient around incomplete terms: a term with an --- unfilled hole cannot be meaningfully compared, so a unification that would --- otherwise fail is deferred. Evaluated only on the failure path. -containsHole :: TermT var -> Bool -containsHole = \case - HoleT{} -> True - Pure{} -> False - Free (AnnF _ termf) -> bifoldr ((||) . containsHole) ((||) . containsHole) False termf - --- | All ways to eliminate a hypothesis into a value usable at a goal. Given a --- @target@ type and a hypothesis /term/ (e.g. @Pure v@ for a context variable), --- return every elimination spine over that term whose type fits the target (or --- a subtype of it). Arguments introduced by application are left as holes for --- the caller to fill later. A value that already fits is returned as-is; a --- function is applied to holes; a Σ-type (or anything that unfolds to one, e.g. --- @is-contr@) is projected, possibly repeatedly — so e.g. --- @first (first (is-segal-A ? ? ? ? ?))@ is discovered. --- --- The search is driven uniformly by the eliminators a (weak head normal) type --- admits (see 'eliminatorsOf'), so adding a new eliminator extends it without --- touching the search. --- --- A Π-application is a forced spine step — there is exactly one way to fill an --- argument (with a hole) — so it extends the spine for free and does not spend --- the budget. Only the genuinely branching eliminators (Σ/cube projections and --- @idJ@, flagged by 'eliminatorsOf') count against 'maxEliminationDepth'. The --- bound therefore limits real search depth, not argument count, so a lemma that --- must be applied to many holes is still reached. The free spine terminates --- because each application strips one Π binder off a finite type. -allEliminationsInto - :: Eq var => TermT var -> TermT var -> TypeCheck var [TermT var] -allEliminationsInto target = go maxEliminationDepth - where - go depth term = do - ty <- typeOf term - fits <- fitsInto term ty target - elims <- eliminatorsOf ty - let step (SpineStep, wrap) = go depth (wrap term) - step (Branching, wrap) - | depth <= 0 = pure [] - | otherwise = go (depth - 1) (wrap term) - deeper <- concat <$> mapM step elims - pure ([term | fits] <> deeper) - --- | How many /branching/ eliminators 'allEliminationsInto' will chain. Forced --- Π-applications are free (see 'allEliminationsInto'), so this bounds only the --- Σ/cube projections and @idJ@ steps, not the argument count of a spine. A --- temporary fixed bound: branching is shallow in the goals seen so far (a few --- projections), and a larger bound mostly adds self-referential spines (a built --- result eliminated again). It should be made configurable once there is more --- evidence of what real goals need. -maxEliminationDepth :: Int -maxEliminationDepth = 7 - --- | Whether a term of the given (whnf) type may stand where a value of the --- @target@ type is expected: the two types unify under 'structuralHoleUnify', --- so a hole acts as a wildcard leaf but a structural mismatch around it is still --- a mismatch (an under-applied function does not match an extension-type goal, --- but a partial application that genuinely fits an ordinary-function goal does). --- --- Outer type restrictions are stripped from both sides first: an extension-type --- boundary is satisfied by later refinement, not by the choice of spine, and --- matching against the restricted goal would reject the very spine that --- introduces the holes meant to satisfy it (e.g. @f ?@ at a boundary goal). --- --- Holes or constraints recorded while probing are discarded, so this is a pure --- yes/no query. -fitsInto :: Eq var => TermT var -> TermT var -> TermT var -> TypeCheck var Bool -fitsInto term ty target = do - ty' <- stripTypeRestrictions <$> whnfT ty - target' <- stripTypeRestrictions <$> whnfT target - censor (const []) $ local structuralHoleUnify - ((unify (Just term) target' ty' >> pure True) `catchError` \_ -> pure False) - --- | Whether eliminating a value spends the search budget. A forced --- Π-application is a 'SpineStep' — there is one way to fill the argument (with a --- hole), so 'allEliminationsInto' applies it for free; a 'Branching' eliminator --- (a Σ/cube projection or @idJ@) costs one against 'maxEliminationDepth'. -data ElimCost = SpineStep | Branching - deriving (Eq, Show) - --- | The eliminators a value of the given (weak head normal) type admits, each --- as a function wrapping the eliminated term, paired with its 'ElimCost'. A --- Π-type is eliminated by application to a fresh hole (a spine step); a Σ-type --- by either projection; an identity type by path induction (@idJ@), with the --- motive and base case left as holes. The projections and @idJ@ branch. --- Anything else admits no simple eliminator. -eliminatorsOf :: Eq var => TermT var -> TypeCheck var [(ElimCost, TermT var -> TermT var)] -eliminatorsOf ty = - case stripTypeRestrictions ty of - TypeFunT _ty _orig _md param _mtope ret -> - pure [ (SpineStep, \term -> let h = mkHole param in appT (substituteT h ret) term h) ] - TypeSigmaT _ty _orig _md a b -> - pure [ (Branching, \term -> firstT a term) - , (Branching, \term -> secondT (substituteT (firstT a term) b) term) ] - -- A cube point pair (e.g. a pattern-bound @(t , s) : 2 × 2@) projects to its - -- coordinates; rzk renders those projections back as the pattern names. - CubeProductT _ty a b -> - pure [ (Branching, \term -> firstT a term) - , (Branching, \term -> secondT b term) ] - -- A path @p : a =_A x@ is eliminated by path induction. The motive - -- @C : (z : A) → (a =_A z) → U@ is always a function, so we introduce it - -- straight away as @\\ b q → ?@ rather than leaving it a bare hole: the spine - -- @idJ A a (\\ b q → ?) ? x p@ then has type @C x p@, which β-reduces to that - -- inner hole — so J fits any goal (the player fills the motive and the base - -- case @d : C a refl@). The two holes are the motive predicate and the base. - TypeIdT _ty a mtA x -> do - tA <- maybe (typeOf a) pure mtA - let -- the motive predicate body, a type, under the two motive binders - cBody = mkHole universeT - cInner = lambdaT (typeFunT (BinderVar Nothing) Id - (typeIdT (S <$> a) (Just (S <$> tA)) (Pure Z)) Nothing universeT) - (BinderVar (Just (fromString "q"))) Nothing cBody - cType = typeFunT (BinderVar Nothing) Id tA Nothing $ - typeFunT (BinderVar Nothing) Id - (typeIdT (S <$> a) (Just (S <$> tA)) (Pure Z)) Nothing universeT - c = lambdaT cType (BinderVar (Just (fromString "b"))) Nothing cInner - dType = appT universeT - (appT (typeFunT (BinderVar Nothing) Id (typeIdT a (Just tA) a) Nothing universeT) c a) - (reflT (typeIdT a (Just tA) a) Nothing) - d = mkHole dType - motiveAt y p = appT universeT - (appT (typeFunT (BinderVar Nothing) Id (typeIdT a (Just tA) y) Nothing universeT) c y) p - pure [ (Branching, \p -> idJT (motiveAt x p) tA a c d x p) ] - _ -> pure [] - where - mkHole t = HoleT TypeInfo{ infoType = t, infoWHNF = Nothing, infoNF = Nothing } Nothing - --- | The binder for a λ introduced over a domain type. A binder the type already --- gives as a pattern is kept as-is — it carries the user's own names (e.g. --- @(t , s)@). Otherwise an /explicit/ (pre-whnf) Σ-type or product domain is --- destructured into a fresh pair pattern, recursively for products, so that a --- nameless @2 × 2 × 2@ parameter is introduced as @((t1 , t2) , t3)@ rather than --- a single opaque variable. Any other domain keeps its single binder. --- --- Leaves are named by what they range over: a cube-product component is a point, --- named @t@/@s@-style as @tN@; a Σ component is a term, named @xN@. The names are --- display-only (the body is a hole that does not mention them) and carry a --- shared running index, so every leaf in the pattern is distinct. -destructuringBinder :: Binder -> TermT var -> Binder -destructuringBinder orig param = case orig of - BinderPair{} -> orig -- already a pattern: keep the user's names - _ -> case param of - CubeProductT{} -> fst (go 1 param) - TypeSigmaT{} -> fst (go 1 param) - _ -> orig -- not a product/Σ: leave the binder alone - where - -- a product/Σ becomes a pair; we recurse into a product's components (plain - -- types) but not under a Σ's binder (a scope). A leaf is named by its - -- enclosing constructor: @tN@ under a cube product, @xN@ under a Σ. - go n = \case - CubeProductT _ a b -> - let (l, n') = child "t" n a - (r, n'') = child "t" n' b - in (BinderPair l r, n'') - TypeSigmaT _ _ _md a _b -> - let (l, n') = child "x" n a - in (BinderPair l (BinderVar (Just (leaf "x" n'))), n' + 1) - _ -> (BinderVar (Just (leaf "t" n)), n + 1) -- unreached: go is called on products only - child pfx n = \case - c@CubeProductT{} -> go n c - c@TypeSigmaT{} -> go n c - _ -> (BinderVar (Just (leaf pfx n)), n + 1) - leaf pfx n = fromString (pfx <> show n :: String) - --- | All ways to introduce a value /of/ a goal type by its head constructor, --- leaving the constituents as holes. Given a @target@ type, return its --- introduction forms: --- --- * a Π-type is introduced by a λ-abstraction over a hole body (@\\ x -> ?@); --- the binder is taken from the type, so a pattern domain (e.g. a @Δ²@ point --- @(t , s)@) is introduced as @\\ (t , s) -> ?@; --- * a Σ-type or a cube product by a pair of holes (@(? , ?)@); --- * an identity type by @refl@, but only when its two endpoints already agree --- (otherwise @refl@ would not typecheck); --- * the unit type by @unit@; --- * the tope universe by each tope constructor — @TOP@, @BOT@, @? ≡ ?@, --- @? ≤ ?@, @? ∧ ?@, @? ∨ ?@ — so a shape (a hole of type @TOPE@) can be --- built up by tapping. --- --- Any other type admits no simple introduction. Unlike 'allEliminationsInto' --- this does not search: a type has at most one introduction form (the tope --- universe is the one exception), read off its (weak head normal) head --- constructor. Outer type restrictions are stripped first, so an extension type --- is introduced by the form of its underlying type (its boundary is met by later --- refinement of the holes, not by the choice of constructor). --- --- The λ binder of a Π-introduction is freshened against @inScope@ (the names --- already visible at the hole), so introducing over a type whose own definition --- reuses an in-scope name (e.g. @hom@, whose internal binder is @t@) yields --- @\\ t₁ -> ?@ rather than a @t@ that shadows the existing one. -allIntroductionsOf :: Eq var => TermT var -> [VarIdent] -> TypeCheck var [TermT var] -allIntroductionsOf target inScope = do - target' <- stripTypeRestrictions <$> whnfT target - case target' of - TypeFunT _ty orig _md param _mtope ret -> - let binder = freshenBinderLeaves inScope (destructuringBinder orig param) - in pure [ lambdaT target' binder Nothing (mkHole ret) ] - TypeSigmaT _ty _orig _md a b -> - let h = mkHole a in pure [ pairT target' h (mkHole (substituteT h b)) ] - CubeProductT _ty a b -> - pure [ pairT target' (mkHole a) (mkHole b) ] - TypeIdT _ty a _tA b -> do - agree <- endpointsAgree a b - pure [ reflT target' Nothing | agree ] - TypeUnitT{} -> pure [ unitT ] - -- the tope universe: every tope constructor builds a tope, so all are - -- introductions of a shape goal. Point arguments (of ≡, ≤) and tope - -- arguments (of ∧, ∨) are left as holes. - UniverseTopeT{} -> - let point = mkHole (mkHole cubeT) -- a point of an as-yet-unknown cube - tope = mkHole target' -- a tope (its type is the tope universe) - in pure [ topeTopT, topeBottomT - , topeEQT point point, topeLEQT point point - , topeAndT tope tope, topeOrT tope tope ] - _ -> pure [] - where - mkHole t = HoleT TypeInfo{ infoType = t, infoWHNF = Nothing, infoNF = Nothing } Nothing - --- | Whether the two endpoints of an identity type are definitionally equal, so --- that @refl@ inhabits it. Like 'fitsInto', any holes or constraints recorded --- while probing are discarded, leaving a pure yes\/no query. -endpointsAgree :: Eq var => TermT var -> TermT var -> TypeCheck var Bool -endpointsAgree a b = - censor (const []) - ((unify Nothing a b >> pure True) `catchError` \_ -> pure False) - --- | Whether the local tope context is contradictory (entails ⊥). Reads the --- precomputed flag when present, falling back to an entailment check. Used to --- decide whether @recBOT@ (ex falso) is available. -contextEntailsBottom :: Eq var => TypeCheck var Bool -contextEntailsBottom = asks localTopesEntailBottom >>= \case - Just b -> return b - Nothing -> entailContextM topeBottomT - --- | Ex falso: in a contradictory tope context @recBOT@ inhabits any type, so it --- is a candidate for every goal there (and only there — elsewhere it would not --- typecheck). Independent of the goal and of the local hypotheses. -recBottomCandidates :: Eq var => TypeCheck var [TermT var] -recBottomCandidates = do - vacuous <- contextEntailsBottom - pure [ recBottomT | vacuous ] - --- | Whether the local tope context is covered by the union of the given topes — --- the coverage obligation of @recOR@ (see 'contextEntailsUnion'), but as a pure --- yes\/no query rather than a check that issues an error. -coverageHolds :: Eq var => [TermT var] -> TypeCheck var Bool -coverageHolds topes = do - topesNF <- mapM nfTope topes - entailContextM (foldr topeOrT topeBottomT topesNF) - --- | Tope case-split moves: ways to build a value of the goal by @recOR@, --- splitting the proof over a cover of the local tope context. Three sources, --- offered together (the UI ranks and filters): --- --- * each disjunction @ψ ∨ φ@ already in the context becomes --- @recOR(ψ ↦ ?, φ ↦ ?)@ — its cover is immediate; --- * when the goal is an extension type, its restriction faces are a cover --- candidate @recOR(ψ₁ ↦ ?, …)@, offered only when they actually cover the --- context (so the move typechecks); --- * a generic two-way split @recOR(? ↦ ?, ? ↦ ?)@ with the guards left as --- holes, for an unusual split the player fills in by hand. --- --- All three are offered only in a setting where a split makes sense — a cube --- variable is in scope, the context has a non-trivial tope, or the goal is a --- restricted type — so an ordinary (tope-free) goal is left alone. -recOrCandidates :: Eq var => TermT var -> TypeCheck var [TermT var] -recOrCandidates goal = do - goalW <- whnfT goal - topes <- asks (filter (/= topeTopT) . availableTopes) - locals <- asks (filter (not . varIsTopLevel . snd) . varInfos) - hasCube <- or <$> mapM (fmap isCubeType . whnfT . varType . snd) locals - let stripped = stripTypeRestrictions goalW - mkRecOr gs = recOrT stripped [ (g, mkHole stripped) | g <- gs ] - fromContext = [ mkRecOr [l, r] | TopeOrT _ l r <- topes ] - faces = case goalW of - TypeRestrictedT _ _ rs -> map fst rs - _ -> [] - isRestricted = case goalW of TypeRestrictedT{} -> True; _ -> False - inShape = hasCube || not (null topes) || isRestricted - generic = [ recOrT stripped [ (mkHole topeT, mkHole stripped) - , (mkHole topeT, mkHole stripped) ] - | inShape ] - fromFaces <- if length faces >= 2 - then do covered <- coverageHolds faces - pure [ mkRecOr faces | covered ] - else pure [] - pure (fromContext <> fromFaces <> generic) - where - mkHole t = HoleT TypeInfo{ infoType = t, infoWHNF = Nothing, infoNF = Nothing } Nothing - --- | Record the goal and local context at a hole (lenient mode only). The goal, --- the local hypotheses, and the tope assumptions are all rendered to --- user-facing 'VarIdent' names here — reusing the same resolution as --- 'ppTermInContext' — so the resulting 'HoleInfo' is independent of the De --- Bruijn scope. The global environment is deliberately excluded (only --- @varIsTopLevel == False@ locals are kept), and locals are split into cube --- variables and ordinary term variables. -recordHole :: Eq var => Maybe VarIdent -> TermT var -> TypeCheck var () -recordHole mname goalTy = recordHoleShape mname goalTy Nothing - --- | Record a hole. When the hole is the argument of a shape-restricted function --- its goal is a /shape/: the cube @goalTy@ together with a membership tope. The --- tope is a scope over the shape's bound variable (the third argument carries --- the declared binder name, if any, and the tope); it is rendered under that --- binder so the goal reads @(binder : goalTy | tope)@. -recordHoleShape - :: Eq var - => Maybe VarIdent - -> TermT var - -> Maybe (Binder, TermT (Inc var)) - -> TypeCheck var () -recordHoleShape mname goalTy mshape = do - goal' <- whnfT goalTy - locals <- asks (filter (not . varIsTopLevel . snd) . varInfos) - -- named top-level lemmas the caller allow-listed for hints (see 'hintLemmas'). - -- They feed the candidate-elimination loop only — not the local context shown - -- to the user, since they are global definitions, not local hypotheses. - lemmas <- asks hintLemmas - lemmaVars <- asks (filter (\(_, i) -> varIsTopLevel i && maybe False (`elem` lemmas) (binderName (varOrig i))) . varInfos) - cubeFlags <- mapM (fmap isCubeType . whnfT . varType . snd) locals - topes <- asks (filter (/= topeTopT) . availableTopes) - origs <- asks varOrigs - binders <- asks varBinders - loc <- asks location - -- for each local hypothesis (and allow-listed lemma), the elimination spines - -- that land in the goal (arguments left as holes). Probing must not leak holes - -- into the recorded output, hence 'censor'. - candidates <- censor (const []) $ do - elims <- concat <$> mapM (\(v, _) -> allEliminationsInto goalTy (Pure v)) (locals ++ lemmaVars) - -- context-driven moves (independent of the goal's head and the hypotheses): - -- ex falso in a contradictory context, and tope case-splits. recOR and recBOT - -- are term-level eliminators, so they are offered only for a term goal — not - -- when the hole is a cube point or a tope, where they cannot appear. - let termLayer = not (isCubeOrTopeType goal') - recbot <- if termLayer then recBottomCandidates else pure [] - recor <- if termLayer then recOrCandidates goalTy else pure [] - pure (elims <> recbot <> recor) - let shapeTope = snd <$> mshape - shapeTopeVars = maybe [] (\t -> [ v | S v <- foldr (:) [] t ]) shapeTope - varsList <- concat <$> mapM freeVarsT_ (goal' : map (varType . snd) (locals ++ lemmaVars) ++ topes) - let mapping = zip (nub (varsList ++ shapeTopeVars ++ map fst (locals ++ lemmaVars))) defaultVarIdents - name v = fromMaybe "_" (join (lookup v origs) <|> lookup v mapping) - fbs = freshBinders name mapping binders - render t = restorePatternVars [ (name v, b) | (v, b) <- fbs ] - (foldBinderProjections (binderProjMap name fbs) (untyped (name <$> t))) - -- a pattern binder is shown as its pattern, e.g. (t , s); others by name - entryName v = maybe (name v) binderDisplayName (lookup v fbs) - entries = [ HoleEntry (entryName v) (render (varType info)) | (v, info) <- locals ] - flagged = zip cubeFlags entries - -- binder name for the shape: the declared name if any, else a default - shapeBinder = fromMaybe (fromString "t") (binderName =<< (fst <$> mshape)) - nameInc Z = shapeBinder - nameInc (S v) = name v - goalShape = (\t -> (shapeBinder, untyped (nameInc <$> t))) <$> shapeTope - -- names already visible at the hole, which an introduced binder must not - -- shadow: each local hypothesis by its display name, or the leaves of a - -- pattern hypothesis. - inScopeNames = [ nm | (v, _) <- locals - , nm <- maybe [name v] binderLeaves (lookup v fbs) ] - -- the introduction forms for the goal itself (constituents left as holes); the - -- Π binder is freshened against 'inScopeNames' so it does not shadow. - introductions <- censor (const []) (allIntroductionsOf goalTy inScopeNames) - -- the goal cell: an SVG of the shape the hole must inhabit (an arrow, triangle - -- or square), drawn from an abstract inhabitant with the proof term hidden. - -- 'Nothing' when the goal is not a renderable shape. - diagram <- censor (const []) (renderGoalCellSVG goal') - lift $ tell - [ HoleInfo - { holeName = mname - , holeGoal = render goal' - , holeGoalShape = goalShape - , holeTermVars = [ e | (False, e) <- flagged ] - , holeCubeVars = [ e | (True, e) <- flagged ] - , holeTopes = map render topes - , holeCandidates = map render candidates - , holeIntroductions = map render introductions - , holeDiagram = diagram - , holeLocation = loc - } ] - --- | Check a hole that appears as the argument of a shape-restricted function, --- whose domain is the cube @cube@ restricted by @tope@ (a scope over the --- domain's bound variable). Mirrors the hole case of 'typecheck', but records --- the shape as the hole's goal so the diagnostic shows @(binder : cube | tope)@. -checkHoleAgainstShape - :: Eq var - => Maybe VarIdent -> Binder -> TermT var -> TermT (Inc var) - -> TypeCheck var (TermT var) -checkHoleAgainstShape mname orig cube tope = do - reject <- asks holesAreErrors - if reject - then issueTypeError (TypeErrorUnsolvedHole mname cube) - else do - recordHoleShape mname cube (Just (orig, tope)) - return (HoleT TypeInfo{ infoType = cube, infoWHNF = Nothing, infoNF = Nothing } mname) - -ppSomeAction :: Eq var => [(var, Maybe VarIdent)] -> Int -> Action var -> String -ppSomeAction origs n action = ppAction [] n (toRzkVarIdent <$> action) - where - vars = nub (foldMap pure action) - mapping = zip vars defaultVarIdents - toRzkVarIdent var = fromMaybe "_" $ - join (lookup var origs) <|> lookup var mapping - -ppAction :: [(VarIdent, Binder)] -> Int -> Action' -> String -ppAction fbs n = unlines . map (replicate (2 * n) ' ' <>) . \case - ActionTypeCheck term ty -> - [ "typechecking" - , " " <> ppU term - , "against type" - , " " <> ppU (untyped ty) ] - - ActionUnify term expected actual -> - [ "unifying expected type" - , " " <> ppU (untyped expected) - , "with actual type" - , " " <> ppU (untyped actual) - , "for term" - , " " <> ppU (untyped term) ] - - ActionUnifyTerms expected actual -> - [ "unifying term (expected)" - , " " <> ppTyped expected - , "with term (actual)" - , " " <> ppTyped actual ] - - ActionInfer term -> - [ "inferring type for term" - , " " <> ppU term ] - - ActionContextEntailedBy ctxTopes term -> - [ "checking if local context" - , intercalate "\n" (map ((" " <>) . ppU . untyped) ctxTopes) - , "includes (is entailed by) restriction tope" - , " " <> ppU (untyped term) ] - - ActionContextEntails ctxTopes term -> - [ "checking if local context" - , intercalate "\n" (map ((" " <>) . ppU . untyped) ctxTopes) - , "is included in (entails) the tope" - , " " <> ppU (untyped term) ] - - ActionContextEntailsUnion ctxTopes terms -> - [ "checking if local context" - , intercalate "\n" (map ((" " <>) . ppU . untyped) ctxTopes) - , "is included in (entails) the union of the topes" - , intercalate "\n" (map ((" " <>) . ppU . untyped) terms) ] - - ActionWHNF term -> - [ "computing WHNF for term" - , " " <> ppTyped term ] - - ActionNF term -> - [ "computing normal form for term" - , " " <> ppU (untyped term) ] - - ActionCheckCoherence (ltope, lterm) (rtope, rterm) -> - [ "checking coherence for" - , " " <> ppU (untyped ltope) - , " |-> " <> ppU (untyped lterm) - , "and" - , " " <> ppU (untyped rtope) - , " |-> " <> ppU (untyped rterm) ] - - ActionCloseSection Nothing -> - [ "closing the file" - , "and collecting assumptions (variables)" ] - ActionCloseSection (Just sectionName) -> - [ "closing #section " <> Rzk.printTree sectionName - , "and collecting assumptions (variables)"] - - ActionCheckLetValue orig -> - [ "checking the local definition " - <> maybe "_" (Rzk.printTree . getVarIdent) orig ] - where - ppU :: Term' -> String - ppU = ppFoldU fbs - ppTyped :: TermT' -> String - ppTyped = ppFoldT fbs - - -traceAction' :: Int -> Action' -> a -> a -traceAction' n action = trace ("[debug]\n" <> ppAction [] n action) - -unsafeTraceAction' :: Int -> Action var -> a -> a -unsafeTraceAction' n = traceAction' n . unsafeCoerce - -data LocationInfo = LocationInfo - { locationFilePath :: Maybe FilePath - , locationLine :: Maybe Int - } deriving (Eq, Show) - -data Verbosity - = Debug - | Normal - | Silent - deriving (Eq, Ord) - -trace' :: Verbosity -> Verbosity -> String -> a -> a -trace' msgLevel currentLevel - | currentLevel <= msgLevel = trace - | otherwise = const id - -traceTypeCheck :: Verbosity -> String -> TypeCheck var a -> TypeCheck var a -traceTypeCheck msgLevel msg tc = do - Context{..} <- ask - trace' msgLevel verbosity msg tc - -localVerbosity :: Verbosity -> TypeCheck var a -> TypeCheck var a -localVerbosity v = local $ \Context{..} -> Context { verbosity = v, .. } - -localRenderBackend :: Maybe RenderBackend -> TypeCheck var a -> TypeCheck var a -localRenderBackend v = local $ \Context{..} -> Context { renderBackend = v, .. } - --- | Run the enclosed action with the 'renderHideTerm' policy set. -localHideTerm :: Bool -> TypeCheck var a -> TypeCheck var a -localHideTerm v = local $ \ctx -> ctx { renderHideTerm = v } - --- | Render the enclosed action with the proof term hidden (see 'renderHideTerm'). -hidingTerm :: TypeCheck var a -> TypeCheck var a -hidingTerm = localHideTerm True - -data Covariance - = Covariant -- ^ Positive position. - | Contravariant -- ^ Negative position. - | Invariant -- ^ Unknown position. - -data RenderBackend - = RenderSVG - | RenderLaTeX - -data ScopeInfo var = ScopeInfo - { scopeName :: Maybe Rzk.SectionName - , scopeVars :: [(var, VarInfo var)] - } deriving (Functor, Foldable) - --- | A scope of top-level entries (definitions, postulates, section --- assumptions). The payload is pinned at 'VarIdent': shifting the context --- under a binder ('enterScopeContext') maps only the keys and never --- traverses the elaborated terms, which is what made @S <$>@ on the whole --- context account for most of the checker's allocation and residency. --- A payload is embedded into the current scope on lookup via 'globalEmbed'. -data GlobalScopeInfo var = GlobalScopeInfo - { gscopeName :: Maybe Rzk.SectionName - , gscopeVars :: [(var, VarInfo VarIdent)] - } deriving (Functor, Foldable) - -addVarToScope :: var -> VarInfo var -> ScopeInfo var -> ScopeInfo var -addVarToScope var info ScopeInfo{..} = ScopeInfo - { scopeVars = (var, info) : scopeVars, .. } - -addModalityToScope :: TModality -> ScopeInfo var -> ScopeInfo var -addModalityToScope md ScopeInfo{..} = ScopeInfo - { scopeVars = map (\(var, VarInfo{..}) -> (var, VarInfo{ modAccum = comp modAccum md, ..})) scopeVars, .. } - -data VarInfo var = VarInfo - { varType :: TermT var - , varValue :: Maybe (TermT var) - , varModality :: TModality - , modAccum :: TModality - , varOrig :: Binder - , varIsAssumption :: Bool -- FIXME: perhaps, introduce something like decl kind? - , varIsTopLevel :: Bool - , varDeclaredAssumptions :: [var] - , varLocation :: Maybe LocationInfo - } deriving (Functor, Foldable) - - -class ModeTheory m where - iden :: m - comp :: m -> m -> m - coe :: m -> m -> Bool - isRA :: m -> Bool - -instance ModeTheory TModality where - iden = Id - - comp Flat Flat = Flat - comp Flat Sharp = Flat - comp Flat Op = Flat - comp Op Flat = Flat - comp Sharp Sharp = Sharp - comp Sharp Flat = Sharp - comp Sharp Op = Sharp - comp Op Sharp = Sharp - comp Op Op = Id - comp Id m = m - comp m Id = m - - coe Flat Id = True - coe Flat Op = True - coe Id Sharp = True - coe Flat Sharp = True - coe Op Sharp = True - coe a b = a == b - - isRA Sharp = True - isRA Op = True - isRA Id = True - isRA _ = False - -data ModalTope var = ModalTope - { tModAccum :: TModality - , tModVar :: TModality - , tTope :: TermT var - } deriving (Functor, Foldable, Eq) - --- | The state of the tope-saturation cache in a 'Context' --- (see 'localTopesSaturated' and 'withRefreshedTopes'). -data CachedSaturation var - = SaturationUncached - -- ^ No cache was installed for this tope context ('entailContextM' - -- falls back to the per-query pipeline). - | SaturationCached (Maybe [[ModalTope var]]) - -- ^ A deferred pipeline run: forced by the first query under this - -- context. 'Nothing' records that the pipeline errored; queries then - -- fall back, so the error surfaces exactly where it would have. - deriving (Functor) - --- Deliberately empty: the cache's variables duplicate those of --- 'localTopesNF', and folding a 'Context' (e.g. collecting names when --- printing a scoped error) must not force the deferred pipeline. -instance Foldable CachedSaturation where - foldMap _ _ = mempty - -data Context var = Context - { localScopes :: [ScopeInfo var] - -- ^ Binder scopes: variables bound while checking the current - -- declaration. Top-level entries live in 'globalScopes'. - , globalScopes :: [GlobalScopeInfo var] - -- ^ Top-level definitions, postulates and section assumptions, with - -- their payloads pinned at 'VarIdent' (see 'GlobalScopeInfo'). - , globalEmbed :: VarIdent -> var - -- ^ The composed injection of top-level names into the current scope - -- (extended by @S .@ at each binder entry; the derived 'Functor' - -- composes it on 'fmap'). Embeds a global payload on lookup. - , localDiscreteTopes :: [ModalTope var] - -- ^ Discreteness axioms for the flat cube variables in scope (a flat - -- point of @2@ or @I@ is an endpoint). Maintained incrementally at - -- binder entry (see 'enterScopeMaybe'), so 'entailM' does not rescan - -- the whole context on every entailment query. A variable's modality - -- is fixed at binding time ('addModalityToScope' only touches - -- 'modAccum'), so entries never need to be revised. - , localTopes :: [ModalTope var] - , localTopesNF :: [ModalTope var] - , localTopesNFUnion :: [[ModalTope var]] - , localTopesEntailBottom :: Maybe Bool - , localTopesSaturated :: CachedSaturation var - -- ^ The saturated alternatives for the context's own tope context - -- ('localTopesNF' plus the discreteness axioms): exactly the - -- preprocessing 'entailM' runs per query, cached at the points where - -- the tope context changes ('localTope', 'enterModality', - -- 'inAllSubContexts', a flat cube binder) via 'withRefreshedTopes'. - -- Ordinary binder entries shift the cached value with the rest of the - -- context, which is sound because saturation commutes with renaming. - , actionStack :: [Action var] - , currentCommand :: Maybe Rzk.Command - , location :: Maybe LocationInfo - , verbosity :: Verbosity - , covariance :: Covariance - , renderBackend :: Maybe RenderBackend - -- | When rendering a diagram, hide the proof term: drop the @\@ - -- (which carries the full term) from every cell and blank the visible label - -- of proof-coloured (interior) cells, keeping the given boundary labels. So - -- a worked term or an abstract inhabitant of a goal type is shown as the - -- shape with its given edges, not the term that fills it. - , renderHideTerm :: Bool - , holesAreErrors :: Bool - -- ^ When 'True' (the default), an unfilled hole is reported as a - -- 'TypeErrorUnsolvedHole'; finished work (and CI) must have no holes. The - -- lenient mode ('allowHoles') instead records each hole's goal and context. - , deferHoleMismatches :: Bool - -- ^ How holes behave during unification, giving three modes overall. With - -- 'holesAreErrors' a hole is rejected outright (strict). Otherwise a hole - -- always unifies as a leaf; this flag then chooses what happens when the - -- /surrounding/ structure disagrees: 'True' (the default) defers — any term - -- containing a hole is accepted, for an in-progress sketch — while 'False' - -- keeps such a mismatch an error, so only a hole standing in a matching - -- structure is accepted ('structuralHoleUnify'). - , hintLemmas :: [VarIdent] - -- ^ Named top-level definitions a hole's candidate list may draw on, beyond - -- the local hypotheses (see 'withHintLemmas'). A caller (the game) supplies - -- a small curated allow-list per level; each listed lemma whose type fits - -- the goal is then offered, applied to holes (e.g. @concat ? ? ?@). - } deriving (Functor) - --- Hand-written because the 'globalEmbed' function field cannot be folded; --- its image is exactly the keys of 'globalScopes', which are folded. -instance Foldable Context where - foldMap f Context{..} = mconcat - [ foldMap (foldMap f) localScopes - , foldMap (foldMap f) globalScopes - , foldMap (foldMap f) localDiscreteTopes - , foldMap (foldMap f) localTopes - , foldMap (foldMap f) localTopesNF - , foldMap (foldMap (foldMap f)) localTopesNFUnion - -- localTopesSaturated is skipped: its Foldable is deliberately empty - -- (folding must not force the deferred saturation pipeline). - , foldMap (foldMap f) actionStack - ] - -addVarInCurrentScope :: var -> VarInfo var -> Context var -> Context var -addVarInCurrentScope var info Context{..} = Context - { localScopes = - case localScopes of - [] -> [ScopeInfo Nothing [(var, info)]] - scope : scopes -> addVarToScope var info scope : scopes - , .. } - --- | Add a top-level entry (definition, postulate, section assumption) to the --- current global scope. Only ever happens at the top level, where variables --- are plain 'VarIdent's. -addVarInCurrentGlobalScope :: VarIdent -> VarInfo VarIdent -> Context VarIdent -> Context VarIdent -addVarInCurrentGlobalScope var info Context{..} = Context - { globalScopes = - case globalScopes of - [] -> [GlobalScopeInfo Nothing [(var, info)]] - scope : scopes -> scope { gscopeVars = (var, info) : gscopeVars scope } : scopes - , .. } - -applyModalityToScopes :: TModality -> [ScopeInfo var] -> [ScopeInfo var] -applyModalityToScopes md scopes = map (addModalityToScope md) scopes - -applyModalityToGlobalScopes :: TModality -> [GlobalScopeInfo var] -> [GlobalScopeInfo var] -applyModalityToGlobalScopes md = map $ \scope -> scope - { gscopeVars = map (fmap (\VarInfo{..} -> VarInfo{ modAccum = comp modAccum md, .. })) (gscopeVars scope) } - -applyModalityToTopes :: TModality -> [ModalTope var] -> [ModalTope var] -applyModalityToTopes md topes = map (\ModalTope{..} -> ModalTope{tModAccum = comp tModAccum md, ..}) topes - -applyModality :: TModality -> Context var -> Context var -applyModality md Context{..} = Context - { localScopes = applyModalityToScopes md localScopes - , globalScopes = applyModalityToGlobalScopes md globalScopes - , localTopes = applyModalityToTopes md localTopes - , localTopesNF = applyModalityToTopes md localTopesNF - , localTopesNFUnion = map (applyModalityToTopes md) localTopesNFUnion - , localTopesSaturated = SaturationUncached -- accessibility changed; 'enterModality' refreshes - , .. } - -emptyTopeContext :: [ModalTope var] -emptyTopeContext = - [ ModalTope Id Id topeTopT - , ModalTope Id Flat topeTopT - , ModalTope Id Op topeTopT - , ModalTope Id Sharp topeTopT - ] - -emptyContext :: Context VarIdent -emptyContext = unseeded { localTopesSaturated = SaturationCached sat } - where - -- Seed the saturation cache for the empty tope context, so top-level - -- entailment queries hit the cached path from the start. Deferred, like - -- every other installation (see 'withRefreshedTopes'). - sat = case runExcept (runWriterT (runReaderT (saturateForEntailment emptyTopeContext) unseeded)) of - Left _ -> Nothing - Right (s, _) -> Just s - unseeded = emptyContextUnseeded - -emptyContextUnseeded :: Context VarIdent -emptyContextUnseeded = Context - { localScopes = [ScopeInfo Nothing []] - , globalScopes = [GlobalScopeInfo Nothing []] - , globalEmbed = id - , localDiscreteTopes = [] - , localTopes = emptyTopeContext - , localTopesNF = emptyTopeContext - , localTopesNFUnion = [emptyTopeContext] - , localTopesEntailBottom = Just False - , localTopesSaturated = SaturationUncached - , actionStack = [] - , currentCommand = Nothing - , location = Nothing - , verbosity = Normal - , covariance = Covariant - , renderBackend = Nothing - , renderHideTerm = False - , holesAreErrors = True - , deferHoleMismatches = True - , hintLemmas = [] - } - --- | Switch to lenient hole mode: record each hole's goal and context instead --- of reporting it as an error. Used by the structured goal/context query and --- the @--allow-holes@ CLI mode; the default (strict) mode rejects holes. -allowHoles :: Context var -> Context var -allowHoles ctx = ctx { holesAreErrors = False } - --- | Allow a hole's candidate list to draw on the given named top-level --- definitions (in addition to the local hypotheses). The game supplies the --- per-level allow-list; 'recordHoleShape' then offers each listed lemma whose --- type fits the goal, applied to holes. See 'hintLemmas'. -withHintLemmas :: [VarIdent] -> Context var -> Context var -withHintLemmas lemmas ctx = ctx { hintLemmas = lemmas } - --- | Within the given action, a hole unifies only as a leaf in an otherwise --- matching structure: a structural mismatch around a hole stays an error rather --- than being deferred (see 'deferHoleMismatches'). Used to ask whether a term --- /could/ have a given type, as opposed to tolerating an in-progress sketch. -structuralHoleUnify :: Context var -> Context var -structuralHoleUnify ctx = ctx { deferHoleMismatches = False } - -askCurrentScope :: TypeCheck var (ScopeInfo var) -askCurrentScope = asks localScopes >>= \case - [] -> panicImpossible "no current scope available" - scope : _scopes -> pure scope - -isAccessible :: ModalTope var -> Bool -isAccessible mt = coe (tModVar mt) (tModAccum mt) - -filterAccessible :: [ModalTope var] -> [ModalTope var] -filterAccessible = filter isAccessible - -filterInaccessible :: [ModalTope var] -> [ModalTope var] -filterInaccessible = filter (not . isAccessible) - -partitionAccessible :: [ModalTope var] -> ([ModalTope var], [ModalTope var]) -partitionAccessible = partition isAccessible - -accessibleTopes :: [ModalTope var] -> [TermT var] -accessibleTopes = map tTope . filterAccessible - -plainTope :: TermT var -> ModalTope var -plainTope = ModalTope Id Id - -availableTopes :: Context var -> [TermT var] -availableTopes ctx = map tTope $ filterAccessible (localTopes ctx) - -availableTopesNF :: Context var -> [TermT var] -availableTopesNF ctx = map tTope $ filterAccessible (localTopesNF ctx) - --- | All in-scope variables: binder-bound locals first, then the top-level --- entries with their payloads embedded into the current scope. Locals are --- always more recent than the globals, so this matches the pre-split order. -varInfos :: Context var -> [(var, VarInfo var)] -varInfos Context{..} = concatMap scopeVars localScopes - <> [ (v, globalEmbed <$> info) - | (v, info) <- concatMap gscopeVars globalScopes ] - --- | Look up one variable's 'VarInfo' by walking the scopes directly. The --- per-variable lookups ('typeOfVar', 'valueOfVar', …) run on every 'typeOf' --- of a variable, so going through a projected association list (as the --- whole-context views below do) allocates a pair per scanned entry on the --- hottest path of the checker. A hit in the global scopes is embedded into --- the current scope ('globalEmbed'); the payload itself is never shifted. -lookupVarInfo :: Eq var => var -> Context var -> Maybe (VarInfo var) -lookupVarInfo x Context{..} = go localScopes - where - go [] = goGlobal globalScopes - go (scope : scopes) = - case lookup x (scopeVars scope) of - Just info -> Just info - Nothing -> go scopes - goGlobal [] = Nothing - goGlobal (scope : scopes) = - case lookup x (gscopeVars scope) of - Just info -> Just (globalEmbed <$> info) - Nothing -> goGlobal scopes - -varTypes :: Context var -> [(var, TermT var)] -varTypes = map (fmap varType) . varInfos - -varValues :: Context var -> [(var, Maybe (TermT var))] -varValues = map (fmap varValue) . varInfos - -varOrigs :: Context var -> [(var, Maybe VarIdent)] -varOrigs = map (fmap (binderName . varOrig)) . varInfos - --- | The full binder (pattern) of each in-scope variable, used to restore --- pattern-binder component names (e.g. @t@\/@s@ for @\\ (t , s) -> …@) when --- rendering goals, holes and contexts. -varBinders :: Context var -> [(var, Binder)] -varBinders = map (fmap varOrig) . varInfos - -withPartialDecls - :: TypeCheck VarIdent ([Decl'], [err]) - -> TypeCheck VarIdent ([Decl'], [err]) - -> TypeCheck VarIdent ([Decl'], [err]) -withPartialDecls tc next = do - (decls, errs) <- tc - if null errs - then first (decls <>) - <$> localDeclsPrepared decls next - else return (decls, errs) - -withSection - :: Maybe Rzk.SectionName - -> TypeCheck VarIdent ([Decl VarIdent], [TypeErrorInScopedContext VarIdent]) - -> TypeCheck VarIdent ([Decl VarIdent], [TypeErrorInScopedContext VarIdent]) - -> TypeCheck VarIdent ([Decl VarIdent], [TypeErrorInScopedContext VarIdent]) -withSection name sectionBody = - withPartialDecls $ startSection name $ do - (decls, errs) <- sectionBody - localDeclsPrepared decls $ - performing (ActionCloseSection name) $ do - result <- (Right <$> endSection errs) `catchError` (return . Left) - case result of - Left err -> return ([], errs <> [err]) - Right (decls', errs') -> return (decls', errs') - -- (\ decls' -> (decls', errs)) <$> endSection errs - -startSection :: Maybe Rzk.SectionName -> TypeCheck VarIdent a -> TypeCheck VarIdent a -startSection name = local $ \Context{..} -> Context - { globalScopes = GlobalScopeInfo { gscopeName = name, gscopeVars = [] } : globalScopes - , .. } - --- | The current global scope, as a plain 'ScopeInfo' (at the top level the --- keys and payloads coincide at 'VarIdent'). -askCurrentGlobalScope :: TypeCheck VarIdent (ScopeInfo VarIdent) -askCurrentGlobalScope = asks globalScopes >>= \case - [] -> panicImpossible "no current global scope available" - scope : _scopes -> pure ScopeInfo { scopeName = gscopeName scope, scopeVars = gscopeVars scope } - -endSection :: [TypeErrorInScopedContext VarIdent] -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]) -endSection errs = askCurrentGlobalScope >>= scopeToDecls errs - -scopeToDecls :: Eq var => [TypeErrorInScopedContext var] -> ScopeInfo var -> TypeCheck var ([Decl var], [TypeErrorInScopedContext var]) -scopeToDecls errs ScopeInfo{..} = do - -- In lenient (hole-checking) mode an as-yet-unfilled hole may still come to - -- use a declared variable, so we tolerate the unused-variable diagnostics - -- wherever such a hole is present anywhere in the section. This covers both an - -- unused section assumption and an unused 'uses' variable, and crucially a - -- hole-free definition whose body refers to an in-progress (hole-bearing) one: - -- its 'uses' reads as unused only because the referenced definition is - -- incomplete. Strict mode (the default, and CI) keeps reporting both. - lenient <- not <$> asks holesAreErrors - let sectionHasHole = any (maybe False containsHole . varValue . snd) scopeVars - (decls, errs') <- collectScopeDecls (lenient && sectionHasHole) errs [] scopeVars - -- only issue unused variable errors if there were no errors prior in the section - -- when (null errs) $ do - unusedErrors <- forM decls $ \Decl{..} -> do - let unusedUsedVars = declUsedVars `intersect` map fst scopeVars - if null errs && not (null unusedUsedVars) && not (lenient && sectionHasHole) - then do - err <- local (\c -> c { location = declLocation }) $ - fromTypeError (TypeErrorUnusedUsedVariables unusedUsedVars declName) - return [err] - else return [] - return (decls, errs' <> concat unusedErrors) - -insertExplicitAssumptionFor - :: Eq var => var -> (var, VarInfo var) -> TermT var -> TermT var -insertExplicitAssumptionFor a (declName, VarInfo{..}) term = - term >>= \case - y | y == declName -> appT varType (Pure declName) (Pure a) - | otherwise -> Pure y - -insertExplicitAssumptionFor' - :: Eq var => var -> (var, VarInfo var) -> VarInfo var -> VarInfo var -insertExplicitAssumptionFor' a decl VarInfo{..} - | varIsAssumption = VarInfo{..} - | otherwise = VarInfo - { varType = insertExplicitAssumptionFor a decl varType - , varValue = insertExplicitAssumptionFor a decl <$> varValue - , varIsAssumption = varIsAssumption - , varIsTopLevel = varIsTopLevel - , varModality = varModality - , modAccum = modAccum - , varOrig = varOrig - , varDeclaredAssumptions = varDeclaredAssumptions - , varLocation = varLocation - } - -makeAssumptionExplicit - :: Eq var - => (var, VarInfo var) - -> [(var, VarInfo var)] - -> TypeCheck var (Bool, [(var, VarInfo var)]) -makeAssumptionExplicit _ [] = pure (False {- UNUSED -}, []) -makeAssumptionExplicit assumption@(a, aInfo) ((x, xInfo) : xs) = do - varsInType <- freeVarsT_ (varType xInfo) - varsInBody <- concat <$> traverse freeVarsT_ (varValue xInfo) - let xFreeVars = varsInBody <> varsInType - let hasAssumption = a `elem` xFreeVars - xType <- typeOfVar x - xValue <- valueOfVar x - let assumptionInType = a `elem` freeVars (untyped xType) - assumptionInBody = a `elem` foldMap (freeVars . untyped) xValue - implicitAssumption = and - [ hasAssumption - , not (assumptionInType || assumptionInBody) - , a `notElem` varDeclaredAssumptions xInfo ] - if hasAssumption - then do - when implicitAssumption $ do - issueTypeError $ TypeErrorImplicitAssumption (a, varType aInfo) x - (_used, xs'') <- makeAssumptionExplicit (a, aInfo) xs' - return (True {- USED -}, (x, xInfo') : xs'') - else do - (used, xs'') <- makeAssumptionExplicit assumption xs - return (used, (x, xInfo) : xs'') - where - xType' = typeFunT (varOrig aInfo) Id (varType aInfo) Nothing (abstract a (varType xInfo)) - xInfo' = VarInfo - { varType = xType' - , varValue = fmap (lambdaT xType' (varOrig aInfo) Nothing . abstract a) (varValue xInfo) - , varIsAssumption = varIsAssumption xInfo - , varIsTopLevel = varIsTopLevel xInfo - , varModality = Id - , modAccum = Id - , varOrig = varOrig xInfo - , varDeclaredAssumptions = varDeclaredAssumptions xInfo \\ [a] - , varLocation = varLocation xInfo - } - xs' = map (fmap (insertExplicitAssumptionFor' a (x, xInfo))) xs - -collectScopeDecls :: Eq var => Bool -> [TypeErrorInScopedContext var] -> [(var, VarInfo var)] -> [(var, VarInfo var)] -> TypeCheck var ([Decl var], [TypeErrorInScopedContext var]) -collectScopeDecls tolerateUnused errs recentVars (decl@(var, VarInfo{..}) : vars) - | varIsAssumption = do - (used, recentVars') <- makeAssumptionExplicit decl recentVars - -- only issue unused vars error if there were no other errors previously - -- when (null errs) $ do - unusedErr <- - if null errs && not used && not tolerateUnused - then local (\c -> c { location = varLocation }) $ - pure <$> fromTypeError (TypeErrorUnusedVariable var varType) - else return [] - collectScopeDecls tolerateUnused (errs <> unusedErr) recentVars' vars - | otherwise = do - collectScopeDecls tolerateUnused errs (decl : recentVars) vars -collectScopeDecls _ errs recentVars [] = do - loc <- asks location - return (toDecl loc <$> recentVars, errs) - where - toDecl loc (var, VarInfo{..}) = Decl - { declName = var - , declType = varType - , declValue = varValue - , declIsAssumption = varIsAssumption - , declUsedVars = varDeclaredAssumptions - , declLocation = updatePosition (binderName varOrig >>= fmap fst . Rzk.hasPosition . fromVarIdent) <$> loc -- FIXME - } - updatePosition Nothing l = l - updatePosition (Just lineNo) l = l { locationLine = Just lineNo } - -abstractAssumption :: Eq var => (var, VarInfo var) -> Decl var -> Decl var -abstractAssumption (var, VarInfo{..}) Decl{..} = Decl - { declName = declName - , declType = typeFunT varOrig Id varType Nothing (abstract var declType) - , declValue = (\body -> lambdaT newDeclType varOrig Nothing (abstract var body)) <$> declValue - , declIsAssumption = declIsAssumption - , declUsedVars = declUsedVars - , declLocation = declLocation - } - where - newDeclType = typeFunT varOrig Id varType Nothing (abstract var declType) - -data OutputDirection = TopDown | BottomUp - deriving (Eq) - -block :: OutputDirection -> [String] -> String -block TopDown = intercalate "\n" -block BottomUp = intercalate "\n" . reverse - -namedBlock :: OutputDirection -> String -> [String] -> String -namedBlock dir name lines_ = block dir $ - name : map indent lines_ - where - indent = intercalate "\n" . (map (" " ++)) . lines - -ppContext' :: OutputDirection -> Context VarIdent -> String -ppContext' dir ctx@Context{..} = block dir $ dropWhile null - [ block TopDown - [ case location of - _ | dir == TopDown -> "" -- FIXME - Just (LocationInfo (Just path) (Just lineNo)) -> - path <> " (line " <> show lineNo <> "):" - Just (LocationInfo (Just path) _) -> - path <> ":" - _ -> "" - , case currentCommand of - Just (Rzk.CommandDefine _loc name _vars _params _ty _term) -> - " Error occurred when checking\n #define " <> Rzk.printTree name - Just (Rzk.CommandPostulate _loc name _vars _params _ty ) -> - " Error occurred when checking\n #postulate " <> Rzk.printTree name - Just (Rzk.CommandCheck _loc term ty) -> - " Error occurred when checking\n " <> Rzk.printTree term <> " : " <> Rzk.printTree ty - Just (Rzk.CommandCompute _loc term) -> - " Error occurred when computing\n " <> Rzk.printTree term - Just (Rzk.CommandComputeNF _loc term) -> - " Error occurred when computing NF for\n " <> Rzk.printTree term - Just (Rzk.CommandComputeWHNF _loc term) -> - " Error occurred when computing WHNF for\n " <> Rzk.printTree term - Just (Rzk.CommandSetOption _loc optionName _optionValue) -> - " Error occurred when trying to set option\n #set-option " <> show optionName - Just command@Rzk.CommandUnsetOption{} -> - " Error occurred when trying to unset option\n " <> Rzk.printTree command - Just command@Rzk.CommandAssume{} -> - " Error occurred when checking assumption\n " <> Rzk.printTree command - Just (Rzk.CommandSection _loc name) -> - " Error occurred when checking\n #section " <> Rzk.printTree name - Just (Rzk.CommandSectionEnd _loc name) -> - " Error occurred when checking\n #end " <> Rzk.printTree name - Nothing -> " Error occurred outside of any command!" - ] - , "" - , case filter (/= topeTopT) (availableTopes ctx) of - [] -> "Local tope context is unrestricted (⊤)." - localTopes' -> namedBlock TopDown "Local tope context:" - [ " " <> ppU (untyped tope) - | tope <- localTopes' ] - , "" - , block dir - [ "when " <> ppAction fbs 0 action - | action <- actionStack ] - , namedBlock TopDown "Definitions in context:" - [ block dir - [ dispName x <> " : " <> ppU (untyped ty) - | (x, ty) <- reverse (varTypes ctx) ] ] - ] - where - (fbs, _) = contextBinders ctx - ppU = ppFoldU fbs - -- a pattern binder is shown as its pattern, e.g. (t , s); others by name - dispName x = maybe (show (Pure x :: Term')) (show . binderDisplayName) (lookup x fbs) - --- | All display names in scope, read off the raw entries: a binder --- ('varOrig') never mentions the scope's variables, so no global payload --- needs embedding. Going through 'varOrigs' here instead embedded every --- global 'VarInfo' once per new top-level name ('checkTopLevelDuplicate'), --- quadratically over a project. -scopeNames :: Context var -> [VarIdent] -scopeNames Context{..} = mapMaybe entryName (concatMap scopeVars localScopes) - <> mapMaybe entryName (concatMap gscopeVars globalScopes) - where - entryName :: (v, VarInfo w) -> Maybe VarIdent - entryName = binderName . varOrig . snd - -doesShadowName :: VarIdent -> TypeCheck var [VarIdent] -doesShadowName name = asks (filter (name ==) . scopeNames) - -checkTopLevelDuplicate :: VarIdent -> TypeCheck var () -checkTopLevelDuplicate name = do - doesShadowName name >>= \case - [] -> return () - collisions -> issueTypeError $ - TypeErrorDuplicateTopLevel collisions name - -checkNameShadowing :: VarIdent -> TypeCheck var () -checkNameShadowing name = do - doesShadowName name >>= \case - [] -> return () - collisions -> issueWarning $ - Rzk.printTree (getVarIdent name) <> " shadows an existing definition:" - <> unlines - [ " " <> ppVarIdentWithLocation name - , "previous top-level definitions found at" - , intercalate "\n" - [ " " <> ppVarIdentWithLocation prev | prev <- collisions ] ] - -withLocation :: LocationInfo -> TypeCheck var a -> TypeCheck var a -withLocation loc = local $ \Context{..} -> Context { location = Just loc, .. } - -withCommand :: Rzk.Command -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]) -> TypeCheck VarIdent ([Decl'], [TypeErrorInScopedContext VarIdent]) -withCommand command tc = local f $ do - result <- (Right <$> tc) `catchError` (return . Left) - case result of - Left err -> return ([], [err]) - Right (decls, errs) -> return (decls, errs) - where - f Context{..} = Context - { currentCommand = Just command - , location = updatePosition (Rzk.hasPosition command) <$> location - , .. } - updatePosition pos loc = loc { locationLine = fst <$> pos } - -localDecls :: [Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a -localDecls [] = id -localDecls (decl : decls) = localDecl decl . localDecls decls - -localDeclsPrepared :: [Decl VarIdent] -> TypeCheck VarIdent a -> TypeCheck VarIdent a -localDeclsPrepared [] = id -localDeclsPrepared (decl : decls) = localDeclPrepared decl . localDeclsPrepared decls - -localDecl :: Decl VarIdent -> TypeCheck VarIdent a -> TypeCheck VarIdent a -localDecl (Decl x ty term isAssumption vars loc) tc = do - ty' <- memoizeWHNF ty - term' <- traverse memoizeWHNF term - localDeclPrepared (Decl x ty' term' isAssumption vars loc) tc - -localDeclPrepared :: Decl VarIdent -> TypeCheck VarIdent a -> TypeCheck VarIdent a -localDeclPrepared (Decl x ty term isAssumption vars loc) tc = do - checkTopLevelDuplicate x - local update tc - where - update = addVarInCurrentGlobalScope x VarInfo - { varType = ty - , varValue = term - , varOrig = BinderVar (Just x) - , varModality = Id - , modAccum = Id - , varIsAssumption = isAssumption - , varIsTopLevel = True - , varDeclaredAssumptions = vars - , varLocation = loc - } - --- | A binding shown in a hole's local context: the display name and its type, --- already rendered with user-facing 'VarIdent' names (see 'HoleInfo'). -data HoleEntry = HoleEntry - { holeEntryName :: VarIdent - , holeEntryType :: Term' - } deriving (Eq, Show) - --- | The structured goal and context at a hole, recorded in lenient mode (see --- 'allowHoles'). Everything is rendered to user-facing 'VarIdent' names at --- record time, so 'HoleInfo' is independent of the De Bruijn scope it came --- from. Local hypotheses are split into ordinary term variables and cube --- variables (the cube/tope layer is specific to Rzk); the global environment is --- deliberately excluded — it belongs in a searchable inventory, not the goal --- panel. -data HoleInfo = HoleInfo - { holeName :: Maybe VarIdent -- ^ the @?name@, if the hole was named - , holeGoal :: Term' -- ^ expected type (the goal), kept symbolic - , holeGoalShape :: Maybe (VarIdent, Term') - -- ^ when the goal is a /shape/ (the hole is the argument of a - -- shape-restricted function), the shape's bound variable and its tope: the - -- goal then reads @(binder : holeGoal | tope)@. 'Nothing' for an ordinary - -- goal. (Extension-type goals need no special handling — they are already a - -- restricted type in 'holeGoal'.) - , holeTermVars :: [HoleEntry] -- ^ local hypotheses whose type is not a cube - , holeCubeVars :: [HoleEntry] -- ^ local cube variables (type is a cube) - , holeTopes :: [Term'] -- ^ local tope assumptions (excluding ⊤) - , holeCandidates :: [Term'] - -- ^ elimination spines over the local hypotheses whose type fits the goal, - -- with applied arguments left as holes (see 'allEliminationsInto'). Already - -- rendered, like the other fields. - , holeIntroductions :: [Term'] - -- ^ introduction forms for the goal type, built from its head constructor - -- with the constituents left as holes (see 'allIntroductionsOf'). Already - -- rendered, like the other fields. - , holeDiagram :: Maybe String - -- ^ an SVG of the goal cell, when the goal is a renderable shape (an arrow, - -- triangle, or square up to dimension 3): the shape with its given boundary - -- edges, drawn from an abstract inhabitant of the goal type with the - -- proof term hidden (see 'renderHideTerm'). 'Nothing' for a non-shape goal. - , holeLocation :: Maybe LocationInfo - } deriving (Eq, Show) - -type TypeCheck var = - ReaderT (Context var) - (WriterT [HoleInfo] (Except (TypeErrorInScopedContext var))) - -freeVarsT_ :: Eq var => TermT var -> TypeCheck var [var] -freeVarsT_ term = do - ctx <- ask - let typeOfVar' x = - case lookupVarInfo x ctx of - Nothing -> panicImpossible "undefined variable" - Just info -> varType info - return (freeVarsT typeOfVar' term) - -traceStartAndFinish :: Show a => String -> a -> a -traceStartAndFinish tag = trace ("start [" <> tag <> "]") . - (\x -> trace ("finish [" <> tag <> "] with " <> show x) x) - --- | Monadic 'all' that stops at the first failing element. -allM :: Monad m => (a -> m Bool) -> [a] -> m Bool -allM p = go - where - go [] = return True - go (x:xs) = p x >>= \case - False -> return False - True -> go xs - -entailM :: Eq var => [ModalTope var] -> TermT var -> TypeCheck var Bool -entailM modalTopes goal = do - -- genTopes <- generateTopesForPointsM (allTopePoints goal) - topes''' <- saturateForEntailment modalTopes - entailSaturatedM topes''' goal - --- | The preprocessing 'entailM' performs before searching: dedup, split off --- context disjunctions, and saturate each alternative. Depends only on the --- given topes (plus the discreteness axioms of the context), not on the goal --- (the points argument of 'saturateTopes' is ignored). -saturateForEntailment :: Eq var => [ModalTope var] -> TypeCheck var [[ModalTope var]] -saturateForEntailment modalTopes = do - discreteAxioms <- generateTopesForModalCubeVarsM - let topes' = nubTermT (modalTopes <> discreteAxioms) - topes'' = simplifyLHSwithDisjunctions topes' - mapM (fmap (saturateTopes [] . saturateBottom) . saturateInv) topes'' - --- | Search each saturated alternative for the goal; the shared tail of --- 'entailM' and the cached 'entailContextM'. -entailSaturatedM :: Eq var => [[ModalTope var]] -> TermT var -> TypeCheck var Bool -entailSaturatedM topes''' goal = asks verbosity >>= \case - Debug -> do - prettyTopes <- mapM ppTermInContext (map tTope (concat topes''')) - prettyTope <- ppTermInContext goal - traceTypeCheck Debug - ("entail " <> intercalate ", " prettyTopes <> " |- " <> prettyTope) $ - allM (`solveRHSM` goal) topes''' - _ -> allM (`solveRHSM` goal) topes''' - --- | Entailment against the context's own tope context, using the --- 'localTopesSaturated' cache when one was installed (it is maintained at --- the points where the tope context changes); otherwise fall back to the --- per-query pipeline over 'localTopesNF'. Matching on the payload of --- 'SaturationCached' is what forces the deferred pipeline, so the cost is --- paid at the first query under a context, and never for contexts that are --- never queried. -entailContextM :: Eq var => TermT var -> TypeCheck var Bool -entailContextM goal = asks localTopesSaturated >>= \case - SaturationCached (Just topes''') -> entailSaturatedM topes''' goal - SaturationCached Nothing -> fallback - SaturationUncached -> fallback - where - fallback = asks localTopesNF >>= (`entailM` goal) - --- | Install a deferred 'localTopesSaturated' cache for the transformed --- context, and run the action with it. The pipeline's effects (Reader, --- Writer, Except) are discharged purely into a thunk: installation costs --- nothing, holes recorded by the speculative run are discarded, and a --- pipeline error (e.g. a tope guard with a hole in lenient mode, which the --- per-query path would never have evaluated) becomes 'Nothing', so errors --- surface exactly where they did before. Used at every point where the tope --- context changes; ordinary binder entries instead shift the cached value --- with the rest of the context (saturation commutes with renaming). -withRefreshedTopes :: Eq var => (Context var -> Context var) -> TypeCheck var a -> TypeCheck var a -withRefreshedTopes f action = do - ctx' <- asks f - let sat = case runExcept (runWriterT (runReaderT (saturateForEntailment (localTopesNF ctx')) ctx')) of - Left _ -> Nothing - Right (s, _) -> Just s - local (const ctx' { localTopesSaturated = SaturationCached sat }) action - - -generateTopesForModalCubeVarsM :: TypeCheck var [ModalTope var] -generateTopesForModalCubeVarsM = asks localDiscreteTopes - -entailTraceM :: Eq var => [ModalTope var] -> TermT var -> TypeCheck var Bool -entailTraceM modalTopes goal = do - topes' <- mapM ppTermInContext (accessibleTopes modalTopes) - goal' <- ppTermInContext goal - result <- trace ("entail " <> intercalate ", " topes' <> " |- " <> goal') $ - modalTopes `entailM` goal - return $ trace (" " <> show result) result - -nubTermT :: Eq a => [a] -> [a] -nubTermT [] = [] -nubTermT (t:ts) = t : nubTermT (filter (/= t) ts) - -saturateTopes :: Eq var => [TermT var] -> [ModalTope var] -> [ModalTope var] -saturateTopes _points topes = - let (accessible, inaccessible) = partitionAccessible topes - saturated = saturateWith - (\mt ts -> mt `elem` ts) - (\new old -> map plainTope $ generateTopes (map tTope new) (map tTope old)) - accessible - in saturated <> inaccessible - -saturateInv :: Eq var => [ModalTope var] -> TypeCheck var [ModalTope var] -saturateInv modalTopes = do - -- FIXME: this is a workaround; ideally we should regenerate all topes - -- on EVERY modality change in any layer, but that would produce too many; - -- for now we also invert topes that were accessible before the modality shift - let accessible = filterAccessible modalTopes - accessibleById = filter (\mt -> coe (tModVar mt) Id) modalTopes - invResults <- forM (nubTermT (accessible <> accessibleById)) $ \mt -> do - nf <- nfTope $ modExtractT topeT Id Op (topeInvT (tTope mt)) - return $ ModalTope (tModAccum mt) Op nf - let accessibleUnderOp = filter (\mt -> coe (tModVar mt) (comp (tModAccum mt) Op)) modalTopes - uninvResults <- forM accessibleUnderOp $ \(ModalTope acc var' phi) -> do - nf <- nfTope $ topeUninvT (modAppT topeT Op phi) - return $ ModalTope (comp acc Op) var' nf - let newTopes = nubTermT (invResults <> uninvResults) - fresh = filter (`notElem` modalTopes) newTopes - return (modalTopes <> fresh) - --- | Ex falso for BOT, lifted across modalities. --- --- A contradiction in the topes that are genuinely available at the identity --- modality entails BOT, and BOT entails @_μ BOT@ for every modality @μ@ by the --- absurd rule (this holds for BOT specifically; a general tope @φ@ does NOT give --- @_μ φ@, which would need the missing unit @id ⇒ μ@). Re-asserting @_μ BOT@ at --- each lock @μ@ where an available tope was hidden lets the contradiction survive --- the lock: e.g. @_b BOT@ is accessible under a @_b@ lock (@coe Flat Flat@), so --- @mod _b recBOT@ in a vacuous context is accepted. --- --- A tope counts as available at the identity modality when its variable modality --- coerces into @Id@: a @_b@-modal tope qualifies via the counit (@coe Flat Id@), --- but a @_#@-modal one does not (@coe Sharp Id@ is False) — which is exactly why --- @_# BOT@ does not leak to plain BOT (see ill-modal-sharp-bot-not-bot). -saturateBottom :: Eq var => [ModalTope var] -> [ModalTope var] -saturateBottom modalTopes - | null droppedAccums = modalTopes -- nothing hidden by a lock; ordinary saturation suffices - | botDerivable = modalTopes <> fresh - | otherwise = modalTopes - where - idAccessible = filter (\mt -> coe (tModVar mt) Id) modalTopes - droppedAccums = nub [ tModAccum mt | mt <- idAccessible, not (isAccessible mt) ] - saturatedId = saturateWith (\t ts -> t `elem` ts) generateTopes (map tTope idAccessible) - botDerivable = topeBottomT `elem` saturatedId - fresh = [ mt - | acc <- droppedAccums - , let mt = ModalTope acc acc topeBottomT - , mt `notElem` modalTopes ] - --- FIXME: cleanup -saturateWith :: (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a] -saturateWith elem' step zs = go (nub' zs) [] - where - go lastNew xs - | null new = lastNew - | otherwise = lastNew <> go new xs' - where - xs' = lastNew <> xs - new = filter (not . (`elem'` xs')) (nub' $ step lastNew xs) - nub' [] = [] - nub' (x:xs) = x : nub' (filter (not . (`elem'` [x])) xs) - -generateTopes :: Eq var => [TermT var] -> [TermT var] -> [TermT var] -generateTopes newTopes oldTopes - | topeBottomT `elem` newTopes = [] - | topeEQT cube2_0T cube2_1T `elem` newTopes = [topeBottomT] - | topeEQT cubeI_0T cubeI_1T `elem` newTopes = [topeBottomT] - | length oldTopes > 100 = [] -- FIXME - | otherwise = concat - [ -- symmetry EQ - [ topeEQT y x | TopeEQT _ty x y <- newTopes ] - -- transitivity EQ (1) - , [ topeEQT x z - | TopeEQT _ty x y : newTopes' <- tails newTopes - , TopeEQT _ty y' z <- newTopes' <> oldTopes - , y == y' ] - -- transitivity EQ (2) - , [ topeEQT x z - | TopeEQT _ty y z : newTopes' <- tails newTopes - , TopeEQT _ty x y' <- newTopes' <> oldTopes - , y == y' ] - - -- transitivity LEQ (1) - , [ topeLEQT x z - | TopeLEQT _ty x y : newTopes' <- tails newTopes - , TopeLEQT _ty y' z <- newTopes' <> oldTopes - , y == y' ] - -- transitivity LEQ (2) - , [ topeLEQT x z - | TopeLEQT _ty y z : newTopes' <- tails newTopes - , TopeLEQT _ty x y' <- newTopes' <> oldTopes - , y == y' ] - - -- antisymmetry LEQ - , [ topeEQT x y - | TopeLEQT _ty x y : newTopes' <- tails newTopes - , TopeLEQT _ty y' x' <- newTopes' <> oldTopes - , y == y' - , x == x' ] - - -- FIXME: special case of substitution of EQ - -- transitivity EQ-LEQ (1) - , [ topeLEQT x z - | TopeEQT _ty y z : newTopes' <- tails newTopes - , TopeLEQT _ty x y' <- newTopes' <> oldTopes - , y == y' ] - - -- FIXME: special case of substitution of EQ - -- transitivity EQ-LEQ (2) - , [ topeLEQT x z - | TopeEQT _ty x y : newTopes' <- tails newTopes - , TopeLEQT _ty y' z <- newTopes' <> oldTopes - , y == y' ] - - -- FIXME: special case of substitution of EQ - -- transitivity EQ-LEQ (3) - , [ topeLEQT x z - | TopeLEQT _ty y z : newTopes' <- tails newTopes - , TopeEQT _ty x y' <- newTopes' <> oldTopes - , y == y' ] - - -- FIXME: special case of substitution of EQ - -- transitivity EQ-LEQ (4) - , [ topeLEQT x z - | TopeLEQT _ty x y : newTopes' <- tails newTopes - , TopeEQT _ty y' z <- newTopes' <> oldTopes - , y == y' ] - - -- FIXME: consequence of LEM for LEQ and antisymmetry for LEQ - , [ topeEQT x y | TopeLEQT _ty x y@Cube2_0T{} <- newTopes ] - -- FIXME: consequence of LEM for LEQ and antisymmetry for LEQ - , [ topeEQT x y | TopeLEQT _ty x@Cube2_1T{} y <- newTopes ] - , [ topeEQT x y | TopeLEQT _ty x y@CubeI_0T{} <- newTopes ] - -- FIXME: consequence of LEM for LEQ and antisymmetry for LEQ - , [ topeEQT x y | TopeLEQT _ty x@CubeI_1T{} y <- newTopes ] - - -- subtyping 2 <: II: endpoints and order of 2 lift to II - , [ topeEQT x cubeI_0T | TopeEQT _ty x Cube2_0T{} <- newTopes ] - , [ topeEQT cubeI_0T x | TopeEQT _ty Cube2_0T{} x <- newTopes ] - , [ topeEQT x cubeI_1T | TopeEQT _ty x Cube2_1T{} <- newTopes ] - , [ topeEQT cubeI_1T x | TopeEQT _ty Cube2_1T{} x <- newTopes ] - , [ topeLEQT x cubeI_0T | TopeLEQT _ty x Cube2_0T{} <- newTopes ] - , [ topeLEQT cubeI_0T x | TopeLEQT _ty Cube2_0T{} x <- newTopes ] - , [ topeLEQT x cubeI_1T | TopeLEQT _ty x Cube2_1T{} <- newTopes ] - , [ topeLEQT cubeI_1T x | TopeLEQT _ty Cube2_1T{} x <- newTopes ] - ] - -generateTopesForPointsM :: Eq var => [TermT var] -> TypeCheck var [TermT var] -generateTopesForPointsM points = do - let pairs = nub $ concat - [ [ (x, y) - | x : points' <- tails (filter (`notElem` [cube2_0T, cube2_1T, cubeI_0T, cubeI_1T]) points) - , y <- points' - , x /= y ] - ] - stars <- forM points $ \x -> do - xType <- typeOf x - return $ if (xType == cubeUnitT) - then [topeEQT x cubeUnitStarT] - else [] - topes <- forM pairs $ \(x, y) -> do - xType <- typeOf x - yType <- typeOf y - return $ if (xType == cube2T) && (yType == cube2T) - then [topeOrT (topeLEQT x y) (topeLEQT y x)] - else [] - return (concat (topes ++ stars)) - -allTopePoints :: Eq var => TermT var -> [TermT var] -allTopePoints = nubTermT . foldMap subPoints . nubTermT . topePoints - -topePoints :: TermT var -> [TermT var] -topePoints = \case - TopeTopT{} -> [] - TopeBottomT{} -> [] - TopeAndT _ l r -> topePoints l <> topePoints r - TopeOrT _ l r -> topePoints l <> topePoints r - TopeEQT _ x y -> [x, y] - TopeLEQT _ x y -> [x, y] - _ -> [] - -subPoints :: TermT var -> [TermT var] -subPoints = \case - p@(PairT _ x y) -> p : foldMap subPoints [x, y] - p@Pure{} -> [p] - p@(Free (AnnF TypeInfo{..} _)) - | Cube2T{} <- infoType -> [p] - | CubeUnitT{} <- infoType -> [p] - _ -> [] - --- | Simplify the context, including disjunctions. See also 'simplifyLHS'. -simplifyLHSwithDisjunctions :: Eq var => [ModalTope var] -> [[ModalTope var]] -simplifyLHSwithDisjunctions topes = map nubTermT $ - case topes of - [] -> [[]] - (ModalTope _ _ TopeTopT{}) : topes' -> simplifyLHSwithDisjunctions topes' - (ModalTope mAcc mVar TopeBottomT{}) : _ -> [[ModalTope mAcc mVar topeBottomT]] - (ModalTope mAcc mVar (TopeAndT _ l r)) : topes' -> simplifyLHSwithDisjunctions ((ModalTope mAcc mVar l) : (ModalTope mAcc mVar r) : topes') - - -- NOTE: it is inefficient to expand disjunctions immediately - (ModalTope mAcc mVar (TopeOrT _ l r)) : topes' -> simplifyLHSwithDisjunctions ((ModalTope mAcc mVar l) : topes') <> simplifyLHSwithDisjunctions ((ModalTope mAcc mVar r) : topes') - - (ModalTope mAcc mVar (TopeEQT _ (PairT _ x y) (PairT _ x' y'))) : topes' -> - simplifyLHSwithDisjunctions (ModalTope mAcc mVar (topeEQT x x') : ModalTope mAcc mVar (topeEQT y y') : topes') - (ModalTope mAcc mVar (TypeModalT _ md inTope)) : topes' -> - simplifyLHSwithDisjunctions ((ModalTope mAcc (comp mVar md) inTope) : topes') - t : topes' -> map (t :) (simplifyLHSwithDisjunctions topes') - --- | Simplify the context, except disjunctions. See also 'simplifyLHSwithDisjunctions'. -simplifyLHS :: Eq var => [ModalTope var] -> [ModalTope var] -simplifyLHS topes = nubTermT $ - case topes of - [] -> [] - (ModalTope _ _ TopeTopT{}) : topes' -> simplifyLHS topes' - (ModalTope _ _ TopeBottomT{}) : _ -> [plainTope topeBottomT] - (ModalTope mAcc mVar (TopeAndT _ l r)) : topes' -> simplifyLHS (ModalTope mAcc mVar l : ModalTope mAcc mVar r : topes') - - -- NOTE: it is inefficient to expand disjunctions immediately - -- (ModalTope mAcc mVar (TopeOrT _ l r)) : topes' -> simplifyLHS (ModalTope mAcc mVar l : topes') <> simplifyLHS (ModalTope mAcc mVar r : topes') - - (ModalTope mAcc mVar (TopeEQT _ (PairT _ x y) (PairT _ x' y'))) : topes' -> - simplifyLHS (ModalTope mAcc mVar (topeEQT x x') : ModalTope mAcc mVar (topeEQT y y') : topes') - (ModalTope mAcc mVar (TypeModalT _ md inTope)) : topes' -> - simplifyLHS (ModalTope mAcc (comp mVar md) inTope : topes') - t : topes' -> t : simplifyLHS topes' - -solveRHSM :: Eq var => [ModalTope var] -> TermT var -> TypeCheck var Bool -solveRHSM modalTopes goal = - let topes = accessibleTopes modalTopes - in case goal of - _ | topeBottomT `elem` topes -> return True - TopeTopT{} -> return True - TypeModalT _ty md inTope -> do - let shifted = applyModalityToTopes md modalTopes - resaturated = saturateTopes [] shifted - resaturatedInv <- saturateInv resaturated - solveRHSM resaturatedInv inTope - TopeEQT _ty (PairT _ty1 x y) (PairT _ty2 x' y') -> - solveRHSM modalTopes $ topeAndT - (topeEQT x x') - (topeEQT y y') - TopeEQT _ty (PairT TypeInfo{ infoType = CubeProductT _ cubeI cubeJ } x y) r -> - solveRHSM modalTopes $ topeAndT - (topeEQT x (firstT cubeI r)) - (topeEQT y (secondT cubeJ r)) - TopeEQT _ty l (PairT TypeInfo{ infoType = CubeProductT _ cubeI cubeJ } x y) -> - solveRHSM modalTopes $ topeAndT - (topeEQT (firstT cubeI l) x) - (topeEQT (secondT cubeJ l) y) - TopeEQT _ty l r - | or - [ l == r - , goal `elem` topes - , topeEQT r l `elem` topes - ] -> return True - TopeEQT _ty l r -> do - lType <- typeOf l - rType <- typeOf r - return $ case (lType, rType) of - (CubeUnitT{}, CubeUnitT{}) -> True - _ -> False - TopeLEQT _ty l r - | l == r -> return True - | solveRHS topes (topeEQT l r) -> return True - | solveRHS topes (topeEQT l cube2_0T) -> return True - | solveRHS topes (topeEQT r cube2_1T) -> return True - TopeAndT _ l r -> solveRHSM modalTopes l >>= \case - False -> return False - True -> solveRHSM modalTopes r - _ | goal `elem` topes -> return True - TopeInvT{} -> do - goal' <- nfTope goal - case goal' of - TopeInvT{} -> return False - _ -> solveRHSM modalTopes goal' - TopeUninvT{} -> do - goal' <- nfTope goal - case goal' of - TopeUninvT{} -> return False - _ -> solveRHSM modalTopes goal' - TopeOrT _ l r -> do - found <- solveRHSM modalTopes l >>= \case - True -> return True - False -> solveRHSM modalTopes r - if found - then return True - else do - lems <- generateTopesForPointsM (allTopePoints goal) - let lems' = [ lem | lem@(TopeOrT _ t1 t2) <- lems, all (`notElem` topes) [t1, t2] ] - (accessible, hidden) = partitionAccessible modalTopes - withTope t = hidden ++ saturateTopes [] (plainTope t : accessible) - - case lems' of - TopeOrT _ t1 t2 : _ -> - solveRHSM (withTope t1) goal >>= \case - False -> return False - True -> solveRHSM (withTope t2) goal - _ -> return False - _ -> return False - -solveRHS :: Eq var => [TermT var] -> TermT var -> Bool -solveRHS topes tope = - case tope of - _ | topeBottomT `elem` topes -> True - TopeTopT{} -> True - TopeEQT _ty (PairT _ty1 x y) (PairT _ty2 x' y') - | solveRHS topes (topeEQT x x') && solveRHS topes (topeEQT y y') -> True - TopeEQT _ty (PairT TypeInfo{ infoType = CubeProductT _ cubeI cubeJ } x y) r - | solveRHS topes (topeEQT x (firstT cubeI r)) && solveRHS topes (topeEQT y (secondT cubeJ r)) -> True - TopeEQT _ty l (PairT TypeInfo{ infoType = CubeProductT _ cubeI cubeJ } x y) - | solveRHS topes (topeEQT (firstT cubeI l) x) && solveRHS topes (topeEQT (secondT cubeJ l) y) -> True - TopeEQT _ty l r -> or - [ l == r - , tope `elem` topes - , topeEQT r l `elem` topes - ] - TopeLEQT _ty l r - | l == r -> True - | solveRHS topes (topeEQT l r) -> True - | solveRHS topes (topeEQT l cube2_0T) -> True - | solveRHS topes (topeEQT r cube2_1T) -> True - -- TopeBottomT{} -> solveLHS topes tope - TopeAndT _ l r -> solveRHS topes l && solveRHS topes r - TopeOrT _ l r -> solveRHS topes l || solveRHS topes r - _ -> tope `elem` topes - -checkTope :: Eq var => TermT var -> TypeCheck var Bool -checkTope tope = do - ctxTopes <- asks availableTopes - performing (ActionContextEntails ctxTopes tope) $ do - tope' <- nfTope tope - entailContextM tope' - -checkTopeEntails :: Eq var => TermT var -> TypeCheck var Bool -checkTopeEntails tope = do - ctxTopes <- asks availableTopes - performing (ActionContextEntailedBy ctxTopes tope) $ do - contextTopes <- asks availableTopesNF - restrictionTope <- nfTope tope - let contextTopesRHS = foldr topeAndT topeTopT contextTopes - [plainTope restrictionTope] `entailM` contextTopesRHS - -checkEntails :: Eq var => TermT var -> TermT var -> TypeCheck var Bool -checkEntails l r = do -- FIXME: add action - l' <- nfTope l - r' <- nfTope r - [plainTope l'] `entailM` r' - -contextEntails :: Eq var => TermT var -> TypeCheck var () -contextEntails tope = do - ctxTopes <- asks availableTopes - performing (ActionContextEntails ctxTopes tope) $ do - topeIsEntailed <- checkTope tope - topes' <- asks availableTopesNF - -- When a hole is used in a cube/tope position (e.g. as the argument of a - -- shape-restricted function), the tope being checked mentions the hole and - -- cannot be decided. Treat it as satisfied (defer) rather than failing. - unless (topeIsEntailed || containsHole tope) $ - issueTypeError $ TypeErrorTopeNotSatisfied topes' tope - -topesEquiv :: Eq var => TermT var -> TermT var -> TypeCheck var Bool -topesEquiv expected actual = performing (ActionUnifyTerms expected actual) $ do - expected' <- nfT expected - actual' <- nfT actual - (&&) - <$> [plainTope expected'] `entailM` actual' - <*> [plainTope actual'] `entailM` expected' - --- | Check that the local tope context is included in (entails) the union of --- the given topes. This is the COVERAGE obligation of @recOR@: every point of the --- context must be covered by some branch guard. --- --- Note that only coverage is required, not equivalence: branch guards may overhang --- the context (e.g. when splitting with an already-defined shape), so we do not --- require @OR(guards) |- context@. -contextEntailsUnion :: Eq var => [TermT var] -> TypeCheck var () -contextEntailsUnion topes = do - ctxTopes <- asks availableTopes - performing (ActionContextEntailsUnion ctxTopes topes) $ do - contextTopes <- asks localTopesNF - topesNF <- mapM nfTope topes - let unionRHS = foldr topeOrT topeBottomT topesNF - entailContextM unionRHS >>= \case - -- a guard mentioning an (unfilled) hole can't be decided; defer coverage - False | not (any containsHole topesNF) -> - issueTypeError $ TypeErrorTopeNotSatisfied (accessibleTopes contextTopes) unionRHS - _ -> return () - --- | Diagnose a recOR branch guard or restriction face against the local tope --- context. There are three cases, by how the tope relates to the context: --- --- * DISJOINT — the tope and a consistent context have empty overlap (their --- conjunction is ⊥). The face/branch is then vacuous everywhere, so this is a --- hard error. --- * OVERHANG — the tope is not entailed by the context but still overlaps it. --- This is allowed and often intentional (e.g. splitting or restricting with an --- already-defined shape, whose faces live on the whole cube rather than being --- relativised to the context), so we only emit a non-fatal hint. The hint is --- gated at 'Normal' verbosity, hence silent under 'Silent' (e.g. in tests). --- * CONTAINED — the tope entails the context: nothing to report. -checkTopeAgainstContext :: Eq var => String -> TermT var -> TypeCheck var () -checkTopeAgainstContext what tope = do - -- a contradictory context is handled elsewhere (recBOT) - ctxEntailsBottom <- contextEntailsBottom - unless ctxEntailsBottom $ do - contextTopes <- asks localTopesNF - let ctxTopes = filter (/= topeTopT) (accessibleTopes contextTopes) - disjoint <- (plainTope tope : contextTopes) `entailM` topeBottomT - -- a face/guard mentioning an (unfilled) hole can't be decided; defer - if disjoint && not (containsHole tope) - then issueTypeError (TypeErrorTopeContextDisjoint tope ctxTopes) - else do - entailed <- checkTopeEntails tope -- tope |- AND(accessible context) - unless entailed $ do - topeStr <- ppTermInContext tope - ctxStrs <- mapM ppTermInContext ctxTopes - traceTypeCheck Normal - (intercalate "\n" $ - [ "Warning: " <> what <> " overhangs the local tope context" - , " " <> topeStr - , "is not entailed by the local context (normalised)" - ] <> map (" " <>) ctxStrs) - (return ()) - -switchVariance :: TypeCheck var a -> TypeCheck var a -switchVariance = local $ \Context{..} -> Context - { covariance = switch covariance, .. } - where - switch Covariant = Contravariant - switch Contravariant = Covariant - switch Invariant = Invariant - -setVariance :: Covariance -> TypeCheck var a -> TypeCheck var a -setVariance variance = local $ \Context{..} -> Context - { covariance = variance, .. } - -enterScopeContext :: Binder -> TModality -> TermT var -> Maybe (TermT var) -> Context var -> Context (Inc var) -enterScopeContext orig md ty val context = - addVarInCurrentScope Z VarInfo - { varType = S <$> ty - , varValue = fmap (S <$>) val - , varOrig = orig - , varModality = md - , modAccum = Id - , varIsAssumption = False - , varIsTopLevel = False - , varDeclaredAssumptions = [] - , varLocation = location context - } - (S <$> context) - -enterScopeMaybe :: Eq var => Binder -> TModality -> TermT var -> Maybe (TermT var) -> TypeCheck (Inc var) b -> TypeCheck var b -enterScopeMaybe orig md ty mval action = do - mDiscrete <- case md of - Flat -> whnfT ty >>= \case - Cube2T{} -> pure (Just (topeOrT (topeEQT z cube2_0T) (topeEQT z cube2_1T))) - CubeIT{} -> pure (Just (topeOrT (topeEQT z cubeI_0T) (topeEQT z cubeI_1T))) - _ -> pure Nothing - _ -> pure Nothing - newContext <- asks (enterScopeContext orig md ty mval) - let newContext' = newContext - { localDiscreteTopes = maybe id ((:) . plainTope) mDiscrete (localDiscreteTopes newContext) } - -- A new discreteness axiom changes the saturation input; ordinary - -- binders keep the shifted cache (saturation commutes with renaming). - refresh = maybe id (const (withRefreshedTopes id)) mDiscrete - closeScope orig (runReaderT (refresh action) newContext') - where - z = Pure Z - -enterScope :: Eq var => Binder -> TModality -> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b -enterScope orig md ty = enterScopeMaybe orig md ty Nothing - -enterScopeWithBind :: Eq var => Binder -> TModality -> TermT var -> TermT var -> TypeCheck (Inc var) b -> TypeCheck var b -enterScopeWithBind orig md ty val = enterScopeMaybe orig md ty (Just val) - --- | Run a sub-scope computation and lift it back to the enclosing scope: close --- the error channel one binder with 'ScopedTypeError' (as before), and re-emit --- the holes it recorded. 'HoleInfo' is already rendered to 'VarIdent' names, so --- no De Bruijn re-indexing is needed — only a plain re-'tell'. On a thrown --- error the sub-scope's holes are dropped, which is intended: holes only matter --- on the success path (lenient mode), and strict mode wants the error anyway. -closeScope - :: Binder - -> WriterT [HoleInfo] (Except (TypeErrorInScopedContext (Inc var))) b - -> TypeCheck var b -closeScope orig inner = do - (b, holes) <- lift . lift . withExceptT (ScopedTypeError (binderName orig)) $ runWriterT inner - lift (tell holes) - return b - -enterModality :: Eq var => TModality -> TypeCheck var b -> TypeCheck var b -enterModality Id action = action -enterModality md action = do - newContext <- asks (applyModality md) - let newContext' = newContext { localTopesEntailBottom = Nothing } - -- 'applyModality' invalidated the saturation cache (accessibility - -- changed); refresh it under the shifted context. - lift $ runReaderT (withRefreshedTopes id action) newContext' - -performing :: Eq var => Action var -> TypeCheck var a -> TypeCheck var a -performing action tc = do - ctx@Context{..} <- ask - unless (length actionStack < 1000) $ -- FIXME: which depth is reasonable? factor out into a parameter - issueTypeError $ TypeErrorOther "maximum depth reached" - traceTypeCheck Debug (ppSomeAction (varOrigs ctx) (length actionStack) action) $ - local (const Context { actionStack = action : actionStack, .. }) $ tc - -stripTypeRestrictions :: TermT var -> TermT var -stripTypeRestrictions (TypeRestrictedT _ty ty _restriction) = stripTypeRestrictions ty -stripTypeRestrictions t = t - --- | Perform at most one \(\eta\)-expansion at the top-level to assist unification. -etaMatch :: Eq var => Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var (TermT var, TermT var) --- FIXME: double check the next 3 rules -etaMatch _mterm expected@TypeRestrictedT{} actual@TypeRestrictedT{} = pure (expected, actual) -etaMatch mterm expected (TypeRestrictedT _ty ty _rs) = etaMatch mterm expected ty -etaMatch (Just term) expected@TypeRestrictedT{} actual = - etaMatch (Just term) expected (typeRestrictedT actual [(topeTopT, term)]) --- ------------------------------------ --- | Subtyping on interval -etaMatch _mterm CubeIT{} Cube2T{} = pure (cubeIT, cubeIT) --- ------------------------------------ -etaMatch _mterm expected@LambdaT{} actual@LambdaT{} = pure (expected, actual) -etaMatch _mterm expected@PairT{} actual@PairT{} = pure (expected, actual) -etaMatch _mterm expected@LambdaT{} actual = do - actual' <- etaExpand actual - pure (expected, actual') -etaMatch _mterm expected actual@LambdaT{} = do - expected' <- etaExpand expected - pure (expected', actual) -etaMatch _mterm expected@PairT{} actual = do - actual' <- etaExpand actual - pure (expected, actual') -etaMatch _mterm expected actual@PairT{} = do - expected' <- etaExpand expected - pure (expected', actual) -etaMatch _mterm expected actual = pure (expected, actual) - -etaExpand :: Eq var => TermT var -> TypeCheck var (TermT var) -etaExpand term@LambdaT{} = pure term -etaExpand term@PairT{} = pure term -etaExpand term = do - ty <- typeOf term - case stripTypeRestrictions ty of - TypeFunT _ty orig md param mtope ret -> pure $ - lambdaT ty orig (Just (md, param, mtope)) - (appT ret (S <$> term) (Pure Z)) - - TypeSigmaT _ty _orig _md a b -> pure $ - pairT ty - (firstT a term) - (secondT (substituteT (firstT a term) b) term) - - CubeProductT _ty a b -> pure $ - pairT ty - (firstT a term) - (secondT b term) - - _ -> pure term - -inCubeLayer :: Eq var => TermT var -> TypeCheck var Bool -inCubeLayer = \case - RecBottomT{} -> pure False - UniverseT{} -> pure False - - UniverseCubeT{} -> pure True - CubeProductT{} -> pure True - CubeUnitT{} -> pure True - CubeUnitStarT{} -> pure True - Cube2T{} -> pure True - Cube2_0T{} -> pure True - Cube2_1T{} -> pure True - - t -> typeOf t >>= inCubeLayer - -inTopeLayer :: Eq var => TermT var -> TypeCheck var Bool -inTopeLayer = \case - RecBottomT{} -> pure False - UniverseT{} -> pure False - - UniverseCubeT{} -> pure True - UniverseTopeT{} -> pure True - - CubeProductT{} -> pure True - CubeUnitT{} -> pure True - CubeUnitStarT{} -> pure True - Cube2T{} -> pure True - Cube2_0T{} -> pure True - Cube2_1T{} -> pure True - - TopeTopT{} -> pure True - TopeBottomT{} -> pure True - TopeAndT{} -> pure True - TopeOrT{} -> pure True - TopeEQT{} -> pure True - TopeLEQT{} -> pure True - - TypeFunT _ty orig md param _mtope ret -> do - enterScope orig md param $ inTopeLayer ret - - t -> typeOfUncomputed t >>= inTopeLayer - -tryRestriction :: Eq var => TermT var -> TypeCheck var (Maybe (TermT var)) -tryRestriction = \case - TypeRestrictedT _ _ rs -> do - let go [] = pure Nothing - go ((tope, term') : rs') = do - checkTope tope >>= \case - True -> pure (Just term') - False -> go rs' - go rs - _ -> pure Nothing - --- | Memoise a term's WHNF on its top node without reducing the term itself. --- --- The returned term has the same (unreduced) structure, so free-variable and --- @uses@ detection see exactly what the user wrote, while a later 'whnfT' is --- O(1) via the cached 'infoWHNF'. Used when storing a definition's elaborated --- type and value, where an in-place reduction could otherwise discard or --- expose a variable occurrence. -memoizeWHNF :: Eq var => TermT var -> TypeCheck var (TermT var) -memoizeWHNF t@Pure{} = pure t -memoizeWHNF t@(Free (AnnF info f)) = do - w <- whnfT t - pure (Free (AnnF info { infoWHNF = Just w } f)) - --- | Compute a typed term to its WHNF. --- --- >>> unsafeTypeCheck' $ whnfT "(\\ (x : Unit) -> x) unit" --- unit : Unit -whnfT :: Eq var => TermT var -> TypeCheck var (TermT var) -whnfT tt = performing (ActionWHNF tt) $ case tt of - -- use cached result if it exists - Free (AnnF info _) - | Just tt' <- infoWHNF info -> pure tt' - - -- universe constants - UniverseT{} -> pure tt - UniverseCubeT{} -> pure tt - UniverseTopeT{} -> pure tt - - -- cube layer (except vars, pairs, and applications) - CubeProductT{} -> nfTope tt - CubeUnitT{} -> pure tt - CubeUnitStarT{} -> pure tt - Cube2T{} -> pure tt - Cube2_0T{} -> pure tt - Cube2_1T{} -> pure tt - CubeIT{} -> pure tt - CubeI_0T{} -> pure tt - CubeI_1T{} -> pure tt - CubeFlipT{} -> nfTope tt - CubeUnflipT{} -> nfTope tt - - -- tope layer (except vars, pairs of points, and applications) - TopeTopT{} -> pure tt - TopeBottomT{} -> pure tt - TopeAndT{} -> nfTope tt - TopeOrT{} -> nfTope tt - TopeEQT{} -> nfTope tt - TopeLEQT{} -> nfTope tt - TopeInvT{} -> nfTope tt - TopeUninvT{} -> nfTope tt - - -- type layer terms that should not be evaluated further - LambdaT{} -> pure tt - PairT{} -> pure tt - ReflT{} -> pure tt - TypeFunT{} -> pure tt - TypeSigmaT{} -> pure tt - TypeIdT{} -> pure tt - TypeModalT{} -> pure tt - RecBottomT{} -> pure tt - TypeUnitT{} -> pure tt - UnitT{} -> pure tt - - -- type ascriptions are ignored, since we already have a typechecked term - TypeAscT _ty term _ty' -> whnfT term - - -- check if we have cube or a tope term (if so, compute NF) - _ -> typeOf tt >>= \case - UniverseCubeT{} -> nfTope tt - UniverseTopeT{} -> nfTope tt - - -- CubeUnitT{} -> pure cubeUnitStarT -- compute an expression of 1 cube to its only point - TypeUnitT{} -> pure unitT -- compute an expression of Unit type to unit - -- FIXME: next line is ad hoc, should be improved! - TypeRestrictedT _info TypeUnitT{} _rs -> pure unitT -- compute an expression of Unit type to unit - - -- check if we have cube point term (if so, compute NF) - typeOf_tt -> typeOf typeOf_tt >>= \case - UniverseCubeT{} -> nfTope tt - - -- now we are in the type layer - _ -> fmap termIsWHNF $ do - tryRestriction typeOf_tt >>= \case - Just tt' -> whnfT tt' - Nothing -> case tt of - -- a hole is opaque: it never reduces, it is already a normal form - HoleT{} -> pure tt - t@(Pure var) -> - valueOfVar var >>= \case - Nothing -> pure t - Just term -> whnfT term - - AppT ty f x -> - whnfT f >>= \case - LambdaT _ty _orig _arg body -> - whnfT (substituteT x body) - f' -> typeOf f' >>= \case - TypeFunT _ty _orig md _param (Just tope) UniverseTopeT{} -> do - x' <- enterModality md $ nfT x - topeAndT - <$> pure (AppT ty f' x') - <*> nfT (substituteT x' tope) - -- FIXME: this seems to be a hack, and will not work in all situations! - -- FIXME: need to check performance of this code thoroughly - -- FIXME: for now, it seems to add ~2x slowdown - TypeFunT info _orig md _param _mtope ret@TypeRestrictedT{} - | TypeRestrictedT{} <- infoType info -> pure (AppT ty f' x) - | otherwise -> do - x' <- enterModality md $ whnfT x - let ret' = substituteT x' ret - tryRestriction ret' >>= \case -- FIXME: too many unnecessary checks? - Nothing -> pure (AppT ty { infoType = ret' } f' x') - Just tt' -> whnfT tt' - _ -> pure (AppT ty f' x) - - LetT _ty _orig _mparam val body -> - whnfT (substituteT val body) - LetModT ty orig app inn mparam val body -> do - (enterModality app $ whnfT val) >>= \case - ModAppT _ md t | md == inn -> do - val' <- enterModality md $ whnfT t - whnfT (substituteT val' body) - b' | isRA inn -> do - bty <- typeOf b' >>= \case - TypeModalT _ _ t -> pure t - _ -> panicImpossible "not modal in letmod" - whnfT (substituteT (modExtractT bty app inn b') body) - _ -> pure (LetModT ty orig app inn mparam val body) - FirstT ty t -> - whnfT t >>= \case - PairT _ l _r -> whnfT l - t' -> pure (FirstT ty t') - - SecondT ty t -> - whnfT t >>= \case - PairT _ _l r -> whnfT r - t' -> pure (SecondT ty t') - ModAppT ty md b -> do - (enterModality md $ whnfT b) >>= \case - ModExtractT _ app inn t | inn == md -> enterModality (comp md app) $ whnfT t - b' -> pure $ ModAppT ty md b' - ModExtractT ty app inn b -> do - (enterModality app $ whnfT b) >>= \case - ModAppT _ md t | inn == md -> enterModality inn $ whnfT t - b' -> pure (ModExtractT ty app inn b') - IdJT ty tA a tC d x p -> - whnfT p >>= \case - ReflT{} -> whnfT d - p' -> pure (IdJT ty tA a tC d x p') - - RecOrT _ty rs -> do - let go [] = pure Nothing - go ((tope, tt') : rs') = do - checkTope tope >>= \case - True -> pure (Just tt') - False -> go rs' - go rs >>= \case - Just tt' -> whnfT tt' - Nothing - | [tt'] <- nubTermT (map snd rs) -> whnfT tt' - | otherwise -> pure tt - - TypeRestrictedT ty type_ rs -> do - rs' <- traverse (\(tope, term) -> (,) <$> nfT tope <*> pure term) rs - case filter ((/= topeBottomT) . fst) rs' of - [] -> whnfT type_ -- get rid of restrictions at BOT - rs'' -> TypeRestrictedT ty <$> whnfT type_ <*> pure rs'' - -nfTope :: Eq var => TermT var -> TypeCheck var (TermT var) -nfTope tt = performing (ActionNF tt) $ fmap termIsNF $ case tt of - HoleT{} -> pure tt - Pure var -> - valueOfVar var >>= \case - Nothing -> return tt - Just term -> nfTope term - - -- see if normal form is already available - Free (AnnF info _) | Just tt' <- infoNF info -> pure tt' - - -- universe constants - UniverseT{} -> pure tt - UniverseCubeT{} -> pure tt - UniverseTopeT{} -> pure tt - - -- cube layer constants - CubeUnitT{} -> pure tt - CubeUnitStarT{} -> pure tt - Cube2T{} -> pure tt - Cube2_0T{} -> pure tt - Cube2_1T{} -> pure tt - CubeIT{} -> pure tt - CubeI_0T{} -> pure tt - CubeI_1T{} -> pure tt - - -- type layer constants - TypeUnitT{} -> pure tt - UnitT{} -> pure tt - - -- cube layer with computation - CubeProductT _ty l r -> cubeProductT <$> nfTope l <*> nfTope r - - CubeFlipT ty t -> - nfTope t >>= \case - CubeUnflipT _ t' -> pure t' - Cube2_0T{} -> pure (modAppT (typeModalT cubeT Op cube2T) Op cube2_1T) - Cube2_1T{} -> pure (modAppT (typeModalT cubeT Op cube2T) Op cube2_0T) - CubeI_0T{} -> pure (modAppT (typeModalT cubeT Op cubeIT) Op cubeI_1T) - CubeI_1T{} -> pure (modAppT (typeModalT cubeT Op cubeIT) Op cubeI_0T) - t' -> pure (CubeFlipT ty t') - - CubeUnflipT ty t -> - nfTope t >>= \case - CubeFlipT _ t' -> pure t' - ModAppT _ Op Cube2_0T{} -> pure cube2_1T - ModAppT _ Op Cube2_1T{} -> pure cube2_0T - ModAppT _ Op CubeI_0T{} -> pure cubeI_1T - ModAppT _ Op CubeI_1T{} -> pure cubeI_0T - t' -> pure (CubeUnflipT ty t') - - -- tope layer constants - TopeTopT{} -> pure tt - TopeBottomT{} -> pure tt - - -- tope layer with computation - TopeAndT ty l r -> - nfTope l >>= \case - TopeBottomT{} -> pure topeBottomT - l' -> nfTope r >>= \case - TopeBottomT{} -> pure topeBottomT - r' -> pure (TopeAndT ty l' r') - - TopeOrT ty l r -> do - l' <- nfTope l - r' <- nfTope r - case (l', r') of - (TopeBottomT{}, _) -> pure r' - (_, TopeBottomT{}) -> pure l' - _ -> pure (TopeOrT ty l' r') - - TopeEQT ty l r -> TopeEQT ty <$> nfTope l <*> nfTope r - TopeLEQT ty l r -> TopeLEQT ty <$> nfTope l <*> nfTope r - - TopeInvT ty t -> - -- Match And/Or on the *unnormalized* input: nfTope of a shape-restricted - -- App produces a TopeAnd via shape-side-condition propagation, and - -- distributing inv over that synthetic conjunction loops forever because - -- the recursive topeInvT renormalizes the same App back into a TopeAnd. - case t of - TopeTopT _ -> pure $ modAppT topeT Op topeTopT - TopeBottomT _ -> pure $ modAppT topeT Op topeBottomT - TopeLEQT _ x y -> do - xTy <- typeOf x - yTy <- typeOf y - nfTope $ - modAppT (typeModalT universeT Op topeT) Op - (topeLEQT - (modExtractT topeT Id Op (cubeFlipT xTy y)) - (modExtractT topeT Id Op (cubeFlipT yTy x))) - TopeEQT _ x y -> do - xTy <- typeOf x - yTy <- typeOf y - nfTope $ - modAppT (typeModalT universeT Op topeT) Op - (topeEQT - (modExtractT topeT Id Op (cubeFlipT xTy y)) - (modExtractT topeT Id Op (cubeFlipT yTy x))) - TopeAndT _ phi psi -> nfTope $ - modAppT (typeModalT universeT Op topeT) Op - (topeAndT - (modExtractT topeT Id Op (topeInvT phi)) - (modExtractT topeT Id Op (topeInvT psi))) - TopeOrT _ phi psi -> nfTope $ - modAppT (typeModalT universeT Op topeT) Op - (topeOrT - (modExtractT topeT Id Op (topeInvT phi)) - (modExtractT topeT Id Op (topeInvT psi))) - _ -> - nfTope t >>= \case - TopeTopT _ -> pure topeTopT - TopeBottomT _ -> pure topeBottomT - TopeUninvT _ phi -> pure phi - TopeLEQT _ x y -> do - xTy <- typeOf x - yTy <- typeOf y - nfTope $ - modAppT (typeModalT universeT Op topeT) Op - (topeLEQT - (modExtractT topeT Id Op (cubeFlipT xTy y)) - (modExtractT topeT Id Op (cubeFlipT yTy x))) - TopeEQT _ x y -> do - xTy <- typeOf x - yTy <- typeOf y - nfTope $ - modAppT (typeModalT universeT Op topeT) Op - (topeEQT - (modExtractT topeT Id Op (cubeFlipT xTy y)) - (modExtractT topeT Id Op (cubeFlipT yTy x))) - t' -> pure (TopeInvT ty t') - - TopeUninvT ty t -> - case t of - ModAppT _ Op inner -> case inner of - TopeTopT _ -> pure topeTopT - TopeBottomT _ -> pure topeBottomT - TopeAndT _ phi psi -> - nfTope $ - (topeAndT - (topeUninvT phi) - (topeUninvT psi)) - TopeOrT _ phi psi -> - nfTope $ - (topeOrT - (topeUninvT phi) - (topeUninvT psi)) - _ -> - nfTope t >>= \case - TopeTopT _ -> pure topeTopT - TopeBottomT _ -> pure topeBottomT - TopeInvT _ phi -> pure phi - ModAppT _ Op inner'' -> case inner'' of - TopeLEQT _ x y -> do - xTy <- typeOf x - yTy <- typeOf y - nfTope $ - (topeLEQT - (cubeUnflipT xTy (modAppT (typeModalT cubeT Op xTy) Op y)) - (cubeUnflipT yTy (modAppT (typeModalT cubeT Op yTy) Op x))) - TopeEQT _ x y -> do - xTy <- typeOf x - yTy <- typeOf y - nfTope $ - (topeEQT - (cubeUnflipT xTy (modAppT (typeModalT cubeT Op xTy) Op y)) - (cubeUnflipT yTy (modAppT (typeModalT cubeT Op yTy) Op x))) - inner' -> - pure $ - TopeUninvT ty - (modAppT (typeModalT universeT Op topeT) Op inner') - t' -> - pure (TopeUninvT ty t') - _ -> - nfTope t >>= \case - TopeInvT _ phi -> pure phi - t'@(ModAppT _ Op _) -> nfTope (TopeUninvT ty t') - t' -> pure (TopeUninvT ty t') - - -- type ascriptions are ignored, since we already have a typechecked term - TypeAscT _ty term _ty' -> nfTope term - - PairT ty l r -> PairT ty <$> nfTope l <*> nfTope r - - AppT ty f x -> - nfTope f >>= \case - LambdaT _ty _orig _arg body -> - nfTope (substituteT x body) - f' -> typeOfUncomputed f' >>= \case - TypeFunT _ty _orig md _param (Just tope) UniverseTopeT{} -> do - x' <- enterModality md $ nfTope x - topeAndT - <$> pure (AppT ty f' x') - <*> nfTope (substituteT x' tope) - _ -> AppT ty f' <$> nfTope x - - FirstT ty t -> - nfTope t >>= \case - PairT _ty x _y -> pure x - t' -> pure (FirstT ty t') - - SecondT ty t -> - nfTope t >>= \case - PairT _ty _x y -> pure y - t' -> pure (SecondT ty t') - - LambdaT ty orig _mparam body - | TypeFunT _ty _origF md param mtope _ret <- infoType ty -> - -- NOTE: the domain @param@ is left unnormalised: in the tope layer it may - -- be a shape (a function type into TOPE), which nfTope cannot normalise. - LambdaT ty orig (Just (md, param, mtope)) <$> enterScope orig md param (nfTope body) - LambdaT{} -> panicImpossible "lambda with a non-function type in the tope layer" - ModAppT ty md b -> - (enterModality md $ nfTope b) >>= \case - ModExtractT _ _ inn t | inn == md -> pure t - b' -> pure $ ModAppT ty md b' - ModExtractT ty app inn b -> - (enterModality app $ nfTope b) >>= \case - ModAppT _ md t | inn == md -> pure t - b' -> pure $ ModExtractT ty app inn b' - LetModT ty orig app inn mparam val body -> do - (enterModality app $ nfTope val) >>= \case - ModAppT _ md t | md == inn -> do - val' <- return t - nfTope (substituteT val' body) - b' | isRA inn -> do - bty <- typeOf b' >>= \case - TypeModalT _ _ t -> pure t - _ -> panicImpossible "not modal in letmod" - nfTope (substituteT (modExtractT bty app inn b') body) - b' -> do - bty <- typeOf b' >>= \case - TypeModalT _ _ t -> pure t - _ -> panicImpossible "not modal in letmod" - val' <- enterModality app $ nfTope b' - body' <- enterScope orig (comp app inn) bty $ nfTope body - pure (LetModT ty orig app inn mparam val' body') - - TypeModalT ty md inner -> TypeModalT ty md <$> (enterModality md $ nfTope inner) - LetT _ty _orig _mparam val body -> nfTope (substituteT val body) - TypeFunT{} -> panicImpossible "exposed function type in the tope layer" - TypeSigmaT{} -> panicImpossible "dependent sum type in the tope layer" - TypeIdT{} -> panicImpossible "identity type in the tope layer" - ReflT{} -> panicImpossible "refl in the tope layer" - IdJT{} -> panicImpossible "idJ eliminator in the tope layer" - TypeRestrictedT{} -> panicImpossible "extension types in the tope layer" - - -- A recOR/recBOT is a term-level eliminator, never a tope. It should have - -- been rejected before reaching here (see the RecOr case of 'typecheck'); as - -- a safety net for any other path, report a type error rather than panicking. - RecOrT{} -> issueTypeError $ TypeErrorOther "a recOR cannot appear in the tope layer" - RecBottomT{} -> issueTypeError $ TypeErrorOther "a recBOT cannot appear in the tope layer" - --- | Compute a typed term to its NF. --- --- >>> unsafeTypeCheck' $ nfT "(\\ (x : Unit) -> x) unit" --- unit : Unit -nfT :: Eq var => TermT var -> TypeCheck var (TermT var) -nfT tt = performing (ActionNF tt) $ case tt of - -- universe constants - UniverseT{} -> pure tt - UniverseCubeT{} -> pure tt - UniverseTopeT{} -> pure tt - - -- cube layer constants - CubeUnitT{} -> pure tt - CubeUnitStarT{} -> pure tt - Cube2T{} -> pure tt - Cube2_0T{} -> pure tt - Cube2_1T{} -> pure tt - CubeIT{} -> pure tt - CubeI_0T{} -> pure tt - CubeI_1T{} -> pure tt - - -- cube layer with computation - CubeProductT{} -> nfTope tt - CubeFlipT{} -> nfTope tt - CubeUnflipT{} -> nfTope tt - - -- tope layer constants - TopeTopT{} -> pure tt - TopeBottomT{} -> pure tt - - -- tope layer with computation - TopeAndT{} -> nfTope tt - TopeOrT{} -> nfTope tt - TopeEQT{} -> nfTope tt - TopeLEQT{} -> nfTope tt - TopeInvT{} -> nfTope tt - TopeUninvT{} -> nfTope tt - - -- type layer constants - ReflT ty _x -> pure (ReflT ty Nothing) - RecBottomT{} -> pure tt - TypeUnitT{} -> pure tt - UnitT{} -> pure tt - - -- type ascriptions are ignored, since we already have a typechecked term - TypeAscT _ty term _ty' -> nfT term - - -- now we are in the type layer - _ -> do - typeOf tt >>= tryRestriction >>= \case - Just tt' -> nfT tt' - Nothing -> case tt of - -- a hole is opaque: it never reduces, it is already a normal form - HoleT{} -> pure tt - t@(Pure var) -> - valueOfVar var >>= \case - Nothing -> pure t - Just term -> nfT term - - TypeFunT ty orig md param mtope ret -> do - param' <- enterModality md $ nfT param - enterScope orig md param' $ do - mtope' <- traverse nfT mtope - maybe id localTope mtope' $ - TypeFunT ty orig md param' mtope' <$> nfT ret - AppT ty f x -> - whnfT f >>= \case - LambdaT _ty _orig _arg body -> - nfT (substituteT x body) - f' -> typeOf f' >>= \case - TypeFunT _ty _orig md _param (Just tope) UniverseTopeT{} -> do - x' <- enterModality md $ nfT x - topeAndT - <$> pure (AppT ty f' x') - <*> nfT (substituteT x' tope) - _ -> AppT ty <$> nfT f' <*> nfT x - LetT _ty _orig _mparam val body -> - nfT (substituteT val body) - LetModT ty orig app inn mparam val body -> do - (enterModality app $ whnfT val) >>= \case - ModAppT _ md t | md == inn -> do - val' <- enterModality md $ nfT t - nfT (substituteT val' body) - b' | isRA inn -> do - bty <- typeOf b' >>= \case - TypeModalT _ _ t -> pure t - _ -> panicImpossible "not modal in letmod" - nfT (substituteT (modExtractT bty app inn b') body) - b' -> do - bty <- typeOf b' >>= \case - TypeModalT _ _ t -> pure t - _ -> panicImpossible "not modal in letmod" - val' <- enterModality app $ nfT b' - body' <- enterScope orig (comp app inn) bty $ nfT body - pure (LetModT ty orig app inn mparam val' body') - LambdaT ty orig _mparam body -> do - case stripTypeRestrictions (infoType ty) of - TypeFunT _ty _orig md param mtope _ret -> do - param' <- enterModality md $ nfT param - enterScope orig md param' $ do - mtope' <- traverse nfT mtope - maybe id localTope mtope' $ - LambdaT ty orig (Just (md, param', mtope')) <$> nfT body - _ -> panicImpossible "lambda with a non-function type" - - - TypeSigmaT ty orig md a b -> do - a' <- enterModality md $ nfT a - enterScope orig md a' $ do - TypeSigmaT ty orig md a' <$> nfT b - PairT ty l r -> PairT ty <$> nfT l <*> nfT r - FirstT ty t -> - whnfT t >>= \case - PairT _ l _r -> nfT l - t' -> FirstT ty <$> nfT t' - SecondT ty t -> - whnfT t >>= \case - PairT _ _l r -> nfT r - t' -> SecondT ty <$> nfT t' - - TypeIdT ty x _tA y -> TypeIdT ty <$> nfT x <*> pure Nothing <*> nfT y - IdJT ty tA a tC d x p -> - whnfT p >>= \case - ReflT{} -> nfT d - p' -> IdJT ty <$> nfT tA <*> nfT a <*> nfT tC <*> nfT d <*> nfT x <*> nfT p' - - RecOrT _ty rs -> do - let go [] = pure Nothing - go ((tope, tt') : rs') = do - checkTope tope >>= \case - True -> pure (Just tt') - False -> go rs' - go rs >>= \case - Just tt' -> nfT tt' - Nothing - | [tt'] <- nubTermT (map snd rs) -> nfT tt' - | otherwise -> pure tt - TypeModalT ty md b -> do - b' <- enterModality md $ nfT b - pure (TypeModalT ty md b') - ModAppT ty md b -> do - (enterModality md $ whnfT b) >>= \case - ModExtractT _ app inn t | inn == md -> enterModality (comp app inn) $ nfT t - b' -> ModAppT ty md <$> (enterModality md $ nfT b') - ModExtractT ty app inn b -> do - (enterModality app $ whnfT b) >>= \case - ModAppT _ md t | inn == md -> enterModality (comp app inn) $ nfT t - b' -> ModExtractT ty app inn <$> (enterModality app $ nfT b') - TypeRestrictedT ty type_ rs -> do - rs' <- forM rs $ \(tope, term) -> do - nfTope tope >>= \case - TopeBottomT{} -> pure Nothing - tope' -> do - term' <- localTope tope' $ - nfT term - return (Just (tope', term')) - case catMaybes rs' of - [] -> nfT type_ - rs'' -> TypeRestrictedT ty <$> nfT type_ <*> pure rs'' - --- | Look up a variable and project one field of its 'VarInfo'; the shared --- shape of the per-variable accessors below. -infoOfVar :: Eq var => (VarInfo var -> a) -> var -> TypeCheck var a -infoOfVar f x = asks (lookupVarInfo x) >>= \case - Nothing -> issueTypeError $ TypeErrorUndefined x - Just info -> return (f info) - -checkDefinedVar :: VarIdent -> TypeCheck VarIdent () -checkDefinedVar = infoOfVar (const ()) - -valueOfVar :: Eq var => var -> TypeCheck var (Maybe (TermT var)) -valueOfVar = infoOfVar varValue - -typeOfVar :: Eq var => var -> TypeCheck var (TermT var) -typeOfVar = infoOfVar varType - -modalityOfVar :: Eq var => var -> TypeCheck var (TModality) -modalityOfVar = infoOfVar varModality - -locksOfVar :: Eq var => var -> TypeCheck var (TModality) -locksOfVar = infoOfVar modAccum - -isTopLevelVar :: Eq var => var -> TypeCheck var Bool -isTopLevelVar = infoOfVar varIsTopLevel - -typeOfUncomputed :: Eq var => TermT var -> TypeCheck var (TermT var) -typeOfUncomputed = \case - Pure x -> typeOfVar x - Free (AnnF TypeInfo{..} _) -> pure infoType - -typeOf :: Eq var => TermT var -> TypeCheck var (TermT var) -typeOf t = typeOfUncomputed t >>= whnfT - -unifyTopes :: Eq var => TermT var -> TermT var -> TypeCheck var () -unifyTopes l r = do - equiv <- (&&) - <$> [plainTope l] `entailM` r - <*> [plainTope r] `entailM` l - unless equiv $ - issueTypeError (TypeErrorTopesNotEquivalent l r) - -inAllSubContexts :: Eq var => TypeCheck var () -> TypeCheck var () -> TypeCheck var () -inAllSubContexts handleSingle tc = do - topeSubContexts <- asks localTopesNFUnion - case topeSubContexts of - [] -> panicImpossible "empty set of alternative contexts" - [_] -> handleSingle - _:_:_ -> do - forM_ topeSubContexts $ \topes' -> do - withRefreshedTopes (\Context{..} -> Context - { localTopes = topes' - , localTopesNF = topes' - , localTopesNFUnion = [topes'] - , .. }) $ - tc - -unify :: Eq var => Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var () -unify mterm expected actual = performUnification `catchError` \typeError -> do - inAllSubContexts (throwError typeError) performUnification - where - performUnification = unifyInCurrentContext mterm expected actual - -unifyViaDecompose :: Eq var => TermT var -> TermT var -> TypeCheck var () -unifyViaDecompose expected actual | expected == actual = return () -unifyViaDecompose (AppT _ f x) (AppT _ g y) = do - unify Nothing f g - setVariance Invariant $ unify Nothing x y -unifyViaDecompose _ _ = issueTypeError (TypeErrorOther "cannot decompose") - -unifyInCurrentContext :: Eq var => Maybe (TermT var) -> TermT var -> TermT var -> TypeCheck var () -unifyInCurrentContext mterm expected actual = performing action $ do - inBottom <- contextEntailsBottom - unless inBottom $ - unifyViaDecompose expected actual `catchError` \_ -> do -- NOTE: this gives a small, but noticeable speedup - expectedVal <- whnfT expected - actualVal <- whnfT actual - mea <- asks covariance >>= \case - Covariant -> Just <$> etaMatch mterm expectedVal actualVal - Contravariant -> Just . swap <$> etaMatch mterm actualVal expectedVal - Invariant -> traceTypeCheck Debug "invariant" $ do - -- FIXME: inefficient - traceTypeCheck Debug "invariant->covariant" $ - setVariance Covariant $ unifyInCurrentContext mterm expectedVal actualVal - traceTypeCheck Debug "invariant->contravariant" $ - setVariance Contravariant $ unifyInCurrentContext mterm expectedVal actualVal - return Nothing - case mea of - Nothing -> return () - -- A hole (lenient mode) stands for a term of the expected type, so it - -- unifies with anything; accept it instead of falling through to the - -- dispatch below (which would panic on an unexpected term). - Just (expected', actual') | isHoleT expected' || isHoleT actual' -> return () - Just (expected', actual') -> - unless (expected' == actual') $ do -- NOTE: this gives a small, but noticeable speedup - case actual' of - RecBottomT{} -> return () - RecOrT _ty rs' -> - case expected' of - RecOrT _ty rs -> sequence_ $ - checkCoherence <$> rs <*> rs' - _ -> do - forM_ rs' $ \(tope, term) -> - localTope tope $ - unifyTerms expected' term - _ -> typeOf expected' >>= typeOf >>= \case - UniverseCubeT{} -> contextEntails (topeEQT expected' actual') - _ -> do - -- A hole stands for a term of the expected type, so a - -- unification that would otherwise fail is deferred when either - -- side still contains an (unfilled) hole — including one nested - -- in a larger term, e.g. @f ?@ checked against an extension-type - -- boundary. The hole may also sit in the tope context rather - -- than the terms: a hole standing for a whole shape point makes - -- the enclosing 'recOR' split over hole-dependent faces, and a - -- branch reduction can drop the hole from the terms while the - -- assumed face (e.g. @π₁ ? ≤ π₂ ?@) still mentions it. Such a - -- branch is only entered because the hole is unfilled, so a - -- mismatch under it is deferred too. 'structuralHoleUnify' turns - -- this off, keeping a structural mismatch around a hole an - -- error. Lazy: only runs on the failure path. - defer <- asks deferHoleMismatches - topeContextHasHole <- asks (any (containsHole . tTope) . localTopes) - let def = unless (expected' == actual') err - holePresent = defer && - (containsHole expected' || containsHole actual' || topeContextHasHole) - err - | holePresent = return () - | otherwise = - case mterm of - Nothing -> issueTypeError (TypeErrorUnifyTerms expected' actual') - Just term -> issueTypeError (TypeErrorUnify term expected' actual') - errS - | holePresent = return () - | otherwise = do - let expectedS = S <$> expected' - actualS = S <$> actual' - case mterm of - Nothing -> issueTypeError (TypeErrorUnifyTerms expectedS actualS) - Just term -> issueTypeError (TypeErrorUnify (S <$> term) expectedS actualS) - case expected' of - Pure{} -> def - - UniverseT{} -> def - UniverseCubeT{} -> def - UniverseTopeT{} -> def - - TypeUnitT{} -> def - UnitT{} -> return () -- Unit always unifies! - - CubeUnitT{} -> def - CubeUnitStarT{} -> def - Cube2T{} -> def - Cube2_0T{} -> def - Cube2_1T{} -> def - CubeIT{} -> def - CubeI_0T{} -> def - CubeI_1T{} -> def - CubeProductT _ l r -> - case actual' of - CubeProductT _ l' r' -> do - unifyTerms l l' - unifyTerms r r' - _ -> err - - PairT _ty l r -> - case actual' of - PairT _ty' l' r' -> do - unifyTerms l l' - unifyTerms r r' - - -- one part of eta-expansion for pairs - -- FIXME: add symmetric version! - _ -> err - - FirstT _ty t -> - case actual' of - FirstT _ty' t' -> unifyTerms t t' - _ -> err - - SecondT _ty t -> - case actual' of - SecondT _ty' t' -> unifyTerms t t' - _ -> err - - TopeTopT{} -> unifyTopes expected' actual' - TopeBottomT{} -> unifyTopes expected' actual' - TopeEQT{} -> unifyTopes expected' actual' - TopeLEQT{} -> unifyTopes expected' actual' - TopeAndT{} -> unifyTopes expected' actual' - TopeOrT{} -> unifyTopes expected' actual' - - RecBottomT{} -> return () -- unifies with anything - RecOrT _ty rs -> - case actual' of - -- ---------------------------------------------- - -- IMPORTANT: this pattern matching is redundant, - -- but it is not obvious, so - -- take care when refactoring! - -- ---------------------------------------------- - -- RecOrT _ty rs' -> sequence_ $ - -- checkCoherence <$> rs <*> rs' - -- ---------------------------------------------- - _ -> do - forM_ rs $ \(tope, term) -> - localTope tope $ - unifyTerms term actual' - - TypeFunT _ty _orig md cube mtope ret -> - case actual' of - TypeFunT _ty' orig' md' cube' mtope' ret' -> do - when (md /= md') $ - issueTypeError (TypeErrorOther $ "modality mismatch in function type: expected " <> show md <> " but got " <> show md') - switchVariance $ -- unifying in the negative position! - unifyTerms cube cube' -- FIXME: unifyCubes - enterScope orig' md cube' $ do - -- The tope checks below are subtyping checks with a fixed - -- direction relative to (subtype, supertype). Which side is - -- the subtype depends on the ambient variance: under - -- Covariant the actual type must be a subtype of the - -- expected one; under Contravariant (inside a domain) the - -- roles are reversed. Invariant is normally handled - -- upstream by running both directions; it is handled here - -- as well for safety. - variance <- asks covariance - case ret' of - UniverseTopeT{} -> do - -- This is the case for tope families (shapes) - -- - -- (Λ → TOPE) <: (Δ → TOPE) - -- since if φ : Λ → TOPE - -- then φ ⊢ Δ - -- - -- we DO NOT take tope context Φ into account! - expectedTopeNF <- fromMaybe topeTopT <$> traverse nfT mtope - actualTopeNF <- fromMaybe topeTopT <$> traverse nfT mtope' - let subEntailsSuper subNF superNF = do - entails <- [plainTope subNF] `entailM` superNF - unless (entails || containsHole subNF || containsHole superNF) $ - issueTypeError (TypeErrorTopeNotSatisfied [subNF] superNF) - case variance of - Covariant -> subEntailsSuper actualTopeNF expectedTopeNF - Contravariant -> subEntailsSuper expectedTopeNF actualTopeNF - Invariant -> do - subEntailsSuper actualTopeNF expectedTopeNF - subEntailsSuper expectedTopeNF actualTopeNF - _ -> do - -- this is the case for Π-types and extension types - -- - -- Ξ | Φ | Γ ⊢ {t : I | φ} → A t <: {s : J | ψ} → B s - -- when - -- Ξ | Φ, ψ ⊢ φ - expectedTopeNF <- fromMaybe topeTopT <$> traverse nfT mtope - actualTopeNF <- fromMaybe topeTopT <$> traverse nfT mtope' - let superEntailsSub superNF subNF = - localTope superNF $ - contextEntails subNF - case variance of - Covariant -> superEntailsSub expectedTopeNF actualTopeNF - Contravariant -> superEntailsSub actualTopeNF expectedTopeNF - Invariant -> do - superEntailsSub expectedTopeNF actualTopeNF - superEntailsSub actualTopeNF expectedTopeNF - case mterm of - Nothing -> unifyTerms ret ret' - Just term -> unifyTypes (appT ret' (S <$> term) (Pure Z)) ret ret' - _ -> err - - TypeSigmaT _ty _orig md a b -> - case actual' of - TypeSigmaT _ty' orig' md' a' b' -> do - when (md /= md') $ - issueTypeError (TypeErrorOther $ "modality mismatch in sigma type: expected " <> show md <> " but got " <> show md') - unify Nothing a a' - enterScope orig' md a' $ unify Nothing b b' - _ -> err - - TypeIdT _ty x tA y -> - case actual' of - TypeIdT _ty' x' tA' y' -> do - -- The underlying types must be compared: without this - -- check the routine equates identity types over - -- different types whenever the endpoints unify, - -- accepting e.g. a free homotopy (a path in the type - -- of functions) where an endpoint-fixing one (a path - -- in a hom-type) is expected. Compared invariantly: - -- subtyping between the underlying types must not - -- leak into equality of identity types over them. - mapM_ (\(t1, t2) -> setVariance Invariant (unify Nothing t1 t2)) - ((,) <$> tA <*> tA') - unify Nothing x x' - unify Nothing y y' - _ -> err - - AppT _ty f x -> - case actual' of - AppT _ty' f' x' -> do - unify Nothing f f' - setVariance Invariant $ - unify Nothing x x' - _ -> err - - LambdaT ty _orig _mparam body -> - case stripTypeRestrictions (infoType ty) of - TypeFunT _ty _origF md param mtope _ret -> - case actual' of - LambdaT ty' orig' _mparam' body' -> - case stripTypeRestrictions (infoType ty') of - TypeFunT _ty' _origF' md' param' mtope' _ret' -> do - when (md /= md') $ - issueTypeError (TypeErrorOther $ "modality mismatch in lambda: expected " <> show md <> " but got " <> show md') - unify Nothing param param' -- we (should) have already checked this in types! - enterScope orig' md param $ do - case (mtope, mtope') of - (Just tope, Just tope') -> do - unify Nothing tope tope' -- we (should) have already checked this in types! - localTope tope $ unify Nothing body body' - (Nothing, Nothing) -> do - unify Nothing body body' - _ -> errS - _ -> err - _ -> err - _ -> err - - LetT{} -> panicImpossible "let at the root of WHNF" - LetModT _ orig app inn _ val body -> - case actual' of - LetModT _ _ app' inn' _ val' body' - | app == app', inn == inn' -> do - unify Nothing val val' - bty <- typeOf val >>= \case - TypeModalT _ _ t -> pure t - _ -> panicImpossible "not modal in letmod" - enterScope orig (comp app inn) bty $ - unify Nothing body body' - _ -> err - - ReflT ty _x | TypeIdT _ty x _tA y <- infoType ty -> - case actual' of - ReflT ty' _x' | TypeIdT _ty' x' _tA' y' <- infoType ty' -> do - -- unify Nothing tA tA' -- TODO: do we need this check? - unify Nothing x x' - unify Nothing y y' - _ -> err - ReflT{} -> panicImpossible "refl with a non-identity type!" - - IdJT _ty a b c d e f -> - case actual' of - IdJT _ty' a' b' c' d' e' f' -> do - unify Nothing a a' - unify Nothing b b' - unify Nothing c c' - unify Nothing d d' - unify Nothing e e' - unify Nothing f f' - _ -> err - - TypeAscT{} -> panicImpossible "type ascription at the root of WHNF" - - TypeRestrictedT _ty ty rs -> - case actual' of - TypeRestrictedT _ty' ty' rs' -> do - unify mterm ty ty' - -- The faces of the supertype must be covered by the faces - -- of the subtype (the subtype is at least as specified), - -- with the boundary terms agreeing on overlaps. Which side - -- is the subtype depends on the ambient variance. - variance <- asks covariance - let subCoversSuper subRs superRs = sequence_ - [ localTope tope $ do - -- FIXME: can do less entails checks? - contextEntails (foldr topeOrT topeBottomT (map fst subRs)) - forM_ subRs $ \(tope', term') -> do - localTope tope' $ - unify Nothing term term' - | (tope, term) <- superRs - ] - case variance of - Covariant -> subCoversSuper rs' rs - Contravariant -> subCoversSuper rs rs' - Invariant -> do - subCoversSuper rs' rs - subCoversSuper rs rs' - _ -> err -- FIXME: need better unification for restrictions - TypeModalT _ty m ty -> - case actual' of - TypeModalT _ty' m' ty' -> do - when (m' /= m) $ err - enterModality m $ unify Nothing ty ty' - _ -> err - ModAppT _ty m ty -> - case actual' of - ModAppT _ty' m' ty' -> do - when (m' /= m) $ err - enterModality m $ unify Nothing ty ty' - _ -> err - ModExtractT _ty app inn te -> - case actual' of - ModExtractT _ty' app' inn' te' -> do - when (app' /= app) $ err - when (inn' /= inn) $ err - enterModality app $ unify Nothing te te' - _ -> err - -- defensive: a hole nested anywhere also defers here rather - -- than panicking on an otherwise unexpected shape - _ | holePresent -> return () - _ -> panicImpossible "unexpected term in UNIFY" - - where - action = case mterm of - Nothing -> ActionUnifyTerms expected actual - Just term -> ActionUnify term expected actual - -unifyTypes :: Eq var => TermT var -> TermT var -> TermT var -> TypeCheck var () -unifyTypes = unify . Just - -unifyTerms :: Eq var => TermT var -> TermT var -> TypeCheck var () -unifyTerms = unify Nothing - -localTope :: Eq var => TermT var -> TypeCheck var a -> TypeCheck var a -localTope tope tc = do - Context{..} <- ask - tope' <- nfTope tope - let modalTope' = plainTope tope' - -- A small optimisation to help unify terms faster - let refine = case tope' of - TopeEQT _ x y | x == y -> const tc -- no new information added! - _ | modalTope' `elem` localTopesNF -> const tc -- no new information added! - | otherwise -> id - refine $ do - entailsBottom <- (modalTope' : localTopesNF) `entailM` topeBottomT - withRefreshedTopes (f modalTope' entailsBottom) tc - where - f tope' entailsBottom Context{..} = Context - { localTopes = plainTope tope : localTopes - , localTopesNF = tope' : localTopesNF - , localTopesNFUnion = map nubTermT - [ new <> old - | new <- simplifyLHSwithDisjunctions [tope'] - , old <- localTopesNFUnion ] - , localTopesEntailBottom = Just entailsBottom - , .. } - -universeT :: TermT var -universeT = iterate f (panicImpossible msg) !! 30 - where - msg = "going too high up the universe levels" - f t = UniverseT TypeInfo - { infoType = t - , infoNF = Just universeT - , infoWHNF = Just universeT } - -cubeT :: TermT var -cubeT = UniverseCubeT TypeInfo - { infoType = universeT - , infoNF = Just cubeT - , infoWHNF = Just cubeT } - -topeT :: TermT var -topeT = UniverseTopeT TypeInfo - { infoType = universeT - , infoNF = Just topeT - , infoWHNF = Just topeT } - -topeEQT :: TermT var -> TermT var -> TermT var -topeEQT l r = TopeEQT info l r - where - info = TypeInfo - { infoType = topeT - , infoNF = Nothing - , infoWHNF = Nothing - } - -topeLEQT :: TermT var -> TermT var -> TermT var -topeLEQT l r = TopeLEQT info l r - where - info = TypeInfo - { infoType = topeT - , infoNF = Nothing - , infoWHNF = Nothing - } - -topeOrT :: TermT var -> TermT var -> TermT var -topeOrT l r = TopeOrT info l r - where - info = TypeInfo - { infoType = topeT - , infoNF = Nothing - , infoWHNF = Nothing - } - -topeAndT :: TermT var -> TermT var -> TermT var -topeAndT l r = TopeAndT info l r - where - info = TypeInfo - { infoType = topeT - , infoNF = Nothing - , infoWHNF = Nothing - } - -cubeProductT :: TermT var -> TermT var -> TermT var -cubeProductT l r = t - where - t = CubeProductT info l r - info = TypeInfo - { infoType = cubeT - , infoNF = Nothing - , infoWHNF = Nothing - } - -cubeUnitT :: TermT var -cubeUnitT = CubeUnitT TypeInfo - { infoType = cubeT - , infoNF = Just cubeUnitT - , infoWHNF = Just cubeUnitT } - -cubeUnitStarT :: TermT var -cubeUnitStarT = CubeUnitStarT TypeInfo - { infoType = cubeUnitT - , infoNF = Just cubeUnitStarT - , infoWHNF = Just cubeUnitStarT } - -typeUnitT :: TermT var -typeUnitT = TypeUnitT TypeInfo - { infoType = universeT - , infoNF = Just typeUnitT - , infoWHNF = Just typeUnitT } - -unitT :: TermT var -unitT = UnitT TypeInfo - { infoType = typeUnitT - , infoNF = Just unitT - , infoWHNF = Just unitT } - -cube2T :: TermT var -cube2T = Cube2T TypeInfo - { infoType = cubeT - , infoNF = Just cube2T - , infoWHNF = Just cube2T } - -cube2_0T :: TermT var -cube2_0T = Cube2_0T TypeInfo - { infoType = cube2T - , infoNF = Just cube2_0T - , infoWHNF = Just cube2_0T } - -cube2_1T :: TermT var -cube2_1T = Cube2_1T TypeInfo - { infoType = cube2T - , infoNF = Just cube2_1T - , infoWHNF = Just cube2_1T } - -cubeIT :: TermT var -cubeIT = CubeIT TypeInfo - { infoType = cubeT - , infoNF = Just cubeIT - , infoWHNF = Just cubeIT } - -cubeI_0T :: TermT var -cubeI_0T = CubeI_0T TypeInfo - { infoType = cubeIT - , infoNF = Just cubeI_0T - , infoWHNF = Just cubeI_0T } - -cubeI_1T :: TermT var -cubeI_1T = CubeI_1T TypeInfo - { infoType = cubeIT - , infoNF = Just cubeI_1T - , infoWHNF = Just cubeI_1T } - -cubeFlipT :: TermT var -> TermT var -> TermT var -cubeFlipT cubeTy t = CubeFlipT info t - where - info = TypeInfo - { infoType = typeModalT cubeT Op cubeTy - , infoNF = Nothing - , infoWHNF = Nothing - } - -cubeUnflipT :: TermT var -> TermT var -> TermT var -cubeUnflipT cubeTy t = CubeUnflipT info t - where - info = TypeInfo - { infoType = cubeTy - , infoNF = Nothing - , infoWHNF = Nothing - } - -topeInvT :: TermT var -> TermT var -topeInvT t = TopeInvT info t - where - info = TypeInfo - { infoType = typeModalT universeT Op topeT - , infoNF = Nothing - , infoWHNF = Nothing - } - -topeUninvT :: TermT var -> TermT var -topeUninvT t = TopeUninvT info t - where - info = TypeInfo - { infoType = topeT - , infoNF = Nothing - , infoWHNF = Nothing - } - -topeTopT :: TermT var -topeTopT = TopeTopT TypeInfo - { infoType = topeT - , infoNF = Just topeTopT - , infoWHNF = Just topeTopT } - -topeBottomT :: TermT var -topeBottomT = TopeBottomT TypeInfo - { infoType = topeT - , infoNF = Just topeBottomT - , infoWHNF = Just topeBottomT } - -recBottomT :: TermT var -recBottomT = RecBottomT TypeInfo - { infoType = recBottomT - , infoNF = Just recBottomT - , infoWHNF = Just recBottomT } - -typeRestrictedT :: TermT var -> [(TermT var, TermT var)] -> TermT var -typeRestrictedT ty rs = t - where - t = TypeRestrictedT info ty rs - info = TypeInfo - { infoType = universeT - , infoNF = Nothing - , infoWHNF = Nothing - } - -lambdaT - :: TermT var - -> Binder - -> Maybe (TModality, TermT var, Maybe (Scope TermT var)) - -> Scope TermT var - -> TermT var -lambdaT ty orig mparam body = t - where - t = LambdaT info orig mparam body - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Just t - } - - -letT :: TermT var -> Binder -> Maybe (TermT var) -> TermT var -> Scope TermT var -> TermT var -letT ty orig mparam val body = t - where - t = LetT info orig mparam val body - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -letModT :: TermT var -> Binder -> TModality -> TModality -> Maybe (TermT var) -> TermT var -> Scope TermT var -> TermT var -letModT ty orig app inn mparam val body = t - where - t = LetModT info orig app inn mparam val body - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -appT :: TermT var -> TermT var -> TermT var -> TermT var -appT ty f x = t - where - t = AppT info f x - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -pairT :: TermT var -> TermT var -> TermT var -> TermT var -pairT ty l r = t - where - t = PairT info l r - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Just t - } - -firstT :: TermT var -> TermT var -> TermT var -firstT ty arg = t - where - t = FirstT info arg - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -secondT :: TermT var -> TermT var -> TermT var -secondT ty arg = t - where - t = SecondT info arg - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -reflT - :: TermT var - -> Maybe (TermT var, Maybe (TermT var)) - -> TermT var -reflT ty mx = t - where - t = ReflT info mx - info = TypeInfo - { infoType = ty - , infoNF = Just (ReflT info Nothing) - , infoWHNF = Just (ReflT info Nothing) - } - -typeFunT - :: Binder - -> TModality - -> TermT var - -> Maybe (Scope TermT var) - -> Scope TermT var - -> TermT var -typeFunT orig md cube mtope ret = t - where - t = TypeFunT info orig md cube mtope ret - info = TypeInfo - { infoType = universeT - , infoNF = Nothing - , infoWHNF = Just t - } - -typeSigmaT - :: Binder - -> TModality - -> TermT var - -> Scope TermT var - -> TermT var -typeSigmaT orig md a b = t - where - t = TypeSigmaT info orig md a b - info = TypeInfo - { infoType = universeT - , infoNF = Nothing - , infoWHNF = Just t - } - -recOrT - :: TermT var - -> [(TermT var, TermT var)] - -> TermT var -recOrT ty rs = t - where - t = RecOrT info rs - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -typeIdT :: TermT var -> Maybe (TermT var) -> TermT var -> TermT var -typeIdT x tA y = t - where - t = TypeIdT info x tA y - info = TypeInfo - { infoType = universeT - , infoNF = Nothing - , infoWHNF = Just t - } - -idJT - :: TermT var - -> TermT var - -> TermT var - -> TermT var - -> TermT var - -> TermT var - -> TermT var - -> TermT var -idJT ty tA a tC d x p = t - where - t = IdJT info tA a tC d x p - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -typeAscT :: TermT var -> TermT var -> TermT var -typeAscT x ty = t - where - t = TypeAscT info x ty - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -typeModalT :: TermT var -> TModality -> TermT var -> TermT var -typeModalT ty md te = t - where - t = TypeModalT info md te - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -modAppT :: TermT var -> TModality -> TermT var -> TermT var -modAppT ty md term = t - where - t = ModAppT info md term - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - -modExtractT :: TermT var -> TModality -> TModality -> TermT var -> TermT var -modExtractT ty app inn term = t - where - t = ModExtractT info app inn term - info = TypeInfo - { infoType = ty - , infoNF = Nothing - , infoWHNF = Nothing - } - --- | Check a @recOR@ in checking position against a known expected type: each --- branch is checked against that type under its guard tope, followed by the --- usual pairwise coherence and the coverage obligation. Passing a /restricted/ --- type pushes the boundary into every branch, so a branch hole reports the --- faces it must meet (under its tope) instead of the bare underlying type. --- --- Under a branch guard, the faces belonging to the other (mutually exclusive) --- branches become disjoint from this branch's tope context, so they are pruned --- by 'pruneVacuousFaces' before the branch is checked. Otherwise a face like --- @i ≡ 1₂@ would be reported as vacuous while checking the @i ≡ 0₂@ branch --- against @A [i ≡ 0₂ ↦ a, i ≡ 1₂ ↦ b]@ — which arises in particular with --- flat-discrete cube variables, where @i ≡ 0₂ ∧ i ≡ 1₂@ is provably ⊥. -checkRecOrAgainst :: Eq var => TermT var -> [(Term var, Term var)] -> TypeCheck var (TermT var) -checkRecOrAgainst expected rs = do - rs' <- forM rs $ \(tope, rterm) -> do - tope' <- typecheck tope topeT - checkTopeAgainstContext "recOR branch guard" tope' - localTope tope' $ do - expected' <- pruneVacuousFaces expected - rterm' <- typecheck rterm expected' - return (tope', rterm') - sequence_ [ checkCoherence l r | l:rs'' <- tails rs', r <- rs'' ] - contextEntailsUnion (map fst rs') - return (recOrT expected rs') - --- | Drop the restriction faces of an extension type that are vacuous in the --- current tope context (their overlap with the context is the empty tope ⊥). A --- face mentioning an unfilled hole cannot be decided, so it is kept. Non-extension --- types are returned unchanged. Used when descending into a recOR branch, where --- the sibling branches' faces are disjoint from the branch guard. -pruneVacuousFaces :: Eq var => TermT var -> TypeCheck var (TermT var) -pruneVacuousFaces (TypeRestrictedT _info ty rs) = do - contextTopes <- asks localTopesNF - kept <- fmap concat $ forM rs $ \face@(tope, _) -> do - vacuous <- if containsHole tope - then return False - else (plainTope tope : contextTopes) `entailM` topeBottomT - return [ face | not vacuous ] - return $ case kept of - [] -> ty - _ -> typeRestrictedT ty kept -pruneVacuousFaces ty = return ty - -typecheck :: Eq var => Term var -> TermT var -> TypeCheck var (TermT var) -typecheck term ty = performing (ActionTypeCheck term ty) $ case term of - -- A hole is checked against a known type (this is checking position): in - -- strict mode it is reported as an unsolved hole; in lenient mode its goal - -- and context are recorded and it is treated as inhabiting the expected type. - Hole mname -> do - reject <- asks holesAreErrors - if reject - then issueTypeError (TypeErrorUnsolvedHole mname ty) - else do - recordHole mname ty - return (HoleT TypeInfo{ infoType = ty, infoWHNF = Nothing, infoNF = Nothing } mname) - - _ -> whnfT ty >>= \case - - RecBottomT{} -> do - -- Even under an absurd tope context (where the expected type collapses to - -- recBOT), the term must still be well-formed in its own right, so that - -- ill-typed bodies are not silently admitted under a false hypothesis. We - -- synthesise its type, discard the result, and keep the recBOT elaboration. - _ <- infer term - return recBottomT - - tr@(TypeRestrictedT _ty ty' rs) -> case term of - -- A recOR against a restricted type: push the restriction into each branch - -- instead of stripping it first, so a branch hole reports the boundary - -- faces it must satisfy under its guard tope, rather than the bare - -- underlying type. Concrete branches still meet the faces, which are - -- checked on each branch's overlap with them (see the general case below). - RecOr branches -> checkRecOrAgainst tr branches - _ -> do - term' <- typecheck term ty' - -- NOTE: restriction faces need not be contained in the local tope context. - -- Each face is checked only on its overlap with the context below, so an - -- overhanging face is harmless (we only hint); a face disjoint from the context - -- is vacuous, however, and is reported as an error by checkTopeAgainstContext. - forM_ rs $ \(tope, rterm) -> do - checkTopeAgainstContext "restriction face" tope - localTope tope $ - unifyTerms rterm term' - return term' -- FIXME: correct? - - ty' -> case term of - Lambda orig mparam body -> - case ty' of - TypeFunT _ty _orig' md' param' mtope' ret -> do - case mparam of - Nothing -> return () - Just (md, param, Nothing) -> do - when (md /= md') $ - issueTypeError (TypeErrorModalityMismatch md' md term) - (paramType, mtope) <- do - paramType <- enterModality md $ infer param - typeOf paramType >>= \case - -- an argument can be a shape - TypeFunT _ty _orig _md cube _mtope UniverseTopeT{} -> do - mapM_ checkNameShadowing (binderLeaves orig) - enterScope orig md cube $ do - let tope' = appT topeT (S <$> paramType) (Pure Z) -- eta expand ty' - return (cube, Just tope') - _kind -> return (paramType, Nothing) - unifyTerms param' paramType - mapM_ checkNameShadowing (binderLeaves orig) - enterScope orig md param' $ do - mapM_ (unifyTerms (fromMaybe topeTopT mtope')) mtope - Just (md, param, mtope) -> do - when (md /= md') $ - issueTypeError (TypeErrorModalityMismatch md' md term) - param'' <- enterModality md $ typecheck param =<< typeOf param' - unifyTerms param' param'' - mapM_ checkNameShadowing (binderLeaves orig) - enterScope orig md param' $ do - mtope'' <- typecheck (fromMaybe TopeTop mtope) topeT - unifyTerms (fromMaybe topeTopT mtope') mtope'' - - mapM_ checkNameShadowing (binderLeaves orig) - enterScope orig md' param' $ do - maybe id localTope mtope' $ do - body' <- typecheck body ret - return (lambdaT ty' orig (Just (md', param', mtope')) body') - - _ -> issueTypeError $ TypeErrorUnexpectedLambda term ty - Let orig annot val body -> do - val' <- performing (ActionCheckLetValue (binderName orig)) $ case annot of - Nothing -> infer val - Just bindType -> do - bindType' <- typecheck bindType universeT - typecheck val bindType' - bindTy <- typeOf val' - body' <- enterScopeWithBind orig Id bindTy val' $ do - typecheck body (S <$> ty') - return (letT ty' orig (Just bindTy) val' body') - LetMod orig app inn annot val body -> do - val' <- performing (ActionCheckLetValue (binderName orig)) $ case annot of - Nothing -> enterModality app $ infer val - Just bindType -> do - bindType' <- infer bindType - bindUniv <- typeOf bindType' - enterModality app $ typecheck val (typeModalT bindUniv inn bindType') - bindTy <- typeOf val' >>= \case - o@(TypeModalT _ty md t) -> - if md == inn then - return t - else - issueTypeError $ TypeErrorNotModal (untyped o) inn val' - o -> issueTypeError $ TypeErrorNotModal (untyped o) inn val' - bindVal <- whnfT val' >>= \case - ModAppT _ty _m t -> pure (Just t) - o | isRA inn -> pure (Just (modExtractT bindTy app inn o)) - _ -> pure Nothing - body' <- enterScopeMaybe orig (comp app inn) bindTy bindVal $ do - typecheck body (S <$> ty') - return (letModT ty' orig app inn (Just bindTy) val' body') - Pair l r -> - case ty' of - CubeProductT _ty a b -> do - l' <- typecheck l a - r' <- typecheck r b - return (pairT ty' l' r') - TypeSigmaT _ty _orig md a b -> do - l' <- enterModality md $ typecheck l a - r' <- typecheck r (substituteT l' b) - return (pairT ty' l' r') - _ -> issueTypeError $ TypeErrorUnexpectedPair term ty - - Refl mx -> - case ty' of - TypeIdT _ty y _tA z -> do - tA <- typeOf y - forM_ mx $ \(x, mxty) -> do - forM_ mxty $ \xty -> do - xty' <- typecheck xty universeT - unifyTerms tA xty' - x' <- typecheck x tA - unifyTerms x' y >> unifyTerms y x' - unifyTerms x' z >> unifyTerms z x' - when (isNothing mx) $ - unifyTerms y z >> unifyTerms z y - return (reflT ty' (Just (y, Just tA))) - _ -> issueTypeError $ TypeErrorUnexpectedRefl term ty - ModExtract{} -> panicImpossible "extract is an internal term and cannot be typechecked" - ModApp md body -> case ty' of - TypeModalT _ty md' tpe -> do - when (md /= md') $ issueTypeError $ - TypeErrorModalityMismatch md' md term - body' <- enterModality md $ typecheck body tpe - return $ modAppT ty' md body' - _ -> issueTypeError $ TypeErrorNotModal term md ty' - - -- In checking position the common type is already known, so we push it - -- into every branch instead of inferring each one and unifying. This is - -- what lets a bare hole branch (recOR(φ ↦ ?, …)) be checked against the - -- expected type and recorded, rather than hitting TypeErrorCannotInferHole - -- via the inference rule. The branch-guard, coherence, and coverage - -- obligations mirror the inference rule (see the RecOr case of 'infer'). - -- A recOR is a term-level eliminator, not a tope; rejecting it when it is - -- checked against the tope universe (e.g. in another recOR's branch guard) - -- keeps it out of the tope layer, where it would otherwise hit a panic. - RecOr rs -> case ty' of - UniverseTopeT{} -> issueTypeError $ - TypeErrorOther "a recOR cannot be used as a tope" - _ -> checkRecOrAgainst ty' rs - -- A neutral term is inferred, then its type unified with the expected - -- one. In lenient (hole-checking) mode a term that still carries an - -- unfilled hole is a work in progress, so a failure of that final - -- unification is tolerated: the holes recorded while inferring the term - -- stand (they were committed before this point), and we accept the term - -- rather than rejecting the whole sketch. The mismatch is typically - -- incidental to the missing pieces — e.g. an extension-type boundary face - -- that only fails to line up because an argument hole sits in the wrong - -- place (`f t` vs `x`), where neither side is itself a hole, so the - -- per-term deferral in 'unifyInCurrentContext' cannot see it. Strict mode - -- (the default, and CI) still rejects the mismatch. - _ -> do - term' <- infer term - inferredType <- typeOf term' - lenient <- not <$> asks holesAreErrors - if lenient && containsHole term' - then unifyTypes term' ty' inferredType `catchError` \_ -> return () - else unifyTypes term' ty' inferredType - return term' - -inferAs :: Eq var => TermT var -> Term var -> TypeCheck var (TermT var) -inferAs expectedKind term = do - term' <- infer term - ty <- typeOf term' - kind <- typeOf ty - unifyTypes ty expectedKind kind - return term' - -infer :: Eq var => Term var -> TypeCheck var (TermT var) -infer tt = performing (ActionInfer tt) $ case tt of - Hole _mname -> issueTypeError (TypeErrorCannotInferHole tt) - Pure x -> do - topLevel <- isTopLevelVar x - unless topLevel $ do - varMod <- modalityOfVar x - locks <- locksOfVar x - when (not (coe varMod locks)) $ issueTypeError $ TypeErrorUnaccessibleVar x varMod locks - pure (Pure x) - - Universe -> pure universeT - UniverseCube -> pure cubeT - UniverseTope -> pure topeT - - CubeUnit -> pure cubeUnitT - CubeUnitStar -> pure cubeUnitStarT - - Cube2 -> pure cube2T - Cube2_0 -> pure cube2_0T - Cube2_1 -> pure cube2_1T - - CubeI -> pure cubeIT - CubeI_0 -> pure cubeI_0T - CubeI_1 -> pure cubeI_1T - CubeProduct l r -> do - l' <- typecheck l cubeT - r' <- typecheck r cubeT - return (cubeProductT l' r') - - CubeFlip t -> do - t' <- infer t - typeOf t' >>= \case - CubeIT{} -> pure $ cubeFlipT cubeIT t' - Cube2T{} -> pure $ cubeFlipT cube2T t' - ty -> do - tyStr <- ppTermInContext ty - issueTypeError $ TypeErrorOther $ - "flip expects an interval cube (2 or 𝕀); got " <> tyStr - CubeUnflip t -> do - t' <- infer t - typeOf t' >>= \case - TypeModalT _ Op (CubeIT{}) -> pure $ cubeUnflipT cubeIT t' - TypeModalT _ Op (Cube2T{}) -> pure $ cubeUnflipT cube2T t' - ty -> do - tyStr <- ppTermInContext ty - issueTypeError $ TypeErrorOther $ - "unflip expects an interval cube (2 or 𝕀) under _op; got " <> tyStr - Pair l r -> do - l' <- infer l - r' <- infer r - lt <- typeOf l' - rt <- typeOf r' - typeOf lt >>= \case - -- Γ ⊢ l ⇒ (I : CUBE) - -- Γ ⊢ r ⇒ (J : CUBE) - -- ——————————————————————————— - -- Γ ⊢ (l, r) ⇒ (I × J : CUBE) - UniverseCubeT{} -> return (pairT (cubeProductT lt rt) l' r') - -- Γ ⊢ l ⇒ (A : U) - -- Γ ⊢ r ⇒ (B : U) - -- ——————————————————————————— - -- Γ ⊢ (l, r) ⇒ (A × B : U) where A × B = Σ (_ : A), B - _ -> do - -- NOTE: infer as a non-dependent pair! - return (pairT (typeSigmaT (BinderVar Nothing) Id lt (S <$> rt)) l' r') - - First t -> do - t' <- infer t - fmap stripTypeRestrictions (typeOf t') >>= \case - RecBottomT{} -> pure recBottomT -- FIXME: is this ok? - TypeSigmaT _ty _orig _md lt _rt -> - return (firstT lt t') - CubeProductT _ty l _r -> - return (firstT l t') - ty -> issueTypeError $ TypeErrorNotPair t' ty - - Second t -> do - t' <- infer t - fmap stripTypeRestrictions (typeOf t') >>= \case - RecBottomT{} -> pure recBottomT -- FIXME: is this ok? - TypeSigmaT _ty _orig _md lt rt -> - return (secondT (substituteT (firstT lt t') rt) t') - CubeProductT _ty _l r -> - return (secondT r t') - ty -> issueTypeError $ TypeErrorNotPair t' ty - - TypeUnit -> pure typeUnitT - Unit -> pure unitT - - TopeTop -> pure topeTopT - TopeBottom -> pure topeBottomT - - TopeEQ l r -> do - l' <- inferAs cubeT l - lt <- typeOf l' - r' <- typecheck r lt - return (topeEQT l' r') - - TopeLEQ l r -> do - l' <- inferAs cubeT l - r' <- inferAs cubeT r - lTy <- typeOf l' - rTy <- typeOf r' - case (lTy, rTy) of - (Cube2T{}, Cube2T{}) -> return (topeLEQT l' r') - (CubeIT{}, CubeIT{}) -> return (topeLEQT l' r') - (CubeIT{}, Cube2T{}) -> do - r'' <- typecheck r cubeIT - return (topeLEQT l' r'') - (Cube2T{}, CubeIT{}) -> do - l'' <- typecheck l cubeIT - return (topeLEQT l'' r') - _ -> do - lStr <- ppTermInContext lTy - rStr <- ppTermInContext rTy - issueTypeError $ TypeErrorOther $ - "the (t ≤ s) tope expects points in interval cubes (2 or 𝕀); got " - <> lStr <> " and " <> rStr - - TopeAnd l r -> do - l' <- typecheck l topeT - r' <- typecheck r topeT - return (topeAndT l' r') - - TopeOr l r -> do - l' <- typecheck l topeT - r' <- typecheck r topeT - return (topeOrT l' r') - - TopeInv t -> do - t' <- typecheck t topeT - return (topeInvT t') - - TopeUninv t -> do - t' <- typecheck t (typeModalT universeT Op topeT ) - return (topeUninvT t') - - RecBottom -> do - contextEntails topeBottomT - return recBottomT - - -- Γ ⊢ t ⇒ (T : K) - -- Γ ⊢ K ≡ U - -- ————————————— - -- Γ ⊢ t ⇒ T ⇐ U - - RecOr rs -> do - ttts <- forM rs $ \(tope, term) -> do - tope' <- typecheck tope topeT - -- NOTE: branch guards need not be contained in the context. recOR requires - -- only coverage (context |- OR(guards)), enforced by contextEntailsUnion below; - -- a guard may overhang the context (e.g. when splitting with a named shape). - -- checkTopeAgainstContext warns on overhang and errors only if the guard is - -- disjoint from the context (a vacuous branch). - checkTopeAgainstContext "recOR branch guard" tope' - localTope tope' $ do - term' <- inferAs universeT term - ty <- typeOf term' - return (tope', (term', ty)) - let rs' = map (fmap fst) ttts - ts = map (fmap snd) ttts - sequence_ [ checkCoherence l r | l:rs'' <- tails rs', r <- rs'' ] - contextEntailsUnion (map fst ttts) - return (recOrT (recOrT universeT ts) rs') - - TypeFun orig md a Nothing b -> do - a' <- enterModality md $ infer a - typeOf a' >>= \case - -- an argument can be a type - UniverseT{} -> - case a' of - -- except if its a TOPE universe - UniverseTopeT{} -> - issueTypeError $ TypeErrorOther "tope params are illegal" - _ -> do - mapM_ checkNameShadowing (binderLeaves orig) - b' <- enterScope orig md a' $ typecheck b universeT - return (typeFunT orig md a' Nothing b') - -- an argument can be a cube - UniverseCubeT{} -> do - mapM_ checkNameShadowing (binderLeaves orig) - b' <- enterScope orig md a' $ typecheck b universeT - return (typeFunT orig md a' Nothing b') - -- an argument can be a shape - TypeFunT _ty _orig _md cube mtope UniverseTopeT{} -> do - mapM_ checkNameShadowing (binderLeaves orig) - enterScope orig md cube $ do - let tope' = appT topeT (S <$> a') (Pure Z) -- eta expand a' - localTope tope' $ do - b' <- typecheck b universeT - case mtope of - Nothing -> return (typeFunT orig md cube (Just tope') b') - Just tope'' -> return (typeFunT orig md cube (Just (topeAndT tope'' tope')) b') - ty -> issueTypeError $ TypeErrorInvalidArgumentType a ty - - TypeFun orig md cube (Just tope) ret -> do - cube' <- enterModality md $ typecheck cube cubeT - mapM_ checkNameShadowing (binderLeaves orig) - enterScope orig md cube' $ do - tope' <- typecheck tope topeT - localTope tope' $ do - ret' <- typecheck ret universeT - return (typeFunT orig md cube' (Just tope') ret') - - TypeSigma orig md a b -> do - a' <- enterModality md $ typecheck a universeT - mapM_ checkNameShadowing (binderLeaves orig) - b' <- enterScope orig md a' $ typecheck b universeT - return (typeSigmaT orig md a' b') - - TypeId x (Just tA) y -> do - tA' <- typecheck tA universeT - x' <- typecheck x tA' - y' <- typecheck y tA' - return (typeIdT x' (Just tA') y') - - TypeId x Nothing y -> do - x' <- inferAs universeT x - tA <- typeOf x' - y' <- typecheck y tA - return (typeIdT x' (Just tA) y') - - App f x -> do - f' <- inferAs universeT f - fmap stripTypeRestrictions (typeOf f') >>= \case - TypeFunT _ty orig md a mtope b -> do - -- A hole argument to a shape-restricted function carries the shape as - -- its goal: record (binder : a | tope) rather than just the cube a. - x' <- enterModality md $ case (x, mtope) of - (Hole mname, Just tope) -> checkHoleAgainstShape mname orig a tope - _ -> typecheck x a - let result = appT (substituteT x' b) f' x' - case b of - UniverseTopeT{} -> do - case mtope of - Nothing -> return result - Just tope -> do - return (topeAndT (substituteT x' tope) result) - _ -> do - mapM_ (contextEntails . substituteT x') mtope -- FIXME: need to check? - return result - ty -> issueTypeError $ TypeErrorNotFunction f' ty - - Lambda _orig Nothing _body -> do - issueTypeError $ TypeErrorCannotInferBareLambda tt - Lambda orig (Just (md, ty, Nothing)) body -> do - ty' <- enterModality md $ infer ty - mtope <- typeOf ty' >>= \case - -- an argument can be a type - UniverseT{} -> - case ty' of - -- except if its a TOPE universe - UniverseTopeT{} -> - issueTypeError $ TypeErrorOther "tope params are illegal" - _ -> return Nothing - -- an argument can be a cube - UniverseCubeT{} -> return Nothing - -- an argument can be a shape - TypeFunT _ty _orig _md cube _mtope UniverseTopeT{} -> do - mapM_ checkNameShadowing (binderLeaves orig) - enterScope orig md cube $ do - let tope' = appT topeT (S <$> ty') (Pure Z) -- eta expand ty' - return (Just tope') - kind -> issueTypeError $ TypeErrorInvalidArgumentType ty kind - mapM_ checkNameShadowing (binderLeaves orig) - enterScope orig md ty' $ do - maybe id localTope mtope $ do - body' <- infer body - ret <- typeOf body' - return (lambdaT (typeFunT orig md ty' mtope ret) orig (Just (md, ty', mtope)) body') - Lambda orig (Just (md, cube, Just tope)) body -> do - cube' <- enterModality md $ typecheck cube cubeT - mapM_ checkNameShadowing (binderLeaves orig) - enterScope orig md cube' $ do - tope' <- infer tope - body' <- localTope tope' $ infer body - ret <- typeOf body' - return (lambdaT (typeFunT orig md cube' (Just tope') ret) orig (Just (md, cube', Just tope')) body') - Let orig annot val body -> do - val' <- performing (ActionCheckLetValue (binderName orig)) $ case annot of - Nothing -> infer val - Just ty -> do - bindTy <- typecheck ty universeT - typecheck val bindTy - bindTy <- typeOf val' - enterScopeWithBind orig Id bindTy val' $ do - body' <- infer body - ret <- typeOf body' - return (letT (substituteT val' ret) orig (Just bindTy) val' body') - LetMod orig app inn annot val body -> do - val' <- performing (ActionCheckLetValue (binderName orig)) $ case annot of - Nothing -> enterModality app $ infer val - Just bindType -> do - bindType' <- infer bindType - bindUniv <- typeOf bindType' - enterModality app $ typecheck val (typeModalT bindUniv inn bindType') - bindTy <- typeOf val' >>= \case - o@(TypeModalT _ty md t) -> - if md == inn then - return t - else - issueTypeError $ TypeErrorNotModal (untyped o) inn val' - o -> issueTypeError $ TypeErrorNotModal (untyped o) inn val' - bindVal <- whnfT val' >>= \case - ModAppT _ty _m t -> pure (Just t) - o | isRA inn -> pure (Just (modExtractT bindTy app inn o)) - _ -> pure Nothing - enterScopeMaybe orig (comp app inn) bindTy bindVal $ do - body' <- infer body - ret <- typeOf body' - return (letModT (substituteT val' ret) orig app inn (Just bindTy) val' body') - Refl Nothing -> issueTypeError $ TypeErrorCannotInferBareRefl tt - Refl (Just (x, Nothing)) -> do - x' <- inferAs universeT x - ty <- typeOf x' - return (reflT (typeIdT x' (Just ty) x') (Just (x', Just ty))) - Refl (Just (x, Just ty)) -> do - ty' <- typecheck ty universeT - x' <- typecheck x ty' - return (reflT (typeIdT x' (Just ty') x') (Just (x', Just ty'))) - - IdJ tA a tC d x p -> do - tA' <- typecheck tA universeT - a' <- typecheck a tA' - let typeOf_C = - typeFunT (BinderVar Nothing) Id tA' Nothing $ - typeFunT (BinderVar Nothing) Id (typeIdT (S <$> a') (Just (S <$> tA')) (Pure Z)) Nothing $ - universeT - tC' <- typecheck tC typeOf_C - let typeOf_d = - appT universeT - (appT (typeFunT (BinderVar Nothing) Id (typeIdT a' (Just tA') a') Nothing universeT) - tC' a') - (reflT (typeIdT a' (Just tA') a') Nothing) - d' <- typecheck d typeOf_d - x' <- typecheck x tA' - p' <- typecheck p (typeIdT a' (Just tA') x') - let ret = - appT universeT - (appT (typeFunT (BinderVar Nothing) Id (typeIdT a' (Just tA') x') Nothing universeT) - tC' x') - p' - return (idJT ret tA' a' tC' d' x' p') - - TypeAsc term ty -> do - ty' <- inferAs universeT ty -- this works on types AND cubes - term' <- typecheck term ty' - return (typeAscT term' ty') - - TypeRestricted ty rs -> do - ty' <- typecheck ty universeT - rs' <- forM rs $ \(tope, term) -> do - tope' <- typecheck tope topeT - term' <- localTope tope' $ typecheck term ty' - return (tope', term') - sequence_ [ checkCoherence l r | l:rs'' <- tails rs', r <- rs'' ] - return (typeRestrictedT ty' rs') - TypeModal md ty -> do - ty' <- enterModality md $ infer ty - universeTy <- typeOf ty' - _ <- case universeTy of - UniverseT {} -> pure universeTy - UniverseCubeT {} -> pure universeTy - UniverseTopeT {} -> pure universeTy - _ -> issueTypeError $ TypeErrorNotTypeInModal universeTy - return (typeModalT universeTy md ty') - ModApp md term -> do - term' <- enterModality md $ infer term - ty <- typeOf term' - tyUniv <- typeOf ty - return $ modAppT (typeModalT tyUniv md ty) md term' - ModExtract _ _ _ -> error "untypable $extract$" - -checkCoherence - :: Eq var - => (TermT var, TermT var) - -> (TermT var, TermT var) - -> TypeCheck var () -checkCoherence (ltope, lterm) (rtope, rterm) = - performing (ActionCheckCoherence (ltope, lterm) (rtope, rterm)) $ do - localTope (topeAndT ltope rtope) $ do - ltype <- stripTypeRestrictions <$> typeOf lterm -- FIXME: why strip? - rtype <- stripTypeRestrictions <$> typeOf rterm -- FIXME: why strip? - -- FIXME: do we need to unify types here or is it included in unification of terms? - unifyTerms ltype rtype - unifyTerms lterm rterm - -inferStandalone :: Term VarIdent -> Either (TypeErrorInScopedContext VarIdent) (TermT VarIdent) -inferStandalone term = defaultTypeCheck (infer term) - -unsafeInferStandalone' :: Term' -> TermT' -unsafeInferStandalone' term = unsafeTypeCheck' (infer term) - -unsafeTypeCheck' :: TypeCheck VarIdent a -> a -unsafeTypeCheck' tc = - case defaultTypeCheck tc of - Left err -> error $ ppTypeErrorInScopedContext' BottomUp err - Right result -> result - -type PointId = String -type ShapeId = [PointId] - -cube2powerT :: Int -> TermT var -cube2powerT 1 = cube2T -cube2powerT dim = cubeProductT (cube2powerT (dim - 1)) cube2T - -splits :: [a] -> [([a], [a])] -splits [] = [([], [])] -splits (x:xs) = ([], x:xs) : [ (x : before, after) | (before, after) <- splits xs ] - -verticesFrom :: [TermT var] -> [(ShapeId, TermT var)] -verticesFrom ts = combine <$> mapM mk ts - where - mk t = [("0", topeEQT t cube2_0T), ("1", topeEQT t cube2_1T)] - combine xs = ([concat (map fst xs)], foldr1 topeAndT (map snd xs)) - -subTopes2 :: Int -> TermT var -> [(ShapeId, TermT var)] --- 1-dim -subTopes2 1 t = - [ (words "0", topeEQT t cube2_0T) - , (words "1", topeEQT t cube2_1T) - , (words "0 1", topeTopT) ] --- 2-dim -subTopes2 2 ts = - -- vertices - [ (words "00", topeEQT t cube2_0T `topeAndT` topeEQT s cube2_0T) - , (words "01", topeEQT t cube2_0T `topeAndT` topeEQT s cube2_1T) - , (words "10", topeEQT t cube2_1T `topeAndT` topeEQT s cube2_0T) - , (words "11", topeEQT t cube2_1T `topeAndT` topeEQT s cube2_1T) - -- edges and the diagonal - , (words "00 01", topeEQT t cube2_0T) - , (words "10 11", topeEQT t cube2_1T) - , (words "00 10", topeEQT s cube2_0T) - , (words "01 11", topeEQT s cube2_1T) - , (words "00 11", topeEQT s t) - -- triangles - , (words "00 01 11", topeLEQT t s) - , (words "00 10 11", topeLEQT s t) - ] - where - t = firstT cube2T ts - s = secondT cube2T ts --- 3-dim -subTopes2 3 t = - -- vertices - [ (words "000", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_0T) - , (words "001", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_1T) - , (words "010", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_0T) - , (words "011", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_1T) - , (words "100", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_0T) - , (words "101", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_1T) - , (words "110", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_0T) - , (words "111", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_1T) - -- edges - , (words "000 001", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_0T) - , (words "010 011", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_1T) - , (words "000 010", topeEQT t1 cube2_0T `topeAndT` topeEQT t3 cube2_0T) - , (words "001 011", topeEQT t1 cube2_0T `topeAndT` topeEQT t3 cube2_1T) - , (words "100 101", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_0T) - , (words "110 111", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_1T) - , (words "100 110", topeEQT t1 cube2_1T `topeAndT` topeEQT t3 cube2_0T) - , (words "101 111", topeEQT t1 cube2_1T `topeAndT` topeEQT t3 cube2_1T) - , (words "000 100", topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_0T) - , (words "001 101", topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_1T) - , (words "010 110", topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_0T) - , (words "011 111", topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_1T) - -- face diagonals - , (words "000 011", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 t3) - , (words "100 111", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 t3) - , (words "000 101", topeEQT t2 cube2_0T `topeAndT` topeEQT t1 t3) - , (words "010 111", topeEQT t2 cube2_1T `topeAndT` topeEQT t1 t3) - , (words "000 110", topeEQT t3 cube2_0T `topeAndT` topeEQT t1 t2) - , (words "001 111", topeEQT t3 cube2_1T `topeAndT` topeEQT t1 t2) - -- the long diagonal - , (words "000 111", topeEQT t3 t2 `topeAndT` topeEQT t2 t1) - -- face triangles - , (words "000 001 011", topeEQT t1 cube2_0T `topeAndT` topeLEQT t2 t3) - , (words "000 010 011", topeEQT t1 cube2_0T `topeAndT` topeLEQT t3 t2) - , (words "100 101 111", topeEQT t1 cube2_1T `topeAndT` topeLEQT t2 t3) - , (words "100 110 111", topeEQT t1 cube2_1T `topeAndT` topeLEQT t3 t2) - , (words "000 001 101", topeEQT t2 cube2_0T `topeAndT` topeLEQT t1 t3) - , (words "000 100 101", topeEQT t2 cube2_0T `topeAndT` topeLEQT t3 t1) - , (words "010 011 111", topeEQT t2 cube2_1T `topeAndT` topeLEQT t1 t3) - , (words "010 110 111", topeEQT t2 cube2_1T `topeAndT` topeLEQT t3 t1) - , (words "000 010 110", topeEQT t3 cube2_0T `topeAndT` topeLEQT t1 t2) - , (words "000 100 110", topeEQT t3 cube2_0T `topeAndT` topeLEQT t2 t1) - , (words "001 011 111", topeEQT t3 cube2_1T `topeAndT` topeLEQT t1 t2) - , (words "001 101 111", topeEQT t3 cube2_1T `topeAndT` topeLEQT t2 t1) - -- diagonal triangles - , (words "000 001 111", topeEQT t1 t2 `topeAndT` topeLEQT t2 t3) - , (words "000 010 111", topeEQT t1 t3 `topeAndT` topeLEQT t1 t2) - , (words "000 100 111", topeEQT t2 t3 `topeAndT` topeLEQT t2 t1) - , (words "000 011 111", topeLEQT t1 t2 `topeAndT` topeEQT t2 t3) - , (words "000 101 111", topeLEQT t2 t1 `topeAndT` topeEQT t1 t3) - , (words "000 110 111", topeLEQT t3 t1 `topeAndT` topeEQT t1 t2) - -- tetrahedra - , (words "000 001 011 111", topeLEQT t1 t2 `topeAndT` topeLEQT t2 t3) - , (words "000 010 011 111", topeLEQT t1 t3 `topeAndT` topeLEQT t3 t2) - , (words "000 001 101 111", topeLEQT t2 t1 `topeAndT` topeLEQT t1 t3) - , (words "000 100 101 111", topeLEQT t2 t3 `topeAndT` topeLEQT t3 t1) - , (words "000 010 110 111", topeLEQT t3 t1 `topeAndT` topeLEQT t1 t2) - , (words "000 100 110 111", topeLEQT t3 t2 `topeAndT` topeLEQT t2 t1) - ] - where - t1 = firstT cube2T (firstT (cube2powerT 2) t) - t2 = secondT cube2T (firstT (cube2powerT 2) t) - t3 = secondT cube2T t -subTopes2 dim _ = error (show dim <> " dimensions are not supported") - -cubeSubTopes :: [(ShapeId, TermT (Inc var))] -cubeSubTopes = subTopes2 3 (Pure Z) - -limitLength :: Int -> String -> String -limitLength n s - | length s > n = take (n - 1) s <> "…" - | otherwise = s - --- | Apply the 'renderHideTerm' policy to a cell's render data: drop the --- @\@ (the full term) from every cell, and blank the visible label of a --- proof-coloured (interior) cell. Boundary cells (coloured otherwise) keep --- their given labels. A no-op when not hiding. -hideTermData :: Bool -> String -> RenderObjectData -> RenderObjectData -hideTermData False _ d = d -hideTermData True mainColor d - | renderObjectDataColor d == mainColor = - d { renderObjectDataLabel = "", renderObjectDataFullLabel = "" } - | otherwise = d { renderObjectDataFullLabel = "" } - -renderObjectsFor - :: Eq var - => String - -> Int - -> TermT var - -> TermT var - -> TypeCheck var [(ShapeId, RenderObjectData)] -renderObjectsFor mainColor dim t term = fmap catMaybes $ do - forM (subTopes2 dim t) $ \(shapeId, tope) -> do - checkTopeEntails tope >>= \case - False -> return Nothing - True -> typeOf term >>= \case - UniverseTopeT{} -> localTope term $ checkTopeEntails tope >>= \case - False -> return Nothing - True -> return $ Just (shapeId, RenderObjectData - { renderObjectDataLabel = "" - , renderObjectDataFullLabel = "" - , renderObjectDataColor = "orange" -- FIXME: orange for topes? - }) - _ -> do - origs <- asks varOrigs - term' <- localTope tope $ whnfT term - label <- - case term' of - AppT _ (Pure z) arg - | Just (Just "_") <- lookup z origs -> return "" - | null (nub (freeVars (untyped arg)) \\ nub (freeVars (untyped t))) -> - ppTermInContext (Pure z) - _ -> ppTermInContext term' - hide <- asks renderHideTerm - return $ Just (shapeId, hideTermData hide mainColor RenderObjectData - { renderObjectDataLabel = label - , renderObjectDataFullLabel = label - , renderObjectDataColor = - case term' of - Pure{} -> "purple" - AppT _ (Pure x) arg - | Just (Just "_") <- lookup x origs -> mainColor - | null (nub (freeVars (untyped arg)) \\ nub (freeVars (untyped t))) -> "purple" - _ -> mainColor - }) - -componentWiseEQT :: Int -> TermT var -> TermT var -> TermT var -componentWiseEQT 1 t s = topeEQT t s -componentWiseEQT 2 t s = topeAndT - (componentWiseEQT 1 (firstT cube2T t) (firstT cube2T s)) - (componentWiseEQT 1 (secondT cube2T t) (secondT cube2T s)) -componentWiseEQT 3 t s = topeAndT - (componentWiseEQT 2 (firstT (cube2powerT 2) t) (firstT (cube2powerT 2) s)) - (componentWiseEQT 1 (secondT cube2T t) (secondT cube2T s)) -componentWiseEQT dim _ _ = error ("cannot work with " <> show dim <> " dimensions") - -renderObjectsInSubShapeFor - :: Eq var - => String - -> Int - -> [var] - -> var - -> TermT var - -> TermT var - -> TermT var - -> TypeCheck var [(ShapeId, RenderObjectData)] -renderObjectsInSubShapeFor mainColor dim sub super retType f x = fmap catMaybes $ do - let reduceContext - = foldr topeOrT topeBottomT - . map (foldr topeAndT topeTopT) - . map (filter (\tope -> all (`notElem` tope) sub)) - . map (map tTope) - . map (saturateTopes []) - . simplifyLHSwithDisjunctions - contextTopes <- asks (reduceContext . localTopesNF) - contextTopes' <- localTope (componentWiseEQT dim (Pure super) x) $ asks (reduceContext . localTopesNF) - forM (subTopes2 dim (Pure super)) $ \(shapeId, tope) -> do - checkEntails tope contextTopes >>= \case - False -> return Nothing - True -> do - origs <- asks varOrigs - term <- localTope tope (whnfT (appT retType f (Pure super))) - label <- typeOf term >>= \case - UniverseTopeT{} -> return "" - _ -> do - case term of - AppT _ (Pure z) arg - | Just (Just "_") <- lookup z origs -> return "" - | null (nub (freeVars (untyped arg)) \\ [super]) -> ppTermInContext (Pure z) - _ -> ppTermInContext term - color <- checkEntails tope contextTopes' >>= \case - True -> do - case term of - Pure{} -> return "purple" - AppT _ (Pure z) arg - | Just (Just "_") <- lookup z origs -> return mainColor - | null (nub (freeVars (untyped arg)) \\ [super]) -> return "purple" - _ -> return mainColor - False -> return "gray" - hide <- asks renderHideTerm - return $ Just (shapeId, hideTermData hide mainColor RenderObjectData - { renderObjectDataLabel = label - , renderObjectDataFullLabel = label - , renderObjectDataColor = color - }) - -renderForSubShapeSVG - :: Eq var - => String - -> Int - -> [var] - -> var - -> TermT var - -> TermT var - -> TermT var - -> TypeCheck var String -renderForSubShapeSVG mainColor dim sub super retType f x = do - objects <- renderObjectsInSubShapeFor mainColor dim sub super retType f x - let objects' = map mk objects - return $ renderCube defaultCamera (if dim > 2 then (pi/7) else 0) $ \obj -> - lookup obj objects' - where - mk (shapeId, renderData) = (intercalate "-" (map fill shapeId), renderData) - fill xs = xs <> replicate (3 - length xs) '1' - -renderForSVG :: Eq var => String -> Int -> TermT var -> TermT var -> TypeCheck var String -renderForSVG mainColor dim t term = do - objects <- renderObjectsFor mainColor dim t term - let objects' = map mk objects - return $ renderCube defaultCamera (if dim > 2 then (pi/7) else 0) $ \obj -> - lookup obj objects' - where - mk (shapeId, renderData) = (intercalate "-" (map fill shapeId), renderData) - fill xs = xs <> replicate (3 - length xs) '1' - -renderTermSVGFor - :: Eq var - => String -- ^ Main color. - -> Int -- ^ Accumulated dimensions so far (from 0 to 3). - -> (Maybe (TermT var, TermT var), [var]) -- ^ Accumulated point term (and its time). - -> TermT var -- ^ Term to render. - -> TypeCheck var (Maybe String) -renderTermSVGFor mainColor accDim (mp, xs) t = do - t' <- whnfT t - ty <- typeOf t' - case t of -- check unevaluated term - AppT _info f x -> typeOf f >>= \case - TypeFunT _ fOrig md fArg mtopeArg ret | Just dim <- dimOf fArg, dim <= maxDim -> do - enterScope fOrig md fArg $ do - maybe id localTope mtopeArg $ do - Just <$> renderForSubShapeSVG mainColor dim (map S xs) Z ret (S <$> f) (S <$> x) -- FIXME: breaks for 2 * (2 * 2), but works for 2 * 2 * 2 = (2 * 2) * 2 - _ -> traverse (\(p', _) -> renderForSVG mainColor accDim p' t') mp - TypeFunT _ _orig' md' _ _ _ | null xs -> enterScope (BinderVar (Just "_")) md' t' $ do - renderTermSVGFor "blue" 0 (Nothing, []) (Pure Z) -- use blue for types - - _ -> case t' of -- check evaluated term - AppT _info f x -> typeOf f >>= \case - TypeFunT _ fOrig md fArg mtopeArg ret | Just dim <- dimOf fArg, dim <= maxDim -> do - enterScope fOrig md fArg $ do - maybe id localTope mtopeArg $ do - Just <$> renderForSubShapeSVG mainColor dim (map S xs) Z ret (S <$> f) (S <$> x) -- FIXME: breaks for 2 * (2 * 2), but works for 2 * 2 * 2 = (2 * 2) * 2 - _ -> traverse (\(p', _) -> renderForSVG mainColor accDim p' t') mp - TypeFunT _ _orig' md' _ _ _ | null xs -> enterScope (BinderVar (Just "_")) md' t' $ do - renderTermSVGFor "blue" 0 (Nothing, []) (Pure Z) -- use blue for types - - _ -> case ty of -- check type of the term - TypeFunT _ orig md arg mtope ret - | Just dim <- dimOf arg, accDim + dim <= maxDim -> enterScope orig md arg $ do - maybe id localTope mtope $ - renderTermSVGFor mainColor (accDim + dim) - (join' (both (fmap S) <$> mp) (S <$> arg) (Pure Z), Z : map S xs) $ - case t' of - LambdaT _ _orig _marg body -> body - _ -> appT ret (S <$> t') (Pure Z) - | null xs -> enterScope orig md arg $ do - maybe id localTope mtope $ - renderTermSVGFor mainColor accDim - (both (fmap S) <$> mp, map S xs) $ - case t' of - LambdaT _ _orig _marg body -> body - _ -> appT ret (S <$> t') (Pure Z) - _ -> traverse (\(p', _) -> renderForSVG mainColor accDim p' t') mp - where - maxDim = 3 - - both f (x, y) = (f x, f y) - - join' Nothing Cube2T{} x = Just (x, cube2T) - join' (Just (p, pt)) Cube2T{} x = Just (p', pt') - where - pt' = cubeProductT pt cube2T - p' = pairT pt' p x - join' p (CubeProductT _ l r) x = - join' (join' p l (firstT l x)) r (secondT r x) - join' _ _ _ = Nothing -- FIXME: error? - - dimOf = \case - Cube2T{} -> Just 1 - CubeProductT _ l r -> (+) <$> dimOf l <*> dimOf r - _ -> Nothing - -renderTermSVG :: Eq var => TermT var -> TypeCheck var (Maybe String) -renderTermSVG = renderTermSVGFor "red" 0 (Nothing, []) -- use red for terms by default - --- | Render the goal /cell/ for a (shape) type: introduce an abstract inhabitant --- and render it with the proof term hidden. Under a boundary tope an abstract --- inhabitant of an extension type reduces to the prescribed face value, so the --- cell shows its given edges with a blank interior — the shape to inhabit, not --- an answer. 'Nothing' for a non-shape type (a 0-cell or a non-cube goal). -renderGoalCellSVG :: Eq var => TermT var -> TypeCheck var (Maybe String) -renderGoalCellSVG ty = - hidingTerm $ enterScope (BinderVar (Just "_")) Id ty $ renderTermSVG' (Pure Z) - -renderTermSVG' :: Eq var => TermT var -> TypeCheck var (Maybe String) -renderTermSVG' t = whnfT t >>= \t' -> typeOf t >>= \case - TypeFunT _ orig md arg mtope ret -> enterScope orig md arg $ do - maybe id localTope mtope $ case t' of - LambdaT _ _orig _marg (AppT _info f x) -> - typeOf f >>= \case - TypeFunT _ fOrig md2 fArg mtope2 _ret | Just dim <- dimOf fArg -> do - enterScope fOrig md2 fArg $ do - maybe id localTope mtope2 $ do - Just <$> renderForSubShapeSVG "red" dim [S Z] Z (S <$> ret) (S <$> f) (S <$> x) - _ -> defaultRenderTermSVG t' arg ret - _ -> defaultRenderTermSVG t' arg ret - _t' -> return Nothing - where - dimOf = \case - Cube2T{} -> Just 1 - CubeProductT _ l r -> (+) <$> dimOf l <*> dimOf r -- WARNING: breaks for 2 * (2 * 2) - _ -> Nothing - - defaultRenderTermSVG t' arg ret = - case dimOf arg of - Just dim | dim <= 3 -> - Just <$> renderForSVG "red" dim (Pure Z) (appT ret (S <$> t') (Pure Z)) - _ -> renderTermSVG' (appT ret (S <$> t') (Pure Z)) - - -type Point2D a = (a, a) -type Point3D a = (a, a, a) -type Edge3D a = (Point3D a, Point3D a) -type Face3D a = (Point3D a, Point3D a, Point3D a) -type Volume3D a = (Point3D a, Point3D a, Point3D a, Point3D a) - -data CubeCoords2D a b = CubeCoords2D - { vertices :: [(Point3D a, Point2D b)] - , edges :: [(Edge3D a, (Point2D b, Point2D b))] - , faces :: [(Face3D a, (Point2D b, Point2D b, Point2D b))] - , volumes :: [(Volume3D a, (Point2D b, Point2D b, Point2D b, Point2D b))] - } - -data Matrix3D a = Matrix3D - a a a - a a a - a a a - -data Matrix4D a = Matrix4D - a a a a - a a a a - a a a a - a a a a - -data Vector3D a = Vector3D a a a - -data Vector4D a = Vector4D a a a a - -rotateX :: Floating a => a -> Matrix3D a -rotateX theta = Matrix3D - 1 0 0 - 0 (cos theta) (- sin theta) - 0 (sin theta) (cos theta) - -rotateY :: Floating a => a -> Matrix3D a -rotateY theta = Matrix3D - (cos theta) 0 (sin theta) - 0 1 0 - (- sin theta) 0 (cos theta) - -rotateZ :: Floating a => a -> Matrix3D a -rotateZ theta = Matrix3D - (cos theta) (- sin theta) 0 - (sin theta) (cos theta) 0 - 0 0 1 - -data Camera a = Camera - { cameraPos :: Point3D a - , cameraFoV :: a - , cameraAspectRatio :: a - , cameraAngleY :: a - , cameraAngleX :: a - } - -viewRotateX :: Floating a => Camera a -> Matrix4D a -viewRotateX Camera{..} = matrix3Dto4D (rotateX cameraAngleX) - -viewRotateY :: Floating a => Camera a -> Matrix4D a -viewRotateY Camera{..} = matrix3Dto4D (rotateY cameraAngleY) - -viewTranslate :: Num a => Camera a -> Matrix4D a -viewTranslate Camera{..} = Matrix4D - 1 0 0 0 - 0 1 0 0 - 0 0 1 0 - (-x) (-y) (-z) 1 - where - (x, y, z) = cameraPos - -project2D :: Floating a => Camera a -> Matrix4D a -project2D Camera{..} = Matrix4D - (2 * n / (r - l)) 0 ((r + l) / (r - l)) 0 - 0 (2 * n / (t - b)) ((t + b) / (t - b)) 0 - 0 0 (- (f + n) / (f - n)) (- 2 * f * n / (f - n)) - 0 0 (-1) 0 - where - n = 1 - f = 2 - r = n * tan (cameraFoV / 2) - l = -r - t = r * cameraAspectRatio - b = -t - - -matrixVectorMult4D :: Num a => Matrix4D a -> Vector4D a -> Vector4D a -matrixVectorMult4D - (Matrix4D - a1 a2 a3 a4 - b1 b2 b3 b4 - c1 c2 c3 c4 - d1 d2 d3 d4) - (Vector4D a b c d) - = Vector4D a' b' c' d' - where - a' = sum (zipWith (*) [a1, b1, c1, d1] [a, b, c, d]) - b' = sum (zipWith (*) [a2, b2, c2, d2] [a, b, c, d]) - c' = sum (zipWith (*) [a3, b3, c3, d3] [a, b, c, d]) - d' = sum (zipWith (*) [a4, b4, c4, d4] [a, b, c, d]) - -matrix3Dto4D :: Num a => Matrix3D a -> Matrix4D a -matrix3Dto4D - (Matrix3D - a1 b1 c1 - a2 b2 c2 - a3 b3 c3) = Matrix4D - a1 b1 c1 0 - a2 b2 c2 0 - a3 b3 c3 0 - 0 0 0 1 - -fromAffine :: Fractional a => Vector4D a -> (Point2D a, a) -fromAffine (Vector4D a b c d) = ((x, y), zIndex) - where - x = a / d - y = b / d - zIndex = c / d - -point3Dto2D :: Floating a => Camera a -> a -> Point3D a -> (Point2D a, a) -point3Dto2D camera rotY (x, y, z) = fromAffine $ - foldr matrixVectorMult4D (Vector4D x y z 1) $ reverse - [ matrix3Dto4D (rotateY rotY) - , viewTranslate camera - , viewRotateY camera - , viewRotateX camera - , project2D camera - ] - -data RenderObjectData = RenderObjectData - { renderObjectDataLabel :: String - , renderObjectDataFullLabel :: String - , renderObjectDataColor :: String - } - -renderCube - :: (Floating a, Show a) - => Camera a - -> a - -> (String -> Maybe RenderObjectData) - -> String -renderCube camera rotY renderDataOf' = unlines $ filter (not . null) - [ "" - , intercalate "\n" - [ " show x1 <> " " <> show y1 - <> " L " <> show x2 <> " " <> show y2 - <> " L " <> show x3 <> " " <> show y3 - <> " Z\" style=\"fill: " <> renderObjectDataColor <> "; opacity: 0.2\">" <> renderObjectDataFullLabel <> "" <> "\n" <> - " show x <> "\" y=\"" <> show y <> "\" fill=\"" <> renderObjectDataColor <> "\">" <> renderObjectDataLabel <> "" - | (faceId, (((x1, y1), (x2, y2), (x3, y3)), _)) <- faces - , Just RenderObjectData{..} <- [renderDataOf faceId] - , let x = (x1 + x2 + x3) / 3 - , let y = (y1 + y2 + y3) / 3 ] - , intercalate "\n" - [ " show x1 <> "," <> show y1 <> " " <> show x2 <> "," <> show y2 - <> "\" stroke=\"" <> renderObjectDataColor <> "\" stroke-width=\"3\" marker-end=\"url(#arrow)\">" <> renderObjectDataFullLabel <> "" <> "\n" <> - " show x <> "\" y=\"" <> show y <> "\" fill=\"" <> renderObjectDataColor <> "\" stroke=\"white\" stroke-width=\"10\" stroke-opacity=\".8\" paint-order=\"stroke\">" <> renderObjectDataLabel <> "" - | (edge, (((x1, y1), (x2, y2)), _)) <- edges - , Just RenderObjectData{..} <- [renderDataOf edge] - , let x = (x1 + x2) / 2 - , let y = (y1 + y2) / 2 ] - , intercalate "\n" - [ " show x <> "\" y=\"" <> show y <> "\" fill=\"" <> renderObjectDataColor <> "\">" <> renderObjectDataLabel <> "" - | (v, ((x, y), _)) <- vertices - , Just RenderObjectData{..} <- [renderDataOf v]] - , "" ] - where - renderDataOf shapeId = - case renderDataOf' shapeId of - Nothing -> Nothing - Just RenderObjectData{..} -> Just RenderObjectData - -- FIXME: move constants to configurable parameters - { renderObjectDataLabel = hideWhenLargerThan shapeId 5 renderObjectDataLabel - , renderObjectDataFullLabel = limitLength 30 renderObjectDataFullLabel - , .. } - - hideWhenLargerThan shapeId n s - | null s || length s > n = if '-' `elem` shapeId then "" else "•" - | otherwise = s - - vertices = - [ (show x <> show y <> show z, ((500 * x'', 500 * y''), zIndex)) - | x <- [0,1] - , y <- [0,1] - , z <- [0,1] - , let f c = 2 * fromInteger c - 1 - , let x' = f x - , let y' = f (1-y) - , let z' = f z - , let ((x'', y''), zIndex) = point3Dto2D camera rotY (x', y', z') ] - - radius = 20 - - mkEdge r (x1, y1) (x2, y2) = ((x1 + dx, y1 + dy), ((x2 - dx), (y2 - dy))) - where - d = sqrt ((x2 - x1)^2 + (y2 - y1)^2) - dx = r * (x2 - x1) / d - dy = r * (y2 - y1) / d - - scaleAround (cx, cy) s (x, y) = (cx + s * (x - cx), cy + s * (y - cy)) - - mkFace (x1, y1) (x2, y2) (x3, y3) = (p1, p2, p3) - where - cx = (x1 + x2 + x3) / 3 - cy = (y1 + y2 + y3) / 3 - p1 = scaleAround (cx, cy) 0.85 (x1, y1) - p2 = scaleAround (cx, cy) 0.85 (x2, y2) - p3 = scaleAround (cx, cy) 0.85 (x3, y3) - - edges = - [ (intercalate "-" [fromName, toName], (mkEdge radius from to, 0)) - | (fromName, (from, _)) : vs <- tails vertices - , (toName, (to, _)) <- vs - , and (zipWith (<=) fromName toName) - ] - - faces = - [ (intercalate "-" [name1, name2, name3], (mkFace v1 v2 v3, 0)) - | (name1, (v1, _)) : vs <- tails vertices - , (name2, (v2, _)) : vs' <- tails vs - , and (zipWith (<=) name1 name2) - , (name3, (v3, _)) <- vs' - , and (zipWith (<=) name2 name3) - ] - - -defaultCamera :: Floating a => Camera a -defaultCamera = Camera - { cameraPos = (0, 7, 10) - , cameraAngleY = pi - , cameraAngleX = pi/5 - , cameraFoV = pi/15 - , cameraAspectRatio = 1 - } - --- * Elaborated types of local binders (for LSP hover) - --- | Naming environment for rendering types found under binders: how to --- display each variable, plus the pattern binders passed on the way down, --- for projection restoration (as in 'recordHoleShape'). -data BinderNames var = BinderNames - { binderNameOf :: var -> VarIdent - , binderNameProjs :: [(VarIdent, [([Proj], VarIdent)])] - , binderNamePats :: [(VarIdent, Binder)] - } - -topLevelBinderNames :: BinderNames VarIdent -topLevelBinderNames = BinderNames id [] [] - -renderBinderType :: BinderNames var -> TermT var -> Term' -renderBinderType names t = - restorePatternVars (binderNamePats names) - (foldBinderProjections (binderNameProjs names) (untyped (binderNameOf names <$> t))) - -underBinder :: Binder -> BinderNames var -> BinderNames (Inc var) -underBinder binder names = BinderNames - { binderNameOf = \case - Z -> zName - S v -> binderNameOf names v - , binderNameProjs = case binder of - BinderVar{} -> binderNameProjs names - _ -> (zName, binderPaths binder) : binderNameProjs names - , binderNamePats = case binder of - BinderVar{} -> binderNamePats names - _ -> (zName, binder) : binderNamePats names - } - where - zName = binderDisplayName binder - --- | The memoised weak head normal form of a typed term, if present. -memoWHNF :: TermT var -> TermT var -memoWHNF t@(Free (AnnF info _)) = fromMaybe t (infoWHNF info) -memoWHNF t = t - - --- | The variables a binder introduces, with rendered types. A pair binder --- splits its type along Σ-types and cube products; when the shape is not --- syntactic (e.g. the type is a defined name applied to arguments, as in --- @((η , (ϵ , (α , β))) : has-quasi-diagrammatic-adj A B f u)@), the type is --- put in weak head normal form first, which needs the global declarations in --- scope (see 'binderTypesInScopeOf'). The dependent part is rendered under --- the earlier component's display name, giving @q : B p@. --- | A binder's displayed type: a plain type, or a cube together with a tope --- for shaped binders like @(t : I | φ t)@. -data BinderTypeView - = TypeView Term' - | ShapeView Term' Term' - -binderTypeEntriesM :: Eq var => BinderNames var -> Binder -> TermT var -> TypeCheck var [(VarIdent, BinderTypeView)] -binderTypeEntriesM names binder ty = case binder of - BinderUnit -> pure [] - BinderVar Nothing -> pure [] - BinderVar (Just x) -> pure [(x, TypeView (renderBinderType names ty))] - BinderPair l r -> splitViewM ty >>= \case - Just (TypeSigmaT _ _ md a bscope) -> do - ls <- binderTypeEntriesM names l a - rs <- enterScope l md a (binderTypeEntriesM (underBinder l names) r bscope) - pure (ls ++ rs) - Just (CubeProductT _ a b) -> - (++) <$> binderTypeEntriesM names l a <*> binderTypeEntriesM names r b - _ -> pure [] -- unrecognised shape; the surface annotation is the fallback - --- | View a type as a Σ-type or cube product: syntactically or through the --- memoised WHNF if possible, computing the WHNF otherwise. Never throws. -splitViewM :: Eq var => TermT var -> TypeCheck var (Maybe (TermT var)) -splitViewM ty = case splitView (memoWHNF ty) of - Just t -> pure (Just t) - Nothing -> (splitView <$> whnfT ty) `catchError` \_ -> pure Nothing - where - splitView t = case stripTypeRestrictions t of - t'@TypeSigmaT{} -> Just t' - t'@CubeProductT{} -> Just t' - _ -> Nothing - --- | Elaborated types of the local binders of a typed term, keyed by the --- binder's original identifier (whose position points at its defining --- occurrence). Every node of a typed term carries its type, so even a bare --- lambda's binder is typed, by the domain of the lambda's own Π-type. -binderTypesOfTermM :: Eq var => BinderNames var -> TermT var -> TypeCheck var [(VarIdent, BinderTypeView)] -binderTypesOfTermM names = go - where - go t = case t of - Pure _ -> pure [] - LambdaT info binder mparam body -> do - (paramType, paramTope) <- case mparam of - Just (_, ty, mtope) -> pure (Just ty, mtope) - -- A bare lambda: the domain (and shape) of its own Π-type. - Nothing -> case funView (memoWHNF (infoType info)) of - Just (p, mtope) -> pure (Just p, mtope) - Nothing -> - (maybe (Nothing, Nothing) (\(p, mtope) -> (Just p, mtope)) . funView - <$> whnfT (infoType info)) - `catchError` \_ -> pure (Nothing, Nothing) - entries <- shapedBinderEntries names binder paramType paramTope - annEntries <- case mparam of - Nothing -> pure [] - Just (md, ty, mtope) -> do - tyEntries <- go ty - topeEntries <- maybe (pure []) (enterScope binder md ty . under binder) mtope - pure (tyEntries ++ topeEntries) - let md = maybe Id (\(m, _, _) -> m) mparam - bodyEntries <- enterScope binder md (fromMaybe universeT paramType) (under binder body) - pure (entries ++ annEntries ++ bodyEntries) - TypeFunT _ binder md param mtope ret -> do - entries <- shapedBinderEntries names binder (Just param) mtope - paramEntries <- go param - topeEntries <- maybe (pure []) (enterScope binder md param . under binder) mtope - retEntries <- enterScope binder md param (under binder ret) - pure (entries ++ paramEntries ++ topeEntries ++ retEntries) - TypeSigmaT _ binder md a bscope -> do - entries <- binderTypeEntriesM names binder a - aEntries <- go a - bEntries <- enterScope binder md a (under binder bscope) - pure (entries ++ aEntries ++ bEntries) - LetT _ binder manno value body -> do - let valueType = case value of - Free (AnnF valueInfo _) -> Just (infoType valueInfo) - Pure _ -> manno - entries <- maybe (pure []) (binderTypeEntriesM names binder) valueType - annEntries <- maybe (pure []) go manno - valueEntries <- go value - bodyEntries <- enterScopeWithBind binder Id (fromMaybe universeT valueType) value - (under binder body) - pure (entries ++ annEntries ++ valueEntries ++ bodyEntries) - LetModT _ binder _nu mu manno value body -> do - unwrapped <- case value of - Pure _ -> pure Nothing - Free (AnnF valueInfo _) -> do - let vt = infoType valueInfo - case modalView (memoWHNF vt) of - Just a -> pure (Just a) - Nothing -> (modalView <$> whnfT vt) `catchError` \_ -> pure Nothing - entries <- maybe (pure []) (binderTypeEntriesM names binder) unwrapped - annEntries <- maybe (pure []) go manno - valueEntries <- go value - bodyEntries <- enterScope binder mu (fromMaybe universeT unwrapped) (under binder body) - pure (entries ++ annEntries ++ valueEntries ++ bodyEntries) - Free (AnnF _ f) -> concat <$> mapM go (bifoldr (\_ acc -> acc) (:) [] f) - under binder = binderTypesOfTermM (underBinder binder names) - funView t = case stripTypeRestrictions t of - TypeFunT _ _ _ param mtope _ -> Just (param, mtope) - _ -> Nothing - modalView t = case stripTypeRestrictions t of - TypeModalT _ _ a -> Just a - _ -> Nothing - -- A shaped plain binder shows its cube together with the tope, as it is - -- written: (t : I | φ t). A shaped pair binder splits along the cube, - -- the tope constraining the components jointly (as in the surface tier). - shapedBinderEntries names' binder mty mtope = case (binder, mty, mtope) of - (BinderVar (Just x), Just cube, Just tope) -> - pure [(x, ShapeView (renderBinderType names' cube) - (renderBinderType (underBinder binder names') tope))] - (_, Just ty, _) -> binderTypeEntriesM names' binder ty - _ -> pure [] - --- | All local binder types of a declaration: Π and Σ binders from the type, --- lambda and let binders from the value. -declBinderTypes :: Decl' -> TypeCheck VarIdent [(VarIdent, BinderTypeView)] -declBinderTypes decl = - (++) <$> binderTypesOfTermM topLevelBinderNames (declType decl) - <*> maybe (pure []) (binderTypesOfTermM topLevelBinderNames) (declValue decl) - --- | Elaborated types of the local binders of @fileDecls@, with @globalDecls@ --- in scope so that 'whnfT' can unfold definitions when splitting pair --- binders. Pure at the interface: runs the checker silently and returns no --- entries where it fails. -binderTypesInScopeOf :: [Decl'] -> [Decl'] -> [(VarIdent, BinderTypeView)] -binderTypesInScopeOf globalDecls fileDecls = - case defaultTypeCheck action of - Left _ -> [] - Right entries -> entries - where - action = localVerbosity Silent $ - localDeclsPrepared globalDecls $ - concat <$> mapM declBinderTypes fileDecls +-- | The type checker. +-- +-- This module is the public face of it: the judgements themselves live in +-- "Rzk.TypeCheck.Judgements", the module driver and the declarations in +-- "Rzk.TypeCheck.Decl", and so on. What used to be one 5,500-line module is now a +-- layer per concern, over the free-foil core in "Language.Rzk.Foil.Syntax". +module Rzk.TypeCheck ( + module Rzk.TypeCheck.Context, + module Rzk.TypeCheck.Display, + module Rzk.TypeCheck.Error, + module Rzk.TypeCheck.Monad, + module Rzk.TypeCheck.Eval, + module Rzk.TypeCheck.Judgements, + module Rzk.TypeCheck.Decl, + module Rzk.TypeCheck.BinderTypes, +) where + +import Rzk.TypeCheck.BinderTypes +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Decl +import Rzk.TypeCheck.Display +import Rzk.TypeCheck.Error +import Rzk.TypeCheck.Eval +import Rzk.TypeCheck.Judgements +import Rzk.TypeCheck.Monad diff --git a/src/Rzk/TypeCheck/BinderTypes.hs b/src/Rzk/TypeCheck/BinderTypes.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/BinderTypes.hs @@ -0,0 +1,213 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The elaborated types of a declaration's local binders, for LSP hover. +-- +-- Every node of a typed term carries its type, so even a bare λ's binder is typed +-- — by the domain of the λ's own Π-type. +-- +-- The old version threaded a @BinderNames@ environment down through the term, to +-- say what each variable it met was called. There is no need: entering a binder +-- puts it in the context, and the context already knows what everything in it is +-- called (see "Rzk.TypeCheck.Display"). +module Rzk.TypeCheck.BinderTypes where + +import Control.Monad.Except (catchError) +import Control.Monad.Reader (asks) +import Data.Bifoldable (bifoldr) +import Data.Maybe (fromMaybe) + +import Control.Monad.Foil (Distinct) +import Control.Monad.Free.Foil (AST (Node, Var)) + +import Control.Monad.Free.Foil.Annotated (AnnSig (..)) +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), TModality (..), + TypeInfo (..), VarIdent) +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Decl +import Rzk.TypeCheck.Display +import Rzk.TypeCheck.Eval +import Rzk.TypeCheck.Monad + +-- | A binder's displayed type: a plain type, or a cube together with a tope, for a +-- shaped binder like @(t : I | φ t)@. +data BinderTypeView + = TypeView Rendered + | ShapeView Rendered Rendered + deriving (Eq, Show) + +-- | Render a term with the names of the context it is in. +renderHere :: TermT n -> TypeCheck n Rendered +renderHere t = do + naming <- asks namingOfContext + pure (renderTerm naming (untyped t)) + +-- | The memoised weak head normal form of a typed term, if present. +memoWHNF :: TermT n -> TermT n +memoWHNF t = fromMaybe t (typeInfoOf t >>= infoWHNF) + +-- | The variables a binder introduces, with their rendered types. +-- +-- A pair binder splits its type along Σ-types and cube products; when the shape is +-- not syntactic (the type is a defined name applied to arguments, as in +-- @((η , (ϵ , (α , β))) : has-quasi-diagrammatic-adj A B f u)@), the type is put in +-- weak head normal form first, which needs the top-level definitions in scope. The +-- dependent part is rendered under the earlier component's display name, giving +-- @q : B p@. +binderTypeEntries + :: Distinct n => Binder -> TermT n -> TypeCheck n [(VarIdent, BinderTypeView)] +binderTypeEntries binder ty = case binder of + BinderUnit -> pure [] + BinderVar Nothing -> pure [] + BinderVar (Just x) -> do + rendered <- renderHere ty + pure [(x, TypeView rendered)] + BinderPair l r -> splitViewM ty >>= \case + Just (TypeSigmaT _ _ md a bscope) -> do + ls <- binderTypeEntries l a + rs <- inScope l md a bscope $ \bBody -> binderTypeEntries r bBody + pure (ls ++ rs) + Just (CubeProductT _ a b) -> + (++) <$> binderTypeEntries l a <*> binderTypeEntries r b + _ -> pure [] -- unrecognised shape; the surface annotation is the fallback + +-- | View a type as a Σ-type or a cube product: syntactically, or through the +-- memoised WHNF if possible, computing the WHNF otherwise. Never throws. +splitViewM :: Distinct n => TermT n -> TypeCheck n (Maybe (TermT n)) +splitViewM ty = case splitView (memoWHNF ty) of + Just t -> pure (Just t) + Nothing -> (splitView <$> whnfT ty) `catchError` \_ -> pure Nothing + where + splitView t = case stripTypeRestrictions t of + t'@TypeSigmaT{} -> Just t' + t'@CubeProductT{} -> Just t' + _ -> Nothing + +-- | The elaborated types of the local binders of a typed term, keyed by the +-- binder's original identifier (whose position points at its defining occurrence). +binderTypesOfTerm + :: Distinct n => TermT n -> TypeCheck n [(VarIdent, BinderTypeView)] +binderTypesOfTerm = go + where + go :: Distinct n => TermT n -> TypeCheck n [(VarIdent, BinderTypeView)] + go t = case t of + Var _ -> pure [] + + LambdaT info binder mparam body -> do + (paramType, paramTope) <- case mparam of + Just (LambdaParam _ ty mtope) -> pure (Just ty, mtope) + -- A bare λ: the domain (and shape) of its own Π-type. + Nothing -> case funView (memoWHNF (infoType info)) of + Just (p, mtope) -> pure (Just p, mtope) + Nothing -> + (maybe (Nothing, Nothing) (\(p, mtope) -> (Just p, mtope)) . funView + <$> whnfT (infoType info)) + `catchError` \_ -> pure (Nothing, Nothing) + entries <- shapedBinderEntries binder paramType paramTope + let md = maybe Id (\(LambdaParam m _ _) -> m) mparam + annEntries <- case mparam of + Nothing -> pure [] + Just (LambdaParam _ ty mtope) -> do + tyEntries <- go ty + topeEntries <- case mtope of + Nothing -> pure [] + Just tope -> inScope binder md ty tope go + pure (tyEntries ++ topeEntries) + bodyEntries <- + inScope binder md (fromMaybe universeT paramType) body go + pure (entries ++ annEntries ++ bodyEntries) + + TypeFunT _ binder md param mtope ret -> do + entries <- shapedBinderEntries binder (Just param) mtope + paramEntries <- go param + topeEntries <- case mtope of + Nothing -> pure [] + Just tope -> inScope binder md param tope go + retEntries <- inScope binder md param ret go + pure (entries ++ paramEntries ++ topeEntries ++ retEntries) + + TypeSigmaT _ binder md a bscope -> do + entries <- binderTypeEntries binder a + aEntries <- go a + bEntries <- inScope binder md a bscope go + pure (entries ++ aEntries ++ bEntries) + + LetT _ binder manno value body -> do + let valueType = case typeInfoOf value of + Just valueInfo -> Just (infoType valueInfo) + Nothing -> manno + entries <- maybe (pure []) (binderTypeEntries binder) valueType + annEntries <- maybe (pure []) go manno + valueEntries <- go value + bodyEntries <- inScopeWith binder Id (fromMaybe universeT valueType) (Just value) body go + pure (entries ++ annEntries ++ valueEntries ++ bodyEntries) + + LetModT _ binder _nu mu manno value body -> do + unwrapped <- case typeInfoOf value of + Nothing -> pure Nothing + Just valueInfo -> do + let vt = infoType valueInfo + case modalView (memoWHNF vt) of + Just a -> pure (Just a) + Nothing -> (modalView <$> whnfT vt) `catchError` \_ -> pure Nothing + entries <- maybe (pure []) (binderTypeEntries binder) unwrapped + annEntries <- maybe (pure []) go manno + valueEntries <- go value + bodyEntries <- inScope binder mu (fromMaybe universeT unwrapped) body go + pure (entries ++ annEntries ++ valueEntries ++ bodyEntries) + + Node (AnnSig _ f) -> + concat <$> mapM go (bifoldr (\_ acc -> acc) (:) [] f) + + funView t = case stripTypeRestrictions t of + TypeFunT _ _ _ param mtope _ -> Just (param, mtope) + _ -> Nothing + modalView t = case stripTypeRestrictions t of + TypeModalT _ _ a -> Just a + _ -> Nothing + + -- A shaped plain binder shows its cube together with the tope, as it is + -- written: (t : I | φ t). A shaped pair binder splits along the cube, the tope + -- constraining the components jointly (as in the surface tier). + shapedBinderEntries + :: Distinct n + => Binder -> Maybe (TermT n) -> Maybe (ScopedTermT n) + -> TypeCheck n [(VarIdent, BinderTypeView)] + shapedBinderEntries binder mty mtope = case (binder, mty, mtope) of + (BinderVar (Just x), Just cube, Just tope) -> do + cubeR <- renderHere cube + topeR <- inScope binder Id cube tope renderHere + pure [(x, ShapeView cubeR topeR)] + (_, Just ty, _) -> binderTypeEntries binder ty + _ -> pure [] + +-- | All the local binder types of a declaration: Π and Σ binders from its type, +-- λ and let binders from its value. +declBinderTypes + :: Distinct n => Decl n -> TypeCheck n [(VarIdent, BinderTypeView)] +declBinderTypes decl = + (++) <$> binderTypesOfTerm (declType decl) + <*> maybe (pure []) binderTypesOfTerm (declValue decl) + +-- | The elaborated types of the local binders of one file's declarations, with the +-- rest of the run's declarations in scope so that 'whnfT' can unfold definitions +-- when splitting pair binders. +-- +-- Pure at the interface: it runs the checker silently and returns no entries where +-- it fails. +binderTypesOfFile :: Checked -> FilePath -> [(VarIdent, BinderTypeView)] +binderTypesOfFile (Checked ctx decls _errs) path = + case runTypeCheckIn ctx action of + Left _ -> [] + Right entries -> entries + where + fileDecls = concat [ ds | (p, ds) <- decls, p == path ] + action = localVerbosity Silent $ + concat <$> mapM declBinderTypes fileDecls diff --git a/src/Rzk/TypeCheck/Context.hs b/src/Rzk/TypeCheck/Context.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/Context.hs @@ -0,0 +1,476 @@ +-- The scope-extension evidence on the three sinkers that are coercions +-- ('sinkContextUnchecked', 'sinkVars', 'sinkNamed') is their soundness contract, +-- not an argument they can consume, so GHC calls it redundant. It stays. +{-# OPTIONS_GHC -fno-warn-name-shadowing -fno-warn-redundant-constraints #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The typing context on free-foil. +-- +-- The successor of @Rzk.TypeCheck@'s @Context var@. Two things change, and they +-- are the point of the migration. +-- +-- [A variable is a name, and so is a top-level entry.] A free-foil term refers to +-- a variable by 'Foil.Name' (an @Int@), and by nothing else: there is no way to +-- put a 'VarIdent' inside a term. So a top-level definition is a name too, bound +-- in the outermost scope with no binder above it, and the hypotheses — global and +-- local alike — are one 'Foil.NameMap', looked up in constant time. The old +-- context was an association list keyed by a @var@ whose equality walked an +-- @S@-chain; @lookupVarInfo@ alone was 11.5% of the checker's time. The surface +-- name of an entry is resolved through 'ctxNamed'. +-- +-- This also gives sections their natural shape. A @#assume@d assumption is an +-- ordinary binder, so the definitions of a section are checked in its scope, and +-- closing the section abstracts the assumption by pairing its binder with the +-- body — no rewrite of the elaborated terms (see @Rzk.TypeCheck.Decl@). +-- +-- [Entering a binder rebuilds nothing.] 'enterBinder' extends the scope and +-- sinks the rest of the context by coercion, so it costs O(1) rather than a walk +-- of the context. The old @enterScopeContext@ mapped @S \<$\>@ over the whole +-- context, rebuilding every elaborated term it held; the heap profile showed +-- those forced copies retaining most of the live heap, and @GlobalScopeInfo@ / +-- @globalEmbed@ (PR #277) exist only to keep that shift off the ~1500 top-level +-- entries. All of that machinery is gone. +module Rzk.TypeCheck.Context where + +import Control.Monad.Foil (DExt, Distinct, NameBinder, + NameMap, Scope) +import qualified Control.Monad.Foil as Foil +-- NOTE: free-foil 0.2.0 gives 'NameMap' no 'Functor' instance (it has one on the +-- unreleased main), so 'mapNameMap' goes through the underlying 'IntMap'. +import Control.Monad.Foil.Internal (NameMap (..)) +import qualified Data.IntMap as IntMap +import Data.Map (Map) +import qualified Data.Map as Map +import Unsafe.Coerce (unsafeCoerce) + +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), TModality (..), + VarIdent, binderName) +import qualified Language.Rzk.Syntax as Rzk + +-- * The pieces of a context + +data Covariance + = Covariant -- ^ Positive position. + | Contravariant -- ^ Negative position. + | Invariant -- ^ Unknown position. + +data RenderBackend + = RenderSVG + | RenderLaTeX + +data Verbosity + = Debug + | Normal + | Silent + deriving (Eq, Ord) + +data LocationInfo = LocationInfo + { locationFilePath :: Maybe FilePath + , locationLine :: Maybe Int + } deriving (Eq, Show) + +-- | What is known about a hypothesis, local or top-level. +data VarInfo n = VarInfo + { varType :: TermT n + , varValue :: Maybe (TermT n) + , varModality :: TModality + , varModAccum :: TModality + , varOrig :: Binder + -- ^ the names the binder introduced, for display only + , varIsAssumption :: Bool -- FIXME: perhaps, introduce something like decl kind? + , varIsTopLevel :: Bool + , varDeclaredAssumptions :: [Foil.Name n] + , varLocation :: Maybe LocationInfo + } + +-- | A tope, together with the modalities under which it is available. +data ModalTope n = ModalTope + { tModAccum :: TModality + , tModVar :: TModality + , tTope :: TermT n + } + +-- | The judgement being performed, for tracing and for the error report. +data Action n + = ActionTypeCheck (Term n) (TermT n) + | ActionUnify (TermT n) (TermT n) (TermT n) + | ActionUnifyTerms (TermT n) (TermT n) + | ActionInfer (Term n) + | ActionContextEntailedBy [TermT n] (TermT n) + | ActionContextEntails [TermT n] (TermT n) + | ActionContextEntailsUnion [TermT n] [TermT n] + | ActionWHNF (TermT n) + | ActionNF (TermT n) + | ActionCheckCoherence (TermT n, TermT n) (TermT n, TermT n) + | ActionCloseSection (Maybe Rzk.SectionName) + | ActionCheckLetValue (Maybe VarIdent) + +-- | The state of the tope-saturation cache in a 'Context' +-- (see 'ctxTopesSaturated'). +data CachedSaturation n + = SaturationUncached + -- ^ No cache was installed for this tope context (entailment falls back to + -- the per-query pipeline). + | SaturationCached (Maybe [[ModalTope n]]) + -- ^ A deferred pipeline run: forced by the first query under this context. + -- 'Nothing' records that the pipeline errored; queries then fall back, so + -- the error surfaces exactly where it would have. + +-- * The context + +data Context n = Context + { ctxScope :: Scope n + -- ^ Every name in scope: the top-level entries, the section assumptions and + -- the binders entered on the way here. Substitution and freshness need it. + , ctxVars :: NameMap n (VarInfo n) + -- ^ What each name in scope stands for. Total on 'ctxScope', which is what + -- 'Foil.lookupName' assumes. + , ctxNamed :: Map VarIdent (Foil.Name n) + -- ^ The surface name of each top-level entry (and of each named binder), for + -- resolving an identifier the parser produced. + , ctxBound :: [Foil.Name n] + -- ^ Every name in scope, most recently bound first. + -- + -- The order has to be recorded, not recovered: free-foil refreshes a binder + -- only when its name clashes, so after a substitution an inner binder may + -- well carry a /smaller/ id than an outer one (@\\ x2 -> \\ x1 -> …@), and the + -- ascending order of 'ctxVars' is not the order things were bound in. Display + -- depends on this: names claim their display name oldest-first, so that an + -- inner binder is the one refreshed away from an outer name, and not the + -- other way round. + , ctxSections :: [SectionInfo n] + -- ^ The open sections, innermost first. Each records the entries declared in + -- it, so closing it can turn them into declarations. + , ctxDiscreteTopes :: [ModalTope n] + -- ^ Discreteness axioms for the flat cube variables in scope (a flat point of + -- @2@ or @I@ is an endpoint). Maintained at binder entry, so entailment does + -- not rescan the context on every query. + , ctxTopes :: [ModalTope n] + , ctxTopesNF :: [ModalTope n] + , ctxTopesNFUnion :: [[ModalTope n]] + , ctxTopesEntailBottom :: Maybe Bool + , ctxTopesSaturated :: CachedSaturation n + -- ^ The saturated alternatives for this tope context, cached at the points + -- where the tope context changes. + , ctxShadow :: Map VarIdent [VarIdent] + -- ^ The identifiers in scope, keyed by their spelling (a 'VarIdent' compares by + -- spelling and carries the position of its defining occurrence, so the values + -- are what a shadowing report names). + -- + -- The check runs at every binder entry, and scanning every name in scope each + -- time was O(context) per binder — with every top-level definition of a project + -- in scope, that is most of them. + , ctxActionStack :: [Action n] + , ctxActionStackDepth :: Int + -- ^ The length of 'ctxActionStack', maintained alongside it: measuring the + -- list on every judgement made each action cost O(depth), and each path + -- O(depth²). + , ctxCurrentCommand :: Maybe Rzk.Command + , ctxLocation :: Maybe LocationInfo + , ctxVerbosity :: Verbosity + , ctxCovariance :: Covariance + , ctxRenderBackend :: Maybe RenderBackend + , ctxRenderHideTerm :: Bool + -- ^ When rendering a diagram, hide the proof term: drop the @\@ (which + -- carries the full term) from every cell and blank the visible label of + -- proof-coloured (interior) cells, keeping the given boundary labels. + , ctxHolesAreErrors :: Bool + -- ^ When 'True' (the default), an unfilled hole is reported as a + -- @TypeErrorUnsolvedHole@; finished work (and CI) must have no holes. The + -- lenient mode ('allowHoles') instead records each hole's goal and context. + , ctxDeferHoleMismatches :: Bool + -- ^ How holes behave during unification, giving three modes overall. With + -- 'ctxHolesAreErrors' a hole is rejected outright (strict). Otherwise a hole + -- always unifies as a leaf; this flag then chooses what happens when the + -- /surrounding/ structure disagrees: 'True' (the default) defers — any term + -- containing a hole is accepted, for an in-progress sketch — while 'False' + -- keeps such a mismatch an error ('structuralHoleUnify'). + , ctxHintLemmas :: [VarIdent] + -- ^ Named top-level definitions a hole's candidate list may draw on, beyond + -- the local hypotheses (see 'withHintLemmas'). + , ctxWarnOverhang :: Bool + -- ^ When 'True', a restriction face or @recOR@ guard that overhangs the + -- local tope context (is not entailed by it, while still overlapping it) + -- is reported with a non-fatal hint. Off by default: deciding the + -- overhang costs a solver entailment per face and guard, and the overhang + -- is legitimate (see @happy-restrict-face-not-contained@). Enabled with + -- @#set-option "warn-overhang" "yes"@. The /disjointness/ error next to + -- it is unaffected: a vacuous face is always rejected. + } + +-- | An open section: the entries declared in it, newest first. +data SectionInfo n = SectionInfo + { sectionName :: Maybe Rzk.SectionName + , sectionEntries :: [Foil.Name n] + } + +emptyContext :: Context Foil.VoidS +emptyContext = Context + { ctxScope = Foil.emptyScope + , ctxVars = Foil.emptyNameMap + , ctxNamed = Map.empty + , ctxBound = [] + , ctxSections = [SectionInfo Nothing []] + , ctxDiscreteTopes = [] + , ctxTopes = emptyTopeContext + , ctxTopesNF = emptyTopeContext + , ctxTopesNFUnion = [emptyTopeContext] + , ctxTopesEntailBottom = Just False + , ctxTopesSaturated = SaturationUncached + , ctxShadow = Map.empty + , ctxActionStack = [] + , ctxActionStackDepth = 0 + , ctxCurrentCommand = Nothing + , ctxLocation = Nothing + , ctxVerbosity = Normal + , ctxCovariance = Covariant + , ctxRenderBackend = Nothing + , ctxRenderHideTerm = False + , ctxHolesAreErrors = True + , ctxDeferHoleMismatches = True + , ctxHintLemmas = [] + , ctxWarnOverhang = False + } + +-- | The tope context of an empty context: @⊤@ holds under every modality. +emptyTopeContext :: [ModalTope n] +emptyTopeContext = + [ ModalTope Id Id topeTopT + , ModalTope Id Flat topeTopT + , ModalTope Id Op topeTopT + , ModalTope Id Sharp topeTopT + ] + +-- * Entering a binder +-- +-- $sinking +-- +-- Everything in a context that mentions the scope is a term, or a container of +-- terms, and so is sinkable: a term whose free names lie in @n@ has its free +-- names in any @l@ that extends @n@. free-foil sinks such a value by coercion +-- (@sink = unsafeCoerce@, sound because @DExt n l@ makes the renaming the +-- identity on raw names; see §3.5 of the Foil paper), and the same argument +-- applies to a whole record of them: renaming every field along the identity is +-- the identity on the representation. +-- +-- Two fields are /not/ sinkable, and 'enterBinder' restores both in the same +-- breath, which is why the coercion below is not exported: +-- +-- * 'ctxScope' is the set of names /in/ @n@. It has to grow, not coerce — +-- tellingly, free-foil gives 'Foil.Scope' no 'Foil.Sinkable' instance. +-- * 'ctxVars' must stay total on the names in scope ('Foil.lookupName' assumes +-- it), so the new binder's entry has to be added. + +-- | Sink a context along a scope extension. Unsound on its own: leaves 'ctxScope' +-- and 'ctxVars' describing the /old/ scope, and the caller must fix both. See the +-- note above; 'enterBinder' is the only caller. +sinkContextUnchecked :: DExt n l => Context n -> Context l +sinkContextUnchecked = unsafeCoerce + +-- | Enter the scope of a binder: extend the scope with it, record what it is +-- called and what it stands for, and carry the rest of the context in. +enterBinder + :: DExt n l + => NameBinder n l + -> VarInfo n -- ^ its type, value and modality + -> [ModalTope l] -- ^ discreteness axioms the binder brings (a flat cube point, + -- which are about the variable itself, hence at its scope) + -> Context n + -> Context l +enterBinder binder info discrete ctx = (sinkContextUnchecked ctx) + { ctxScope = Foil.extendScope binder (ctxScope ctx) + , ctxVars = Foil.addNameBinder binder (Foil.sink info) (sinkVars (ctxVars ctx)) + , ctxBound = Foil.nameOf binder : sinkNames (ctxBound ctx) + , ctxNamed = case binderName (varOrig info) of + Nothing -> sinkNamed (ctxNamed ctx) + Just name -> Map.insert name (Foil.nameOf binder) (sinkNamed (ctxNamed ctx)) + , ctxDiscreteTopes = discrete <> sinkTopes (ctxDiscreteTopes ctx) + , ctxShadow = addBinderNames (varOrig info) (ctxShadow ctx) + } + +-- | Enter a /fresh/ binder: one the checker invents rather than one a term +-- carries (to look under a Π when comparing two of them, say). +withFreshBinder + :: Distinct n + => Context n + -> VarInfo n + -> (forall l. DExt n l => NameBinder n l -> Context l -> r) + -> r +withFreshBinder ctx info k = + Foil.withFresh (ctxScope ctx) $ \binder -> + k binder (enterBinder binder info [] ctx) + +-- | Record the name a binder introduces (if any), for the shadowing check. +addBinderNames :: Binder -> Map VarIdent [VarIdent] -> Map VarIdent [VarIdent] +addBinderNames orig names = + case binderName orig of + Nothing -> names + Just name -> Map.insertWith (<>) name [name] names + +-- | The identifiers in scope spelled like this one. +shadowedBy :: VarIdent -> Context n -> [VarIdent] +shadowedBy name ctx = Map.findWithDefault [] name (ctxShadow ctx) + +-- * Sinking the parts + +instance Foil.Sinkable VarInfo where + sinkabilityProof rename info = info + { varType = Foil.sinkabilityProof rename (varType info) + , varValue = Foil.sinkabilityProof rename <$> varValue info + , varDeclaredAssumptions = rename <$> varDeclaredAssumptions info + } + +instance Foil.Sinkable ModalTope where + sinkabilityProof rename tope = + tope { tTope = Foil.sinkabilityProof rename (tTope tope) } + +sinkVars :: DExt n l => NameMap n (VarInfo n) -> NameMap n (VarInfo l) +sinkVars = Foil.sinkContainer + +sinkTopes :: DExt n l => [ModalTope n] -> [ModalTope l] +sinkTopes = Foil.sinkContainer + +sinkNamed :: DExt n l => Map VarIdent (Foil.Name n) -> Map VarIdent (Foil.Name l) +sinkNamed = Foil.sinkContainer + +sinkNames :: DExt n l => [Foil.Name n] -> [Foil.Name l] +sinkNames = Foil.sinkContainer + +-- * Lookup + +-- | What a name stands for. Total: every name in scope has an entry. +lookupVarInfo :: Foil.Name n -> Context n -> VarInfo n +lookupVarInfo name ctx = Foil.lookupName name (ctxVars ctx) + +-- | What every name in scope stands for, in no particular order. +varInfos :: Context n -> [VarInfo n] +varInfos ctx = IntMap.elems m + where + NameMap m = ctxVars ctx + +-- | Every hypothesis in scope, oldest binding first (see 'ctxBound': the ids +-- themselves do not tell us this). +varsInScope :: Context n -> [(Foil.Name n, VarInfo n)] +varsInScope ctx = + [ (name, lookupVarInfo name ctx) | name <- reverse (ctxBound ctx) ] + +-- | The name a surface identifier resolves to, if any. +lookupNamed :: VarIdent -> Context n -> Maybe (Foil.Name n) +lookupNamed name ctx = Map.lookup name (ctxNamed ctx) + +-- | The display binder of a name (the whole pattern, for projection folding). +binderOfName :: Foil.Name n -> Context n -> Binder +binderOfName name = varOrig . lookupVarInfo name + +-- * Modalities + +class ModeTheory m where + iden :: m + comp :: m -> m -> m + coe :: m -> m -> Bool + isRA :: m -> Bool + +instance ModeTheory TModality where + iden = Id + + comp Flat Flat = Flat + comp Flat Sharp = Flat + comp Flat Op = Flat + comp Op Flat = Flat + comp Sharp Sharp = Sharp + comp Sharp Flat = Sharp + comp Sharp Op = Sharp + comp Op Sharp = Sharp + comp Op Op = Id + comp Id m = m + comp m Id = m + + coe Flat Id = True + coe Flat Op = True + coe Id Sharp = True + coe Flat Sharp = True + coe Op Sharp = True + coe a b = a == b + + isRA Sharp = True + isRA Op = True + isRA Id = True + isRA _ = False + +-- | Accumulate a modality (a lock) over the hypotheses and the topes. +-- +-- Note that top-level entries are /not/ touched: a top-level variable is exempt +-- from the accessibility check (see @infer@), so accumulating a modality over +-- them was work with no observable effect. The old context did it to all ~1500 +-- of them on every modal binder. +applyModality :: TModality -> Context n -> Context n +applyModality md ctx = ctx + { ctxVars = mapNameMap addToVar (ctxVars ctx) + , ctxTopes = map addToTope (ctxTopes ctx) + , ctxTopesNF = map addToTope (ctxTopesNF ctx) + , ctxTopesNFUnion = map (map addToTope) (ctxTopesNFUnion ctx) + , ctxTopesSaturated = SaturationUncached -- accessibility changed + } + where + addToVar info + | varIsTopLevel info = info + | otherwise = info { varModAccum = comp (varModAccum info) md } + addToTope tope = tope { tModAccum = comp (tModAccum tope) md } + +-- | Map the values of a name map, keeping its keys. +mapNameMap :: (a -> b) -> NameMap n a -> NameMap n b +mapNameMap f (NameMap m) = NameMap (IntMap.map f m) + +-- | Replace what a name stands for. +-- +-- Closing a section rewrites the definitions made in it, so that each takes the +-- section's assumptions as explicit parameters; this is how the rewritten entries +-- go back into the context. +insertVarInfo :: Foil.Name n -> VarInfo n -> Context n -> Context n +insertVarInfo name info ctx = ctx { ctxVars = replace (ctxVars ctx) } + where + replace (NameMap m) = NameMap (IntMap.insert (Foil.nameId name) info m) + +-- * Topes + +isAccessible :: ModalTope n -> Bool +isAccessible mt = coe (tModVar mt) (tModAccum mt) + +filterAccessible :: [ModalTope n] -> [ModalTope n] +filterAccessible = filter isAccessible + +accessibleTopes :: [ModalTope n] -> [TermT n] +accessibleTopes = map tTope . filterAccessible + +plainTope :: TermT n -> ModalTope n +plainTope = ModalTope Id Id + +availableTopes :: Context n -> [TermT n] +availableTopes = accessibleTopes . ctxTopes + +availableTopesNF :: Context n -> [TermT n] +availableTopesNF = accessibleTopes . ctxTopesNF + +-- * Hole modes + +-- | Switch to lenient hole mode: record each hole's goal and context instead of +-- reporting it as an error. +allowHoles :: Context n -> Context n +allowHoles ctx = ctx { ctxHolesAreErrors = False } + +-- | Allow a hole's candidate list to draw on the given named top-level +-- definitions, in addition to the local hypotheses. +withHintLemmas :: [VarIdent] -> Context n -> Context n +withHintLemmas lemmas ctx = ctx { ctxHintLemmas = lemmas } + +-- | Within the given action, a hole unifies only as a leaf of an otherwise +-- matching structure: a structural mismatch around a hole stays an error rather +-- than being deferred (see 'ctxDeferHoleMismatches'). +structuralHoleUnify :: Context n -> Context n +structuralHoleUnify ctx = ctx { ctxDeferHoleMismatches = False } diff --git a/src/Rzk/TypeCheck/Decl.hs b/src/Rzk/TypeCheck/Decl.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/Decl.hs @@ -0,0 +1,735 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Declarations, sections, commands, and the public entry points. +-- +-- A top-level entry is a name bound in the outermost scope, so the scope /grows/ +-- as a module is checked: each @#define@, @#postulate@ and @#assume@ enters a +-- binder and the rest of the module is checked under it. The driver is therefore +-- written in continuation-passing style, and the result is packaged with the scope +-- it was produced in ('Checked'). +-- +-- That also gives sections their shape. A @#assume@d assumption is an ordinary +-- binder, and closing the section abstracts it out of the definitions that used it +-- (@makeAssumptionExplicit@), rewriting the later definitions to apply them to it. +module Rzk.TypeCheck.Decl where + +import Control.Monad (forM, when) +import Control.Monad.Except (catchError, runExcept) +import Control.Monad.Reader (ask, asks, local, runReaderT) +import Control.Monad.Trans.Writer.CPS (runWriterT) +import Data.List (intercalate) +import qualified Data.Map as Map +import Debug.Trace (trace) + +import Control.Monad.Foil (DExt, Distinct, NameBinder) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil (AST (Var), ScopedAST (..)) + +import Language.Rzk.Foil.Convert (Env, toTerm) +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), TModality (..), + VarIdent, binderName, markUnresolved, + patternToTerm, varIdentAt) +import qualified Language.Rzk.Syntax as Rzk +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Display +import Rzk.TypeCheck.Error +import Rzk.TypeCheck.Eval +import Rzk.TypeCheck.Judgements +import Rzk.TypeCheck.Monad +import Rzk.TypeCheck.Render + +-- * Declarations + +-- FIXME: merge with VarInfo +data Decl n = Decl + { declName :: VarIdent + -- ^ the surface name, as the user wrote it (with its source position) + , declNameOf :: Foil.Name n + -- ^ the name it is bound to in the top-level scope + , declType :: TermT n + , declValue :: Maybe (TermT n) + , declIsAssumption :: Bool + , declUsedVars :: [Foil.Name n] + , declLocation :: Maybe LocationInfo + } + +-- | A declaration sinks along a scope extension, by coercion (see the note in +-- "Rzk.TypeCheck.Context"). +sinkDecl :: DExt n l => Decl n -> Decl l +sinkDecl decl = decl + { declNameOf = Foil.sink (declNameOf decl) + , declType = Foil.sink (declType decl) + , declValue = Foil.sink <$> declValue decl + , declUsedVars = Foil.sink <$> declUsedVars decl + } + +-- | What a run of the checker produced: the top-level scope, the declarations in +-- it, and the errors found. +-- +-- The scope is existential, and the declarations live in it. Anything that wants +-- to /resume/ from a checked prefix (the LSP's incremental path) keeps the whole +-- package and carries on from that context; anything that only displays them reads +-- them through the context's naming. +data Checked where + Checked + :: Distinct n + => Context n + -> [(FilePath, [Decl n])] + -> [TypeErrorInScopedContext] + -> Checked + +-- * Entering a top-level entry + +-- | Bind a top-level entry and run the rest of the module under it. +withTopLevel + :: Distinct n + => VarIdent -- ^ the surface name + -> TermT n -- ^ its type + -> Maybe (TermT n) -- ^ its value, for a definition + -> Bool -- ^ is it an assumption (a @#assume@)? + -> [Foil.Name n] -- ^ the variables it declared it uses + -> (forall l. (DExt n l, Distinct l) => NameBinder n l -> Decl l -> TypeCheck l r) + -> TypeCheck n r +withTopLevel name ty mval isAssumption usedVars k = do + checkTopLevelDuplicate name + ctx <- ask + Foil.withFresh (ctxScope ctx) $ \binder -> do + let info = VarInfo + { varType = ty + , varValue = mval + , varModality = Id + , varModAccum = Id + , varOrig = BinderVar (Just name) + , varIsAssumption = isAssumption + , varIsTopLevel = True + , varDeclaredAssumptions = usedVars + , varLocation = ctxLocation ctx + } + ctx' = recordInSection (Foil.nameOf binder) (enterBinder binder info [] ctx) + decl = Decl + { declName = name + , declNameOf = Foil.nameOf binder + , declType = Foil.sink ty + , declValue = Foil.sink <$> mval + , declIsAssumption = isAssumption + , declUsedVars = Foil.sink <$> usedVars + , declLocation = ctxLocation ctx + } + inContext ctx' (k binder decl) + +-- | Record a new entry in the innermost open section. +recordInSection :: Foil.Name n -> Context n -> Context n +recordInSection name ctx = ctx + { ctxSections = case ctxSections ctx of + [] -> [SectionInfo Nothing [name]] + s : rest -> s { sectionEntries = name : sectionEntries s } : rest + } + +-- * Sections + +startSection :: Maybe Rzk.SectionName -> TypeCheck n a -> TypeCheck n a +startSection name = local $ \ctx -> ctx + { ctxSections = SectionInfo name [] : ctxSections ctx } + +-- | Close a section: abstract each of its assumptions out of the definitions that +-- used it, report the ones that went unused, and take the assumptions back out of +-- scope. +-- +-- The definitions stay in scope, with their entries rewritten to take the +-- assumption as an explicit parameter. The assumptions' names stay in the /scope +-- index/ — a scope only ever grows — but they are removed from the surface-name map +-- and from the list of what is in scope, so they can no longer be referred to, +-- shown, or shadowed. +endSection + :: Distinct n + => [TypeErrorInScopedContext] + -> TypeCheck n ([Decl n], [TypeErrorInScopedContext], Context n) +endSection errs = do + ctx <- ask + let entries = case ctxSections ctx of + [] -> [] + s : _ -> sectionEntries s -- newest first + infos = [ (name, lookupVarInfo name ctx) | name <- entries ] + + -- In lenient (hole-checking) mode an as-yet-unfilled hole may still come to use a + -- declared variable, so we tolerate the unused-variable diagnostics wherever such + -- a hole is present anywhere in the section. This covers both an unused section + -- assumption and an unused 'uses' variable, and crucially a hole-free definition + -- whose body refers to an in-progress (hole-bearing) one: its 'uses' reads as + -- unused only because the referenced definition is incomplete. Strict mode (the + -- default, and CI) keeps reporting both. + lenient <- not <$> asks ctxHolesAreErrors + let sectionHasHole = any (maybe False containsHole . varValue . snd) infos + tolerateUnused = lenient && sectionHasHole + + (kept, errs') <- collectSectionDecls tolerateUnused errs [] infos + + loc <- asks ctxLocation + let decls = map (toDecl loc) kept + assumptions = [ name | (name, info) <- infos, varIsAssumption info ] + isAssumption v = any (sameName v) assumptions + -- the names the section's assumptions were written with, which leave scope + assumedNames = + [ x | (_, info) <- infos, varIsAssumption info + , Just x <- [binderName (varOrig info)] ] + + -- the definitions of the section are now abstracted over its assumptions + ctx' = foldr (uncurry insertVarInfo) ctx + { ctxSections = closeInnermost (ctxSections ctx) + , ctxBound = filter (not . isAssumption) (ctxBound ctx) + , ctxNamed = Map.filter (not . isAssumption) (ctxNamed ctx) + , ctxShadow = foldr Map.delete (ctxShadow ctx) assumedNames + } kept + + -- The section's definitions outlive it, so the enclosing section adopts + -- them: closing /that/ one must see them too, and abstract them over its own + -- assumptions in turn. + closeInnermost sections = case drop 1 sections of + [] -> [] + s : rest -> s { sectionEntries = reverse (map fst kept) <> sectionEntries s } : rest + + -- only issue unused-variable errors if there were none before in the section + unusedErrors <- fmap concat $ forM decls $ \decl -> do + let unusedUsedVars = [ v | v <- declUsedVars decl, isAssumption v ] + if null errs && not (null unusedUsedVars) && not tolerateUnused + then local (\c -> c { ctxLocation = declLocation decl }) $ do + err <- typeErrorHere (TypeErrorUnusedUsedVariables unusedUsedVars (declNameOf decl)) + return [err] + else return [] + + pure (decls, errs' <> unusedErrors, ctx') + where + sameName a b = Foil.nameId a == Foil.nameId b + + toDecl loc (name, info) = Decl + { declName = case varOrig info of + BinderVar (Just x) -> x + _ -> "_" + , declNameOf = name + , declType = varType info + , declValue = varValue info + , declIsAssumption = varIsAssumption info + , declUsedVars = varDeclaredAssumptions info + , declLocation = loc + } + +-- | An error, captured in the current context (rather than thrown). +typeErrorHere :: Distinct n => TypeError n -> TypeCheck n TypeErrorInScopedContext +typeErrorHere err = do + ctx <- ask + pure (TypeErrorInScopedContext ctx err) + +-- | Turn the section's entries into declarations, abstracting each assumption out +-- of the definitions that follow it. +-- +-- The entries come newest first, so the definitions accumulated in @recent@ are +-- exactly those that could have used the assumption currently being processed. +collectSectionDecls + :: Distinct n + => Bool -- ^ tolerate unused variables + -> [TypeErrorInScopedContext] + -> [(Foil.Name n, VarInfo n)] -- ^ the definitions seen so far (oldest last) + -> [(Foil.Name n, VarInfo n)] -- ^ the entries still to process (newest first) + -> TypeCheck n ([(Foil.Name n, VarInfo n)], [TypeErrorInScopedContext]) +collectSectionDecls _tolerate errs recent [] = pure (recent, errs) +collectSectionDecls tolerate errs recent (entry@(name, info) : rest) + | varIsAssumption info = do + (used, recent') <- makeAssumptionExplicit entry recent + unusedErr <- + if null errs && not used && not tolerate + then local (\c -> c { ctxLocation = varLocation info }) $ + pure <$> typeErrorHere (TypeErrorUnusedVariable name (varType info)) + else return [] + collectSectionDecls tolerate (errs <> unusedErr) recent' rest + | otherwise = + collectSectionDecls tolerate errs (entry : recent) rest + +-- | Abstract one assumption out of the definitions that come after it. +-- +-- A definition that mentions the assumption gains it as an explicit parameter, and +-- every later definition that mentions /that/ definition is rewritten to apply it +-- to the assumption. A definition that mentions it without declaring it in its +-- @uses@ clause is an implicit assumption, and an error. +makeAssumptionExplicit + :: Distinct n + => (Foil.Name n, VarInfo n) + -> [(Foil.Name n, VarInfo n)] + -> TypeCheck n (Bool, [(Foil.Name n, VarInfo n)]) +makeAssumptionExplicit _ [] = pure (False {- UNUSED -}, []) +makeAssumptionExplicit assumption@(a, aInfo) ((x, xInfo) : xs) = do + scope <- asks ctxScope + -- Two notions of use, and the difference between them is what 'implicit' means. + -- The deep one follows the types of the variables the entry mentions, so it sees + -- a dependency the entry never names; the shallow one is a syntactic occurrence. + deepVars <- do + inTy <- freeVarsDeep (varType xInfo) + inVal <- concat <$> traverse freeVarsDeep (varValue xInfo) + pure (inTy <> inVal) + -- The syntactic check reads the declaration as the user wrote it, from the + -- context — not the entry, which the assumptions abstracted before this one have + -- already rewritten (and which therefore mentions them). + written <- asks (lookupVarInfo x) + let hasAssumption = a `elemName` deepVars + inTypeSyntactically = a `elemName` freeVarsOfTermT (varType written) + inBodySyntactically = any (elemName a . freeVarsOfTermT) (varValue written) + declared = a `elemName` varDeclaredAssumptions xInfo + -- used, but never written down: neither in the type, nor in the body, nor in + -- the 'uses' clause + implicit = and + [ hasAssumption + , not (inTypeSyntactically || inBodySyntactically) + , not declared + ] + if hasAssumption + then do + when implicit $ + issueTypeError $ TypeErrorImplicitAssumption (a, varType aInfo) x + let xInfo' = abstractOver scope a aInfo xInfo + xs' = map (fmap (applyToAssumption scope a (x, xInfo'))) xs + (_used, xs'') <- makeAssumptionExplicit assumption xs' + return (True {- USED -}, (x, xInfo') : xs'') + else do + (used, xs'') <- makeAssumptionExplicit assumption xs + return (used, (x, xInfo) : xs'') + +-- | Give an entry the assumption as an explicit parameter. +abstractOver + :: Distinct n + => Foil.Scope n -> Foil.Name n -> VarInfo n -> VarInfo n -> VarInfo n +abstractOver scope a aInfo info = info + { varType = newType + , varValue = fmap abstractValue (varValue info) + , varModality = Id + , varModAccum = Id + , varDeclaredAssumptions = + filter (\v -> Foil.nameId v /= Foil.nameId a) (varDeclaredAssumptions info) + } + where + orig = varOrig aInfo + newType = + abstractName scope a (varType info) $ \binder body -> + typeFunT orig Id (varType aInfo) Nothing (ScopedAST binder body) + abstractValue value = + abstractName scope a value $ \binder body -> + lambdaT newType orig Nothing (ScopedAST binder body) + +-- | Rewrite every use of a definition into an application of it to the assumption +-- it has just been abstracted over. +applyToAssumption + :: Distinct n + => Foil.Scope n -> Foil.Name n -> (Foil.Name n, VarInfo n) -> VarInfo n -> VarInfo n +applyToAssumption scope a (defName, defInfo) info + | varIsAssumption info = info + | otherwise = info + { varType = rewrite (varType info) + , varValue = rewrite <$> varValue info + } + where + applied = appT (varType defInfo) (Var defName) (Var a) + rewrite = substituteName scope defName applied + +-- * Commands + +countCommands :: Integral a => [Rzk.Command] -> a +countCommands = fromIntegral . length + +setOption :: Distinct n => String -> String -> TypeCheck n a -> TypeCheck n a +setOption "verbosity" = \case + "debug" -> localVerbosity Debug + "normal" -> localVerbosity Normal + "silent" -> localVerbosity Silent + _ -> const $ + issueTypeError $ TypeErrorOther "unknown verbosity level (use \"debug\", \"normal\", or \"silent\")" +setOption "render" = \case + "svg" -> localRenderBackend (Just RenderSVG) + "latex" -> localRenderBackend (Just RenderLaTeX) + "none" -> localRenderBackend Nothing + _ -> const $ + issueTypeError $ TypeErrorOther "unknown render backend (use \"svg\", \"latex\", or \"none\")" +-- Render the shape only, hiding the proof term (drop the everywhere and +-- blank interior labels), so a worked term can be shown as the cell it builds +-- without giving the term away. +setOption "render-hide-term" = \case + "yes" -> localHideTerm True + "no" -> localHideTerm False + _ -> const $ + issueTypeError $ TypeErrorOther "unknown value for \"render-hide-term\" (use \"yes\" or \"no\")" +-- The overhang hint costs a solver entailment per restriction face and recOR +-- guard, so it is off by default and opted into per module (or scope). +setOption "warn-overhang" = \case + "yes" -> localWarnOverhang True + "no" -> localWarnOverhang False + _ -> const $ + issueTypeError $ TypeErrorOther "unknown value for \"warn-overhang\" (use \"yes\" or \"no\")" +setOption optionName = const $ const $ + issueTypeError $ TypeErrorOther ("unknown option " <> show optionName) + +unsetOption :: Distinct n => String -> TypeCheck n a -> TypeCheck n a +unsetOption "verbosity" = localVerbosity (ctxVerbosity emptyContext) +unsetOption "render" = localRenderBackend (ctxRenderBackend emptyContext) +unsetOption "render-hide-term" = localHideTerm (ctxRenderHideTerm emptyContext) +unsetOption "warn-overhang" = localWarnOverhang (ctxWarnOverhang emptyContext) +unsetOption optionName = const $ + issueTypeError $ TypeErrorOther ("unknown option " <> show optionName) + +paramToParamDecl :: Distinct n => Rzk.Param -> TypeCheck n [Rzk.ParamDecl] +paramToParamDecl (Rzk.ParamPatternShapeDeprecated loc pat cube tope) = pure + [ Rzk.ParamTermShape loc (patternToTerm pat) cube tope ] +paramToParamDecl (Rzk.ParamPatternShape loc pats cube tope) = pure + [ Rzk.ParamTermShape loc (patternToTerm pat) cube tope | pat <- pats] +paramToParamDecl (Rzk.ParamPatternType loc pats ty) = pure + [ Rzk.ParamTermType loc (patternToTerm pat) ty | pat <- pats ] +paramToParamDecl Rzk.ParamPattern{} = issueTypeError $ + TypeErrorOther "untyped pattern in parameters" +paramToParamDecl (Rzk.ParamPatternModalType loc pats mc ty) = pure + [ Rzk.ParamTermModalType loc (patternToTerm pat) mc ty | pat <- pats ] +paramToParamDecl (Rzk.ParamPatternModalShape loc pats mc cube tope) = pure + [ Rzk.ParamTermModalShape loc (patternToTerm pat) mc cube tope | pat <- pats ] + +addParamDecls :: [Rzk.ParamDecl] -> Rzk.Term -> Rzk.Term +addParamDecls [] = id +addParamDecls (paramDecl : paramDecls) + = Rzk.TypeFun Nothing paramDecl . addParamDecls paramDecls + +addParams :: [Rzk.Param] -> Rzk.Term -> Rzk.Term +addParams [] = id +addParams params = Rzk.Lambda Nothing params + +-- | Run a command, recording which one it is and where. +-- +-- An error raised anywhere in the command (or in the rest of the module, which is +-- checked inside it) is /collected/ rather than thrown: the declarations made +-- before it stand, the error is reported, and the rest of the module is skipped. +-- The strict entry points turn the first collected error back into a thrown one. +withCommand + :: Rzk.Command + -> ([Decl n] -> [TypeErrorInScopedContext] -> TypeCheck n r) + -> TypeCheck n r + -> TypeCheck n r +withCommand command k action = + local atCommand (action `catchError` \err -> k [] [err]) + where + atCommand ctx = ctx + { ctxCurrentCommand = Just command + , ctxLocation = updatePosition (Rzk.hasPosition command) <$> ctxLocation ctx + } + updatePosition pos loc = loc { locationLine = fst <$> pos } + +-- | Elaborate a surface term in the current top-level scope: a free identifier +-- resolves to the top-level entry it names. +elaborate :: forall n. Distinct n => Rzk.Term -> TypeCheck n (Term n) +elaborate term = do + ctx <- ask + let env :: Env n + env name = case lookupNamed name ctx of + Just v -> Var v + Nothing -> Hole (Just (markUnresolved name)) + pure (toTerm (ctxScope ctx) env term) + +-- | Is a surface identifier defined at the top level? +checkDefined :: Distinct n => VarIdent -> TypeCheck n (Foil.Name n) +checkDefined name = asks (lookupNamed name) >>= \case + Just v -> pure v + Nothing -> issueTypeError (TypeErrorUndefined name) + +splitSectionCommands + :: Distinct n + => Rzk.SectionName -> [Rzk.Command] -> TypeCheck n ([Rzk.Command], [Rzk.Command]) +splitSectionCommands name [] = + issueTypeError (TypeErrorOther $ "Section " <> Rzk.printTree name <> " is not closed with an #end") +splitSectionCommands name (Rzk.CommandSection _loc name' : moreCommands) = do + (cs1, cs2) <- splitSectionCommands name' moreCommands + (cs3, cs4) <- splitSectionCommands name cs2 + return (cs1 <> cs3, cs4) +splitSectionCommands name (Rzk.CommandSectionEnd _loc endName : moreCommands) = do + when (Rzk.printTree name /= Rzk.printTree endName) $ + issueTypeError $ TypeErrorOther $ + "unexpected #end " <> Rzk.printTree endName <> ", expecting #end " <> Rzk.printTree name + return ([], moreCommands) +splitSectionCommands name (command : moreCommands) = do + (cs1, cs2) <- splitSectionCommands name moreCommands + return (command : cs1, cs2) + +-- * The module driver + +-- | Check a module's commands, extending the scope with each definition. +-- +-- The continuation runs in the /final/ scope, with the declarations the module +-- produced (sunk into it) and the errors found. +checkCommands + :: forall n r. Distinct n + => Maybe FilePath -> Integer -> Integer -> [Rzk.Command] + -> (forall l. (DExt n l, Distinct l) + => [Decl l] -> [TypeErrorInScopedContext] -> TypeCheck l r) + -> TypeCheck n r +checkCommands path i total commands k = case commands of + [] -> k [] [] + + command@(Rzk.CommandUnsetOption _loc optionName) : more -> + announce ("Unsetting option " <> optionName) $ + withCommand command k $ + unsetOption optionName $ + checkCommands path (i + 1) total more k + + command@(Rzk.CommandSetOption _loc optionName optionValue) : more -> + announce ("Setting option " <> optionName <> " = " <> optionValue) $ + withCommand command k $ + setOption optionName optionValue $ + checkCommands path (i + 1) total more k + + command@(Rzk.CommandDefine _loc name (Rzk.DeclUsedVars _ vars) params ty term) : more -> + announce (" Checking #define " <> Rzk.printTree name) $ + withCommand command k $ do + used <- mapM (checkDefined . varIdentAt path) vars + paramDecls <- concat <$> mapM paramToParamDecl params + -- Store the elaborated type and term unreduced, but memoise their WHNF on + -- the top node. Reducing in place would discard or expose a variable + -- occurrence, so the section unused/implicit-assumption checks (run over the + -- stored type and value) would disagree with the term the user wrote; + -- keeping the WHNF cached preserves the original one-shot reduction. + tyTerm <- elaborate (addParamDecls paramDecls ty) + ty' <- memoizeWHNF =<< typecheck tyTerm universeT + valTerm <- elaborate (addParams params term) + term' <- memoizeWHNF =<< typecheck valTerm ty' + withTopLevel (varIdentAt path name) ty' (Just term') False used $ \binder decl -> do + backend <- asks ctxRenderBackend + termSVG <- case backend of + Just RenderSVG -> renderTermSVG (Var (Foil.nameOf binder)) + Just RenderLaTeX -> issueTypeError $ + TypeErrorOther "\"latex\" rendering is not yet supported" + Nothing -> pure Nothing + maybe id trace termSVG $ + checkCommands path (i + 1) total more $ \decls errs -> + k (sinkDecl decl : decls) errs + + command@(Rzk.CommandPostulate _loc name (Rzk.DeclUsedVars _ vars) params ty) : more -> + announce (" Checking #postulate " <> Rzk.printTree name) $ + withCommand command k $ do + used <- mapM (checkDefined . varIdentAt path) vars + paramDecls <- concat <$> mapM paramToParamDecl params + tyTerm <- elaborate (addParamDecls paramDecls ty) + ty' <- memoizeWHNF =<< typecheck tyTerm universeT + withTopLevel (varIdentAt path name) ty' Nothing False used $ \_binder decl -> + checkCommands path (i + 1) total more $ \decls errs -> + k (sinkDecl decl : decls) errs + + command@(Rzk.CommandAssume _loc names ty) : more -> + announce (" Checking #assume " + <> intercalate " " [ Rzk.printTree name | name <- names ]) $ + withCommand command k $ do + tyTerm <- elaborate ty + ty' <- typecheck tyTerm universeT + assume (map (varIdentAt path) names) ty' $ \assumed -> + checkCommands path (i + 1) total more $ \decls errs -> + k (map sinkDecl assumed <> decls) errs + + command@(Rzk.CommandCheck _loc term ty) : more -> + announce (" Checking " <> Rzk.printTree term <> " : " <> Rzk.printTree ty) $ + withCommand command k $ do + tyTerm <- elaborate ty + ty' <- typecheck tyTerm universeT >>= whnfT + termTerm <- elaborate term + _term' <- typecheck termTerm ty' + checkCommands path (i + 1) total more k + + Rzk.CommandCompute loc term : more -> + checkCommands path i total (Rzk.CommandComputeWHNF loc term : more) k + + command@(Rzk.CommandComputeNF _loc term) : more -> + announce (" Computing NF for " <> Rzk.printTree term) $ + withCommand command k $ do + term' <- elaborate term >>= infer >>= nfT + shown <- ppInContext term' + traceTypeCheck Normal (" " <> shown) $ + checkCommands path (i + 1) total more k + + command@(Rzk.CommandComputeWHNF _loc term) : more -> + announce (" Computing WHNF for " <> Rzk.printTree term) $ + withCommand command k $ do + term' <- elaborate term >>= infer >>= whnfT + shown <- ppInContext term' + traceTypeCheck Normal (" " <> shown) $ + checkCommands path (i + 1) total more k + + command@(Rzk.CommandSection _loc name) : more -> + withCommand command k $ do + (sectionCommands, more') <- splitSectionCommands name more + withSection (Just name) i sectionCommands path total $ \sectionDecls sectionErrs -> + if null sectionErrs + then checkCommands path (i + countCommands sectionCommands) total more' $ + \decls errs -> k (map sinkDecl sectionDecls <> decls) errs + else k sectionDecls sectionErrs + + command@(Rzk.CommandSectionEnd _loc endName) : _more -> + withCommand command k $ + issueTypeError $ TypeErrorOther $ + "unexpected #end " <> Rzk.printTree endName <> ", no section was declared!" + where + announce :: String -> TypeCheck n a -> TypeCheck n a + announce what = + traceTypeCheck Normal + ("[ " <> show i <> " out of " <> show total <> " ]" <> what) + +-- | Assume a list of names of the same type, each a top-level entry. +assume + :: Distinct n + => [VarIdent] -> TermT n + -> (forall l. (DExt n l, Distinct l) => [Decl l] -> TypeCheck l r) + -> TypeCheck n r +assume [] _ty k = k [] +assume (name : names) ty k = + withTopLevel name ty Nothing True [] $ \_binder decl -> + assume names (Foil.sink ty) $ \decls -> + k (sinkDecl decl : decls) + +-- | Check the commands of a section, then close it. +withSection + :: forall n r. Distinct n + => Maybe Rzk.SectionName -> Integer -> [Rzk.Command] -> Maybe FilePath -> Integer + -> (forall l. (DExt n l, Distinct l) + => [Decl l] -> [TypeErrorInScopedContext] -> TypeCheck l r) + -> TypeCheck n r +withSection name i sectionCommands path total k = + startSection name $ + checkCommands path i total sectionCommands $ \_decls errs -> + performing (ActionCloseSection name) $ do + result <- (Right <$> endSection errs) `catchError` (return . Left) + case result of + Left err -> k [] (errs <> [err]) + Right (decls', errs', ctx') -> inContext ctx' (k decls' errs') + +-- | Check one module. +checkModule + :: forall n r. Distinct n + => Maybe FilePath -> Rzk.Module + -> (forall l. (DExt n l, Distinct l) + => [Decl l] -> [TypeErrorInScopedContext] -> TypeCheck l r) + -> TypeCheck n r +checkModule path (Rzk.Module _moduleLoc _lang commands) k = + -- FIXME: use the module name? or an anonymous section? + withSection Nothing 1 commands path (countCommands commands) k + +checkModuleWithLocation + :: Distinct n + => (FilePath, Rzk.Module) + -> (forall l. (DExt n l, Distinct l) + => [Decl l] -> [TypeErrorInScopedContext] -> TypeCheck l r) + -> TypeCheck n r +checkModuleWithLocation (path, module_) k = + traceTypeCheck Normal ("Checking module from " <> path) $ + withLocation (LocationInfo { locationFilePath = Just path, locationLine = Nothing }) $ + checkModule (Just path) module_ k + +-- | Check a list of modules, one after another, in a scope that grows as it goes. +-- +-- Checking stops at the first module with an error, as it did before. +checkModules + :: forall n r. Distinct n + => [(FilePath, Rzk.Module)] + -> (forall l. (DExt n l, Distinct l) + => [(FilePath, [Decl l])] -> [TypeErrorInScopedContext] -> TypeCheck l r) + -> TypeCheck n r +checkModules [] k = k [] [] +checkModules (m@(path, _) : ms) k = + checkModuleWithLocation m $ \decls errs -> + case errs of + _:_ -> k [(path, decls)] errs + _ -> checkModules ms $ \rest errors -> + k ((path, map sinkDecl decls) : rest) errors + +-- * The public entry points + +-- | Check the modules, and package the result with the scope it was checked in. +checkedModules :: [(FilePath, Rzk.Module)] -> Context Foil.VoidS -> Either TypeErrorInScopedContext (Checked, [HoleInfo]) +checkedModules modules ctx = + runExcept $ runWriterT $ flip runReaderT ctx $ + checkModules modules $ \decls errs -> do + ctx' <- ask + pure (Checked ctx' decls errs) + +-- | Check the modules strictly: an unfilled hole is an error, and the first error +-- stops the run. +typecheckModules + :: [(FilePath, Rzk.Module)] -> Either TypeErrorInScopedContext Checked +typecheckModules modules = do + (checked@(Checked _ _ errs), _holes) <- checkedModules modules emptyContext + case errs of + err : _ -> Left err + [] -> Right checked + +-- | Check the modules in lenient hole mode, returning the holes recorded (each +-- with its goal and local context). This is the structured goal/context query the +-- LSP and the game consume. +typecheckModulesWithHoles + :: [(FilePath, Rzk.Module)] + -> Either TypeErrorInScopedContext (Checked, [HoleInfo]) +typecheckModulesWithHoles = typecheckModulesWithHolesAndLemmas [] + +-- | Like 'typecheckModulesWithHoles', but additionally offers the given named +-- top-level definitions as hole candidates (each applied to holes when its type +-- fits the goal). The game passes a level's allow-list of relevant lemmas so they +-- surface as moves; an empty list reproduces 'typecheckModulesWithHoles'. +typecheckModulesWithHolesAndLemmas + :: [VarIdent] + -> [(FilePath, Rzk.Module)] + -> Either TypeErrorInScopedContext (Checked, [HoleInfo]) +typecheckModulesWithHolesAndLemmas lemmas modules = + checkedModules modules (withHintLemmas lemmas (allowHoles emptyContext)) + +-- * What a consumer sees + +-- | A declaration, rendered: no scope index, and nothing to re-elaborate. +-- +-- This is what the LSP shows — a name, a type, a location — and it is all it needs. +-- The elaborated terms stay inside the 'Checked' package, which is what a /resume/ +-- needs. +data DeclView = DeclView + { declViewName :: VarIdent + , declViewType :: Rendered + , declViewIsAssumption :: Bool + , declViewLocation :: Maybe LocationInfo + } deriving (Eq, Show) + +-- | The declarations of a checked run, rendered, grouped by the file they came +-- from. +declViews :: Checked -> [(FilePath, [DeclView])] +declViews (Checked ctx decls _errs) = map (fmap (map view)) decls + where + naming = namingOfContext ctx + view decl = DeclView + { declViewName = declName decl + , declViewType = renderTerm naming (untyped (declType decl)) + , declViewIsAssumption = declIsAssumption decl + , declViewLocation = declLocation decl + } + +-- | Continue checking from a prefix that has already been checked. +-- +-- This is the incremental path: the cached context /is/ the elaborated prefix, so +-- nothing is replayed and nothing is re-elaborated. +recheckFrom + :: Checked + -> [(FilePath, Rzk.Module)] + -> Either TypeErrorInScopedContext (Checked, [HoleInfo]) +recheckFrom (Checked ctx decls _errs) modules = + runExcept $ runWriterT $ flip runReaderT ctx $ + checkModules modules $ \newDecls errs -> do + ctx' <- ask + pure (Checked ctx' (map (fmap (map sinkDecl)) decls <> newDecls) errs) + +-- | The errors of a checked run. +checkedErrors :: Checked -> [TypeErrorInScopedContext] +checkedErrors (Checked _ _ errs) = errs + +-- | Nothing checked yet: the empty context, and no declarations. +emptyChecked :: Checked +emptyChecked = Checked emptyContext [] [] diff --git a/src/Rzk/TypeCheck/Display.hs b/src/Rzk/TypeCheck/Display.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/Display.hs @@ -0,0 +1,149 @@ +{-# LANGUAGE OverloadedStrings #-} + +-- | Showing a term to the user. +-- +-- A term of the core names its variables by 'Foil.Name' (an @Int@), so anything +-- user-facing — an error, a trace of a judgement, a hole's goal — has to say what +-- each name is /called/. That is a 'Naming': a display name and a display binder +-- per name in scope, plus the supply of fresh names for the binders the printer +-- meets on the way down. +-- +-- This replaces the old @var -> VarIdent@ threading (@name@, @nameInc@, +-- @BinderNames@, @ppTermInContext@ — four copies of the same idea), and with it +-- the unwinding loop that rebuilt those names one binder at a time. +module Rzk.TypeCheck.Display where + +import Control.Monad.Foil (NameMap) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Foil.Internal (NameMap (..)) +import qualified Data.IntMap as IntMap +import Data.List (nub, (\\)) +import qualified Data.Set as Set + +import Language.Rzk.Foil.Print (fromTerm) +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), Display, + TypeInfo (..), VarIdent, + binderIsCompound, binderLeaves, + binderToPattern, defaultVarIdents, + freshenBinderLeaves, fromVarIdent, + refreshVarIn) +import qualified Language.Rzk.Syntax as Rzk +import Rzk.TypeCheck.Context + +-- | What every name in scope is called, and what the printer may call the +-- binders it has yet to meet. +data Naming n = Naming + { namingOf :: NameMap n Display + , namingUsed :: [VarIdent] + -- ^ the display names taken, so a bound binder is refreshed away from them + , namingSupply :: [VarIdent] + -- ^ the names left over, for anonymous binders + } + +-- | Read the naming off a context. +-- +-- A named binder keeps its name, refreshed only if an outer name has already +-- taken it. An anonymous one draws from the supply. A pattern binder has its +-- component names freshened as a group, so that the pattern shown in the context +-- and the projections folded inside a term agree on them. +-- +-- Entries are named oldest binding first (see 'ctxBound'), so an outer binder +-- keeps its name and an inner one is the one refreshed away from it. +namingOfContext :: Context n -> Naming n +namingOfContext ctx = Naming + { namingOf = NameMap (IntMap.fromList entries) + , namingUsed = used + , namingSupply = defaultVarIdents \\ used + } + where + (entries, usedSet) = go Set.empty defaultVarIdents (varsInScope ctx) + used = Set.toList usedSet + + -- Name the entries in binding order, each avoiding the names already taken. + -- The taken names are a set: this runs once per entry, and a context can hold + -- every top-level definition of a project. + go taken _supply [] = ([], taken) + go taken supply ((v, info) : rest) = + case varOrig info of + BinderVar (Just x) -> + let x' = refreshVarIn taken x + in name (x', BinderVar (Just x')) [x'] supply + BinderVar Nothing -> + case supply of + x : supply' -> name (x, BinderVar (Just x)) [x] supply' + [] -> panicImpossible "not enough fresh variables" + binder -> + -- A pattern binder: the variable itself needs a placeholder name (it is + -- only shown when the whole point is used, and then it prints as the + -- pattern), and its leaves are freshened together. + case supply of + x : supply' -> + let binder' = freshenBinderLeaves (Set.toList taken) binder + in name (x, binder') (x : binderLeaves binder') supply' + [] -> panicImpossible "not enough fresh variables" + where + name display claimed supply' = + let (acc, taken') = go (foldr Set.insert taken claimed) supply' rest + in ((Foil.nameId v, display) : acc, taken') + +-- | A term already rendered for the user, kept as surface syntax rather than a +-- string so that a consumer may still inspect it. +-- +-- Its 'Show' prints the surface syntax, which is what the old @Term'@ did, so a +-- rendered goal or candidate reads the same as it always has (@\\ (t, s) → ?@). +newtype Rendered = Rendered { getRendered :: Rzk.Term } + +instance Show Rendered where + show = Rzk.printTree . getRendered + +-- | Two rendered terms are equal when they read the same. (The surface AST +-- carries source positions, which a rendered term should not be judged by.) +instance Eq Rendered where + l == r = show l == show r + +-- | A term as surface syntax, with the context's names. +-- +-- A binder /inside/ the term is freshened only against the names the term itself +-- mentions — not against everything in scope. A type shows the binder it was +-- written with (@Σ (a : A), B a@), even where the context happens to have an @a@ of +-- its own: the two are different variables, and shadowing is what binders are for. +renderTerm :: Naming n -> Term n -> Rendered +renderTerm naming t = Rendered (fromTerm used supply (namingOf naming) t) + where + used = nub $ concat + [ x : binderLeaves binder + | v <- freeVarsOfTerm t + , let (x, binder) = displayOf naming v + ] + supply = defaultVarIdents \\ used + +-- | A term shown to the user. +ppTerm :: Naming n -> Term n -> String +ppTerm naming = show . renderTerm naming + +-- | A typed term shown as @term : type@, as the old @ppFoldT@ did. A variable is +-- shown bare: its type is in the context, not on the node. +ppTermT :: Naming n -> TermT n -> String +ppTermT naming t = + case typeInfoOf t of + Nothing -> ppTerm naming (untyped t) + Just info -> ppTerm naming (untyped t) <> " : " <> ppTerm naming (untyped (infoType info)) + +-- | What a name is called, and the (freshened) binder it was introduced by. +displayOf :: Naming n -> Foil.Name n -> Display +displayOf naming name = Foil.lookupName name (namingOf naming) + +-- | A variable as the user sees it: a pattern binder shows as its pattern +-- (@(t, s)@), anything else by its display name. +ppName :: Naming n -> Foil.Name n -> String +ppName naming name = + case Foil.lookupName name (namingOf naming) of + (_, binder) | binderIsCompound binder -> Rzk.printTree (binderToPattern binder) + (x, _) -> Rzk.printTree (fromVarIdent x) + +panicImpossible :: String -> a +panicImpossible msg = error $ unlines + [ "PANIC! Impossible happened (" <> msg <> ")!" + , "Please, report a bug at https://github.com/rzk-lang/rzk/issues" + ] diff --git a/src/Rzk/TypeCheck/Error.hs b/src/Rzk/TypeCheck/Error.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/Error.hs @@ -0,0 +1,385 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | Type errors, and how they are shown. +-- +-- An error is captured /at its own scope/: it packages the context it was raised +-- in, existentially, so its scope index does not escape into the error type. The +-- old representation instead nested the error one @Inc@ deeper at every binder +-- (@ScopedTypeError@) and unwound the whole stack at printing time, inventing a +-- name per binder as it went. That unwinding loop, and both of its +-- @FIXME: very inefficient filter@ sites, are gone: the context already knows what +-- everything in scope is called (see "Rzk.TypeCheck.Display"). +-- +-- The error type is therefore /not/ scope-indexed, which is why entering a binder +-- no longer has to re-index the error channel. +module Rzk.TypeCheck.Error where + +import Control.Monad.Foil (Distinct) +import qualified Control.Monad.Foil as Foil +import Data.List (intercalate) + +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (TModality (..), VarIdent, getVarIdent, + ppVarIdentWithLocation) +import qualified Language.Rzk.Syntax as Rzk +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Display + +data TypeError n + = TypeErrorOther String + | TypeErrorUnify (TermT n) (TermT n) (TermT n) + | TypeErrorUnifyTerms (TermT n) (TermT n) + | TypeErrorNotPair (TermT n) (TermT n) + | TypeErrorNotModal (Term n) TModality (TermT n) + | TypeErrorModalityMismatch TModality TModality (Term n) + | TypeErrorUnaccessibleVar (Foil.Name n) TModality TModality + | TypeErrorNotTypeInModal (TermT n) + | TypeErrorNotFunction (TermT n) (TermT n) + | TypeErrorUnexpectedLambda (Term n) (TermT n) + | TypeErrorUnexpectedPair (Term n) (TermT n) + | TypeErrorUnexpectedRefl (Term n) (TermT n) + | TypeErrorCannotInferBareLambda (Term n) + | TypeErrorCannotInferBareRefl (Term n) + | TypeErrorCannotInferHole (Term n) + | TypeErrorUnsolvedHole (Maybe VarIdent) (TermT n) + | TypeErrorUndefined VarIdent + | TypeErrorTopeNotSatisfied [TermT n] (TermT n) + | TypeErrorTopeContextDisjoint (TermT n) [TermT n] + | TypeErrorTopesNotEquivalent (TermT n) (TermT n) + | TypeErrorInvalidArgumentType (Term n) (TermT n) + | TypeErrorDuplicateTopLevel [VarIdent] VarIdent + | TypeErrorUnusedVariable (Foil.Name n) (TermT n) + | TypeErrorUnusedUsedVariables [Foil.Name n] (Foil.Name n) + | TypeErrorImplicitAssumption (Foil.Name n, TermT n) (Foil.Name n) + +-- | An error, together with the context it was raised in. +-- +-- The scope index is existential: an error raised under a binder is /already/ +-- complete (its context says what its names are called), so it needs nothing +-- from the enclosing scope and can be thrown straight through it. +data TypeErrorInScopedContext where + TypeErrorInScopedContext + :: Distinct n => Context n -> TypeError n -> TypeErrorInScopedContext + +ppModality :: TModality -> String +ppModality = \case + Flat -> "♭" + Sharp -> "♯" + Op -> "ᵒᵖ" + Id -> "_id" + +-- * Rendering + +data OutputDirection = TopDown | BottomUp + deriving (Eq) + +block :: OutputDirection -> [String] -> String +block TopDown = intercalate "\n" +block BottomUp = intercalate "\n" . reverse + +namedBlock :: OutputDirection -> String -> [String] -> String +namedBlock dir name lines_ = block dir $ + name : map indent lines_ + where + indent = intercalate "\n" . map (" " ++) . lines + +ppTypeError :: Naming n -> TypeError n -> String +ppTypeError naming = \case + TypeErrorOther msg -> msg + TypeErrorUnify term expected actual -> block TopDown + [ "cannot unify expected type" + , " " <> ppU (untyped expected) + , "with actual type" + , " " <> ppU (untyped actual) + , "for term" + , " " <> ppU (untyped term) ] + TypeErrorUnifyTerms expected actual -> block TopDown + [ "cannot unify term" + , " " <> ppU (untyped expected) + , "with term" + , " " <> ppU (untyped actual) ] + TypeErrorNotPair term ty -> block TopDown + [ "expected a cube product or dependent pair" + , "but got type" + , " " <> ppU (untyped ty) + , "for term" + , " " <> ppU (untyped term) + , case ty of + TypeFunT{} -> "\nPerhaps the term is applied to too few arguments?" + _ -> "" + ] + TypeErrorNotModal term m ty -> block TopDown + [ "expected modal type " <> ppModality m <> " ?" + , "but got type" + , " " <> ppU (untyped ty) + , "for term" + , " " <> ppU term + ] + TypeErrorModalityMismatch expected actual term -> block TopDown + [ "modality mismatch" + , " expected " <> ppModality expected + , " but got " <> ppModality actual + , "for term" + , " " <> ppU term + ] + TypeErrorUnaccessibleVar _var varMod locks -> block TopDown + [ "unaccessible var with modality " <> ppModality varMod + , " under locks " <> ppModality locks + ] + TypeErrorNotTypeInModal ty -> block TopDown + [ "expected a type inside modal type" + , "but got" + , " " <> ppU (untyped ty) + ] + + TypeErrorUnexpectedLambda term ty -> block TopDown + [ "unexpected lambda abstraction" + , " " <> ppU term + , "when typechecking against a non-function type" + , " " <> ppTyped ty + ] + TypeErrorUnexpectedPair term ty -> block TopDown + [ "unexpected pair" + , " " <> ppU term + , "when typechecking against a type that is not a product or a dependent sum" + , " " <> ppTyped ty + ] + TypeErrorUnexpectedRefl term ty -> block TopDown + [ "unexpected refl" + , " " <> ppU term + , "when typechecking against a type that is not an identity type" + , " " <> ppTyped ty + ] + + TypeErrorNotFunction term ty -> block TopDown + [ "expected a function or extension type" + , "but got type" + , " " <> ppU (untyped ty) + , "for term" + , " " <> ppU (untyped term) + , case term of + AppT _ty f _x -> "\nPerhaps the term\n " <> ppU (untyped f) <> "\nis applied to too many arguments?" + _ -> "" + ] + TypeErrorCannotInferBareLambda term -> block TopDown + [ "cannot infer the type of the argument" + , "in lambda abstraction" + , " " <> ppU term + ] + TypeErrorCannotInferBareRefl term -> block TopDown + [ "cannot infer the type of term" + , " " <> ppU term + ] + TypeErrorCannotInferHole term -> block TopDown + [ "cannot infer the type of a hole" + , " " <> ppU term + , "a hole is only allowed where its type is already known (checking position)" + ] + TypeErrorUnsolvedHole mname goal -> block TopDown + [ "found an unsolved hole" <> maybe "" (\name -> " ?" <> show name) mname + , "expected type (goal):" + , " " <> ppU (untyped goal) + ] + TypeErrorUndefined var -> block TopDown + [ "undefined variable: " <> show var ] + TypeErrorTopeNotSatisfied topes tope -> block TopDown + [ "local context is not included in (does not entail) the tope" + , " " <> ppU (untyped tope) + , "in local context (normalised)" + , intercalate "\n" (map ((" " <>) . ppTyped) topes)] -- FIXME: remove + TypeErrorTopeContextDisjoint tope topes -> block TopDown + [ "the tope" + , " " <> ppU (untyped tope) + , "is disjoint from the local tope context (their conjunction is the empty tope ⊥)," + , "so this restriction face or recOR branch is vacuous everywhere" + , "in local context (normalised)" + , intercalate "\n" (map ((" " <>) . ppTyped) topes)] + TypeErrorTopesNotEquivalent expected actual -> block TopDown + [ "expected tope" + , " " <> ppU (untyped expected) + , "but got" + , " " <> ppU (untyped actual) ] + + TypeErrorInvalidArgumentType argType argKind -> block TopDown + [ "invalid function parameter type" + , " " <> ppU argType + , "function parameter can be a cube, a shape, or a type" + , "but given parameter type has type" + , " " <> ppU (untyped argKind) + ] + + TypeErrorDuplicateTopLevel previous lastName -> block TopDown + [ "duplicate top-level definition" + , " " <> ppVarIdentWithLocation lastName + , "previous top-level definitions found at" + , intercalate "\n" + [ " " <> ppVarIdentWithLocation name + | name <- previous ] + ] + + TypeErrorUnusedVariable name type_ -> block TopDown + [ "unused variable" + , " " <> ppVar name <> " : " <> ppU (untyped type_) + ] + + TypeErrorUnusedUsedVariables vars name -> block TopDown + [ "unused variables" + , " " <> unwords (map ppVar vars) + , "declared as used in definition of" + , " " <> ppVar name + ] + + TypeErrorImplicitAssumption (a, aType) name -> block TopDown + [ "implicit assumption" + , " " <> ppVar a <> " : " <> ppU (untyped aType) + , "used in definition of" + , " " <> ppVar name + ] + where + ppU = ppTerm naming + ppTyped = ppTermT naming + ppVar = ppName naming + +ppAction :: Naming n -> Int -> Action n -> String +ppAction naming n = unlines . map (replicate (2 * n) ' ' <>) . \case + ActionTypeCheck term ty -> + [ "typechecking" + , " " <> ppU term + , "against type" + , " " <> ppU (untyped ty) ] + + ActionUnify term expected actual -> + [ "unifying expected type" + , " " <> ppU (untyped expected) + , "with actual type" + , " " <> ppU (untyped actual) + , "for term" + , " " <> ppU (untyped term) ] + + ActionUnifyTerms expected actual -> + [ "unifying term (expected)" + , " " <> ppTyped expected + , "with term (actual)" + , " " <> ppTyped actual ] + + ActionInfer term -> + [ "inferring type for term" + , " " <> ppU term ] + + ActionContextEntailedBy topes term -> + [ "checking if local context" + , intercalate "\n" (map ((" " <>) . ppU . untyped) topes) + , "includes (is entailed by) restriction tope" + , " " <> ppU (untyped term) ] + + ActionContextEntails topes term -> + [ "checking if local context" + , intercalate "\n" (map ((" " <>) . ppU . untyped) topes) + , "is included in (entails) the tope" + , " " <> ppU (untyped term) ] + + ActionContextEntailsUnion topes terms -> + [ "checking if local context" + , intercalate "\n" (map ((" " <>) . ppU . untyped) topes) + , "is included in (entails) the union of the topes" + , intercalate "\n" (map ((" " <>) . ppU . untyped) terms) ] + + ActionWHNF term -> + [ "computing WHNF for term" + , " " <> ppTyped term ] + + ActionNF term -> + [ "computing normal form for term" + , " " <> ppU (untyped term) ] + + ActionCheckCoherence (ltope, lterm) (rtope, rterm) -> + [ "checking coherence for" + , " " <> ppU (untyped ltope) + , " |-> " <> ppU (untyped lterm) + , "and" + , " " <> ppU (untyped rtope) + , " |-> " <> ppU (untyped rterm) ] + + ActionCloseSection Nothing -> + [ "closing the file" + , "and collecting assumptions (variables)" ] + ActionCloseSection (Just sectionName) -> + [ "closing #section " <> Rzk.printTree sectionName + , "and collecting assumptions (variables)"] + + ActionCheckLetValue orig -> + [ "checking the local definition " + <> maybe "_" (Rzk.printTree . getVarIdent) orig ] + where + ppU = ppTerm naming + ppTyped = ppTermT naming + +-- | The context an error was raised in: where it happened, what was being +-- checked, the tope context, the stack of judgements, and the hypotheses. +ppContext :: OutputDirection -> Context n -> String +ppContext dir ctx@Context{..} = block dir $ dropWhile null + [ block TopDown + [ case ctxLocation of + _ | dir == TopDown -> "" -- FIXME + Just (LocationInfo (Just path) (Just lineNo)) -> + path <> " (line " <> show lineNo <> "):" + Just (LocationInfo (Just path) _) -> + path <> ":" + _ -> "" + , case ctxCurrentCommand of + Just (Rzk.CommandDefine _loc name _vars _params _ty _term) -> + " Error occurred when checking\n #define " <> Rzk.printTree name + Just (Rzk.CommandPostulate _loc name _vars _params _ty ) -> + " Error occurred when checking\n #postulate " <> Rzk.printTree name + Just (Rzk.CommandCheck _loc term ty) -> + " Error occurred when checking\n " <> Rzk.printTree term <> " : " <> Rzk.printTree ty + Just (Rzk.CommandCompute _loc term) -> + " Error occurred when computing\n " <> Rzk.printTree term + Just (Rzk.CommandComputeNF _loc term) -> + " Error occurred when computing NF for\n " <> Rzk.printTree term + Just (Rzk.CommandComputeWHNF _loc term) -> + " Error occurred when computing WHNF for\n " <> Rzk.printTree term + Just (Rzk.CommandSetOption _loc optionName _optionValue) -> + " Error occurred when trying to set option\n #set-option " <> show optionName + Just command@Rzk.CommandUnsetOption{} -> + " Error occurred when trying to unset option\n " <> Rzk.printTree command + Just command@Rzk.CommandAssume{} -> + " Error occurred when checking assumption\n " <> Rzk.printTree command + Just (Rzk.CommandSection _loc name) -> + " Error occurred when checking\n #section " <> Rzk.printTree name + Just (Rzk.CommandSectionEnd _loc name) -> + " Error occurred when checking\n #end " <> Rzk.printTree name + Nothing -> " Error occurred outside of any command!" + ] + , "" + , case filter (not . isTopeTop) (availableTopes ctx) of + [] -> "Local tope context is unrestricted (⊤)." + topes -> namedBlock TopDown "Local tope context:" + [ " " <> ppU (untyped tope) + | tope <- topes ] + , "" + , block dir + [ "when " <> ppAction naming 0 action + | action <- ctxActionStack ] + , namedBlock TopDown "Definitions in context:" + [ block dir + [ ppName naming name <> " : " <> ppU (untyped (varType info)) + | (name, info) <- reverse (varsInScope ctx) ] ] + ] + where + naming = namingOfContext ctx + ppU = ppTerm naming + isTopeTop TopeTopT{} = True + isTopeTop _ = False + +-- | An error, with the context it was raised in. +ppTypeErrorInScopedContext :: OutputDirection -> TypeErrorInScopedContext -> String +ppTypeErrorInScopedContext dir (TypeErrorInScopedContext ctx err) = block dir + [ ppTypeError (namingOfContext ctx) err + , "" + , ppContext dir ctx + ] diff --git a/src/Rzk/TypeCheck/Eval.hs b/src/Rzk/TypeCheck/Eval.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/Eval.hs @@ -0,0 +1,1615 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE RecordWildCards #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Entering a scope, evaluation, and the tope solver. +-- +-- These three are one recursive knot and cannot be separated: +-- +-- * entering a binder needs 'whnfT', to see whether a flat variable is a point +-- of a cube and so brings a discreteness axiom with it; +-- * 'whnfT' strips an extension type's restrictions, which asks the solver +-- whether a face's tope holds ('checkTope'); +-- * 'nfT' normalises under a binder and under a tope ('localTope'); +-- * and the solver normalises the topes it reasons about ('nfTope'). +module Rzk.TypeCheck.Eval where + +import Control.Monad (forM, forM_, unless, when) +import Control.Monad.Except (runExcept) +import Control.Monad.Reader (ask, asks, local, + runReaderT) +import Control.Monad.Trans.Writer.CPS (runWriterT) +import Data.List (intercalate, nub, nubBy, + tails) +import Data.Maybe (catMaybes) + +import Control.Monad.Foil (DExt, Distinct, NameBinder) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil (AST (Node, Var), + ScopedAST (..)) +import Data.Bifunctor (Bifunctor) + +import Control.Monad.Free.Foil.Annotated (AnnSig (..)) +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), TModality (..), + TypeInfo (..), VarIdent) +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Display +import Rzk.TypeCheck.Error +import Rzk.TypeCheck.Monad + +-- * Variables + +-- | Look up a name and project one field of its 'VarInfo'. +infoOfVar :: (VarInfo n -> a) -> Foil.Name n -> TypeCheck n a +infoOfVar f x = asks (f . lookupVarInfo x) + +valueOfVar :: Foil.Name n -> TypeCheck n (Maybe (TermT n)) +valueOfVar = infoOfVar varValue + +typeOfVar :: Foil.Name n -> TypeCheck n (TermT n) +typeOfVar = infoOfVar varType + +modalityOfVar :: Foil.Name n -> TypeCheck n TModality +modalityOfVar = infoOfVar varModality + +locksOfVar :: Foil.Name n -> TypeCheck n TModality +locksOfVar = infoOfVar varModAccum + +isTopLevelVar :: Foil.Name n -> TypeCheck n Bool +isTopLevelVar = infoOfVar varIsTopLevel + +-- | Is a surface name defined? +checkDefinedVar :: Distinct n => VarIdent -> TypeCheck n () +checkDefinedVar name = asks (lookupNamed name) >>= \case + Nothing -> issueTypeError (TypeErrorUndefined name) + Just _ -> return () + +typeOfUncomputed :: TermT n -> TypeCheck n (TermT n) +typeOfUncomputed = \case + Var x -> typeOfVar x + t -> case typeInfoOf t of + Just info -> pure (infoType info) + Nothing -> panicImpossible "a node with no annotation" + +typeOf :: Distinct n => TermT n -> TypeCheck n (TermT n) +typeOf t = typeOfUncomputed t >>= whnfT + +-- | The free variables of a typed term, including those that occur only in the +-- /types/ of the variables it mentions. +-- +-- A definition can depend on a section assumption without naming it: through the +-- type of something else it uses. Closing a section has to see that dependency, and +-- it is exactly what distinguishes an implicit assumption from an explicit one. +freeVarsDeep :: TermT n -> TypeCheck n [Foil.Name n] +freeVarsDeep t = do + ctx <- ask + let typeOfName v = varType (lookupVarInfo v ctx) + + -- a node's own free variables, and those of its type + partial term = case typeInfoOf term of + Nothing -> freeVarsOfTermT term + Just info -> freeVarsOfTermT term <> freeVarsOfTermT (infoType info) + + go vars latest + | null new = vars + | otherwise = go (new <> vars) (foldMap (partial . typeOfName) new) + where + new = filter (`notElemName` vars) (nubNames latest) + + pure (go [] (partial t)) + +nubNames :: [Foil.Name n] -> [Foil.Name n] +nubNames = nubBy (\a b -> Foil.nameId a == Foil.nameId b) + +elemName :: Foil.Name n -> [Foil.Name n] -> Bool +elemName x = any (\y -> Foil.nameId x == Foil.nameId y) + +notElemName :: Foil.Name n -> [Foil.Name n] -> Bool +notElemName x = not . elemName x + +-- * Substitution, in the monad + +-- | Instantiate a scoped term with an argument: the old @substituteT@. +instantiate :: Distinct n => ScopedTermT n -> TermT n -> TypeCheck n (TermT n) +instantiate scoped arg = do + scope <- asks ctxScope + pure (instantiateT scope scoped arg) + +-- * Entering a binder + +-- | The discreteness axiom a flat cube variable brings with it: a flat point of +-- @2@ (or of @I@) is one of the endpoints. Maintained at binder entry so that +-- entailment does not have to rescan the context on every query. +discreteAxiomOf + :: forall n l. Distinct n + => TModality -> TermT n -> NameBinder n l -> TypeCheck n [ModalTope l] +discreteAxiomOf Flat ty binder = whnfT ty >>= \case + Cube2T{} -> pure [endpoints cube2_0T cube2_1T] + CubeIT{} -> pure [endpoints cubeI_0T cubeI_1T] + _ -> pure [] + where + z = Var (Foil.nameOf binder) :: TermT l + endpoints zero one = plainTope (topeOrT (topeEQT z zero) (topeEQT z one)) +discreteAxiomOf _ _ _ = pure [] + +-- | What a binder adds to the context. +binderInfo + :: Binder -> TModality -> TermT n -> Maybe (TermT n) -> Maybe LocationInfo + -> VarInfo n +binderInfo orig md ty mval loc = VarInfo + { varType = ty + , varValue = mval + , varModality = md + , varModAccum = Id + , varOrig = orig + , varIsAssumption = False + , varIsTopLevel = False + , varDeclaredAssumptions = [] + , varLocation = loc + } + +-- | Run an action under a binder that has already been chosen. +underBinder + :: (Distinct n, DExt n l) + => NameBinder n l -> Binder -> TModality -> TermT n -> Maybe (TermT n) + -> TypeCheck l a -> TypeCheck n a +underBinder binder orig md ty mval action = do + ctx <- ask + discrete <- discreteAxiomOf md ty binder + let info = binderInfo orig md ty mval (ctxLocation ctx) + ctx' = enterBinder binder info discrete ctx + -- A new discreteness axiom changes the saturation input; an ordinary binder + -- carries the cached value in with the rest of the context (saturation + -- commutes with renaming). + inContext ctx' $ + if null discrete then action else withRefreshedTopes id action + +-- | Enter a fresh binder (one the checker invents) and run an action whose result +-- says nothing about the new scope. +withBinder + :: Distinct n + => Binder -> TModality -> TermT n + -> (forall l. (DExt n l, Distinct l) => NameBinder n l -> TypeCheck l a) + -> TypeCheck n a +withBinder orig md ty k = do + scope <- asks ctxScope + withFreshIn scope $ \binder -> + underBinder binder orig md ty Nothing (k binder) + +withFreshIn + :: Distinct n + => Foil.Scope n + -> (forall l. (DExt n l, Distinct l) => NameBinder n l -> r) + -> r +withFreshIn scope k = Foil.withFresh scope k + +-- | Open a scoped term under its own binder, run the action on the body, and pack +-- the result back up as a scoped term. +underScope + :: Distinct n + => Binder -> TModality -> TermT n -> Maybe (TermT n) + -> ScopedTermT n + -> (forall l. (DExt n l, Distinct l) => TermT l -> TypeCheck l (TermT l)) + -> TypeCheck n (ScopedTermT n) +underScope orig md ty mval scoped k = do + scope <- asks ctxScope + withScopedT scope scoped $ \binder body -> + ScopedAST binder <$> underBinder binder orig md ty mval (k body) + +-- | Like 'underScope', for a Π (or a λ over a shape), which binds a tope scope +-- beside the body under what the user wrote as one binder. +underScope2 + :: Distinct n + => Binder -> TModality -> TermT n + -> ScopedTermT n -> ScopedTermT n + -> (forall l. (DExt n l, Distinct l) => TermT l -> TermT l -> TypeCheck l (TermT l, TermT l)) + -> TypeCheck n (ScopedTermT n, ScopedTermT n) +underScope2 orig md ty scoped1 scoped2 k = do + scope <- asks ctxScope + withScopedT2 scope scoped1 scoped2 $ \binder body1 body2 -> do + (r1, r2) <- underBinder binder orig md ty Nothing (k body1 body2) + pure (ScopedAST binder r1, ScopedAST binder r2) + +-- | Open a scoped term for a computation whose result says nothing about the new +-- scope (a check, or a rendered string). +inScope + :: (Bifunctor sig, Distinct n) + => Binder -> TModality -> TermT n -> ScopedAST NameBinder sig n + -> (forall l. (DExt n l, Distinct l) => AST NameBinder sig l -> TypeCheck l a) + -> TypeCheck n a +inScope orig md ty = inScopeWith orig md ty Nothing + +-- | Like 'inScope', for a binder that stands for a known value (a @let@). +inScopeWith + :: (Bifunctor sig, Distinct n) + => Binder -> TModality -> TermT n -> Maybe (TermT n) + -> ScopedAST NameBinder sig n + -> (forall l. (DExt n l, Distinct l) => AST NameBinder sig l -> TypeCheck l a) + -> TypeCheck n a +inScopeWith orig md ty mval scoped k = do + scope <- asks ctxScope + withScopedT scope scoped $ \binder body -> + underBinder binder orig md ty mval (k body) + +-- | Open a scoped term with a binder that has just been entered. +-- +-- The scoped term lives in the enclosing scope, and so may be the codomain of the +-- type a λ is being checked against, or the tope of a shape: all of them are +-- opened under the /one/ binder the λ introduces. +openScoped + :: (Bifunctor sig, DExt n l) + => NameBinder n l -> ScopedAST NameBinder sig n -> TypeCheck l (AST NameBinder sig l) +openScoped binder scoped = do + scope <- asks ctxScope + pure (openWith scope (Foil.nameOf binder) scoped) + +-- | A scope that does not use its binder: the codomain of a non-dependent function +-- type, say. +constScope :: Distinct n => TermT n -> TypeCheck n (ScopedTermT n) +constScope t = do + scope <- asks ctxScope + pure (Foil.withFresh scope $ \binder -> ScopedAST binder (Foil.sink t)) + +-- | Enter the binder of an /untyped/ scope — the body of a λ, or of a let, as the +-- user wrote it — and elaborate it into a typed one. +-- +-- The binder comes from the term being checked, and the scopes of the /type/ it is +-- checked against are opened under that same binder with 'openScoped'. +elaborateUnder + :: Distinct n + => Binder -> TModality -> TermT n -> Maybe (TermT n) + -> ScopedTerm n + -> (forall l. (DExt n l, Distinct l) + => NameBinder n l -> Term l -> TypeCheck l (TermT l)) + -> TypeCheck n (ScopedTermT n) +elaborateUnder orig md ty mval scoped k = do + scope <- asks ctxScope + withScopedT scope scoped $ \binder body -> + ScopedAST binder <$> underBinder binder orig md ty mval (k binder body) + +-- | Enter the binder of an untyped scope and run a computation under it. +-- +-- The result may not mention the new scope — but a 'ScopedAST' /hides/ its scope, +-- so the continuation can pack whatever it built with the binder it was given and +-- hand back as many scoped terms as it likes. That is how a λ returns its +-- elaborated body, its shape tope and the type it turned out to have, all at once. +checkUnderWith + :: Distinct n + => Binder -> TModality -> TermT n -> Maybe (TermT n) -> ScopedTerm n + -> (forall l. (DExt n l, Distinct l) + => NameBinder n l -> Term l -> TypeCheck l a) + -> TypeCheck n a +checkUnderWith orig md ty mval scoped k = do + scope <- asks ctxScope + withScopedT scope scoped $ \binder body -> + underBinder binder orig md ty mval (k binder body) + +checkUnder + :: Distinct n + => Binder -> TModality -> TermT n -> ScopedTerm n + -> (forall l. (DExt n l, Distinct l) + => NameBinder n l -> Term l -> TypeCheck l a) + -> TypeCheck n a +checkUnder orig md ty = checkUnderWith orig md ty Nothing + +-- * Modalities + +enterModality :: Distinct n => TModality -> TypeCheck n b -> TypeCheck n b +enterModality Id action = action +enterModality md action = do + ctx <- asks (applyModality md) + let ctx' = ctx { ctxTopesEntailBottom = Nothing } + -- 'applyModality' invalidated the saturation cache (accessibility changed); + -- refresh it under the shifted context. + inContext ctx' (withRefreshedTopes id action) + +-- * The tope context + +-- | Assume a tope for the enclosed action. +localTope :: Distinct n => TermT n -> TypeCheck n a -> TypeCheck n a +localTope tope tc = do + ctx <- ask' + tope' <- nfTope tope + let modalTope' = plainTope tope' + -- A small optimisation to help unify terms faster. + let noNewInformation = case tope' of + TopeEQT _ x y | eqT x y -> True + _ -> any (eqModalTope modalTope') (ctxTopesNF ctx) + if noNewInformation + then tc + else do + entailsBottom <- (modalTope' : ctxTopesNF ctx) `entailM` topeBottomT + withRefreshedTopes (extend modalTope' entailsBottom) tc + where + ask' = asks id + extend tope' entailsBottom ctx = ctx + { ctxTopes = plainTope tope : ctxTopes ctx + , ctxTopesNF = tope' : ctxTopesNF ctx + , ctxTopesNFUnion = map nubModalTopes + [ new <> old + | new <- simplifyLHSwithDisjunctions [tope'] + , old <- ctxTopesNFUnion ctx ] + , ctxTopesEntailBottom = Just entailsBottom + } + +-- | Install a deferred saturation cache for the transformed context, and run the +-- action with it. +-- +-- The pipeline's effects are discharged purely into a thunk: installing costs +-- nothing, holes recorded by the speculative run are discarded, and a pipeline +-- error (a tope guard with a hole in lenient mode, say, which the per-query path +-- would never have evaluated) becomes 'Nothing', so errors surface exactly where +-- they did before. +withRefreshedTopes + :: Distinct n + => (Context n -> Context n) -> TypeCheck n a -> TypeCheck n a +withRefreshedTopes f action = do + ctx' <- asks f + let sat = case runExcept (runWriterT (runReaderT (saturateForEntailment (ctxTopesNF ctx')) ctx')) of + Left _ -> Nothing + Right (s, _) -> Just s + local (const ctx' { ctxTopesSaturated = SaturationCached sat }) action + +-- | Run a check in every alternative of a disjunctive tope context. +inAllSubContexts :: Distinct n => TypeCheck n () -> TypeCheck n () -> TypeCheck n () +inAllSubContexts handleSingle tc = do + topeSubContexts <- asks ctxTopesNFUnion + case topeSubContexts of + [] -> panicImpossible "empty set of alternative contexts" + [_] -> handleSingle + _:_:_ -> + forM_ topeSubContexts $ \topes' -> + withRefreshedTopes (\ctx -> ctx + { ctxTopes = topes' + , ctxTopesNF = topes' + , ctxTopesNFUnion = [topes'] + }) tc + +-- * Equality of topes + +eqModalTope :: Distinct n => ModalTope n -> ModalTope n -> Bool +eqModalTope l r = and + [ tModAccum l == tModAccum r + , tModVar l == tModVar r + , eqT (tTope l) (tTope r) + ] + +nubModalTopes :: Distinct n => [ModalTope n] -> [ModalTope n] +nubModalTopes [] = [] +nubModalTopes (t : ts) = t : nubModalTopes (filter (not . eqModalTope t) ts) + +elemModalTope :: Distinct n => ModalTope n -> [ModalTope n] -> Bool +elemModalTope t = any (eqModalTope t) + +-- * Entailment + +-- | Monadic 'all' that stops at the first failing element. +allM :: Monad m => (a -> m Bool) -> [a] -> m Bool +allM p = go + where + go [] = return True + go (x:xs) = p x >>= \case + False -> return False + True -> go xs + +entailM :: Distinct n => [ModalTope n] -> TermT n -> TypeCheck n Bool +entailM modalTopes goal = do + saturated <- saturateForEntailment modalTopes + entailSaturatedM saturated goal + +-- | The preprocessing 'entailM' does before searching: dedup, split off the +-- context's disjunctions, and saturate each alternative. Depends only on the +-- given topes (plus the discreteness axioms of the context), not on the goal. +saturateForEntailment + :: Distinct n => [ModalTope n] -> TypeCheck n [[ModalTope n]] +saturateForEntailment modalTopes = do + discreteAxioms <- asks ctxDiscreteTopes + let topes' = nubModalTopes (modalTopes <> discreteAxioms) + topes'' = simplifyLHSwithDisjunctions topes' + mapM (fmap (saturateTopes . saturateBottom) . saturateInv) topes'' + +-- | Search each saturated alternative for the goal. +entailSaturatedM + :: Distinct n => [[ModalTope n]] -> TermT n -> TypeCheck n Bool +entailSaturatedM saturated goal = asks ctxVerbosity >>= \case + Debug -> do + naming <- asks namingOfContext + let prettyTopes = map (ppTerm naming . untyped . tTope) (concat saturated) + prettyTope = ppTerm naming (untyped goal) + traceTypeCheck Debug + ("entail " <> intercalate ", " prettyTopes <> " |- " <> prettyTope) $ + allM (`solveRHSM` goal) saturated + _ -> allM (`solveRHSM` goal) saturated + +-- | Entailment against the context's own tope context, using the cached +-- saturation when one was installed. Matching on the payload of +-- 'SaturationCached' is what forces the deferred pipeline, so the cost is paid at +-- the first query under a context, and never for one that is never queried. +entailContextM :: Distinct n => TermT n -> TypeCheck n Bool +entailContextM goal = asks ctxTopesSaturated >>= \case + SaturationCached (Just saturated) -> entailSaturatedM saturated goal + SaturationCached Nothing -> fallback + SaturationUncached -> fallback + where + fallback = asks ctxTopesNF >>= (`entailM` goal) + +-- * Saturation + +saturateTopes :: Distinct n => [ModalTope n] -> [ModalTope n] +saturateTopes topes = saturated <> inaccessible + where + (accessible, inaccessible) = partitionAccessible topes + saturated = saturateWith + elemModalTope + (\new old -> map plainTope (generateTopes (map tTope new) (map tTope old))) + accessible + +saturateInv :: Distinct n => [ModalTope n] -> TypeCheck n [ModalTope n] +saturateInv modalTopes = do + -- FIXME: this is a workaround; ideally we should regenerate all topes on + -- EVERY modality change in any layer, but that would produce too many; for + -- now we also invert topes that were accessible before the modality shift. + let accessible = filterAccessible modalTopes + accessibleById = filter (\mt -> coe (tModVar mt) Id) modalTopes + invResults <- forM (nubModalTopes (accessible <> accessibleById)) $ \mt -> do + nf <- nfTope $ modExtractT topeT Id Op (topeInvT (tTope mt)) + return $ ModalTope (tModAccum mt) Op nf + let accessibleUnderOp = + filter (\mt -> coe (tModVar mt) (comp (tModAccum mt) Op)) modalTopes + uninvResults <- forM accessibleUnderOp $ \(ModalTope acc var' phi) -> do + nf <- nfTope $ topeUninvT (modAppT topeT Op phi) + return $ ModalTope (comp acc Op) var' nf + let newTopes = nubModalTopes (invResults <> uninvResults) + fresh = filter (\t -> not (elemModalTope t modalTopes)) newTopes + return (modalTopes <> fresh) + +-- | Ex falso for BOT, lifted across modalities. +-- +-- A contradiction in the topes that are genuinely available at the identity +-- modality entails BOT, and BOT entails @_μ BOT@ for every modality @μ@ by the +-- absurd rule (this holds for BOT specifically; a general tope @φ@ does NOT give +-- @_μ φ@, which would need the missing unit @id ⇒ μ@). Re-asserting @_μ BOT@ at +-- each lock @μ@ where an available tope was hidden lets the contradiction survive +-- the lock: @_b BOT@ is accessible under a @_b@ lock (@coe Flat Flat@), so +-- @mod _b recBOT@ in a vacuous context is accepted. +-- +-- A tope counts as available at the identity modality when its variable modality +-- coerces into @Id@: a @_b@-modal tope qualifies via the counit (@coe Flat Id@), +-- but a @_#@-modal one does not (@coe Sharp Id@ is False) — which is exactly why +-- @_# BOT@ does not leak to plain BOT. +saturateBottom :: Distinct n => [ModalTope n] -> [ModalTope n] +saturateBottom modalTopes + | null droppedAccums = modalTopes -- nothing hidden by a lock + | botDerivable = modalTopes <> fresh + | otherwise = modalTopes + where + idAccessible = filter (\mt -> coe (tModVar mt) Id) modalTopes + droppedAccums = nub [ tModAccum mt | mt <- idAccessible, not (isAccessible mt) ] + saturatedId = saturateWith elemT generateTopes (map tTope idAccessible) + botDerivable = topeBottomT `elemT` saturatedId + fresh = [ mt + | acc <- droppedAccums + , let mt = ModalTope acc acc topeBottomT + , not (elemModalTope mt modalTopes) ] + +-- FIXME: cleanup +saturateWith :: (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a] +saturateWith elem' step zs = go (nub' zs) [] + where + go lastNew xs + | null new = lastNew + | otherwise = lastNew <> go new xs' + where + xs' = lastNew <> xs + new = filter (not . (`elem'` xs')) (nub' $ step lastNew xs) + nub' [] = [] + nub' (x:xs) = x : nub' (filter (not . (`elem'` [x])) xs) + +generateTopes :: Distinct n => [TermT n] -> [TermT n] -> [TermT n] +generateTopes newTopes oldTopes + | topeBottomT `elemT` newTopes = [] + | topeEQT cube2_0T cube2_1T `elemT` newTopes = [topeBottomT] + | topeEQT cubeI_0T cubeI_1T `elemT` newTopes = [topeBottomT] + | length oldTopes > 100 = [] -- FIXME + | otherwise = concat + [ -- symmetry EQ + [ topeEQT y x | TopeEQT _ty x y <- newTopes ] + -- transitivity EQ (1) + , [ topeEQT x z + | TopeEQT _ty x y : newTopes' <- tails newTopes + , TopeEQT _ty y' z <- newTopes' <> oldTopes + , eqT y y' ] + -- transitivity EQ (2) + , [ topeEQT x z + | TopeEQT _ty y z : newTopes' <- tails newTopes + , TopeEQT _ty x y' <- newTopes' <> oldTopes + , eqT y y' ] + + -- transitivity LEQ (1) + , [ topeLEQT x z + | TopeLEQT _ty x y : newTopes' <- tails newTopes + , TopeLEQT _ty y' z <- newTopes' <> oldTopes + , eqT y y' ] + -- transitivity LEQ (2) + , [ topeLEQT x z + | TopeLEQT _ty y z : newTopes' <- tails newTopes + , TopeLEQT _ty x y' <- newTopes' <> oldTopes + , eqT y y' ] + + -- antisymmetry LEQ + , [ topeEQT x y + | TopeLEQT _ty x y : newTopes' <- tails newTopes + , TopeLEQT _ty y' x' <- newTopes' <> oldTopes + , eqT y y' + , eqT x x' ] + + -- FIXME: special case of substitution of EQ + -- transitivity EQ-LEQ (1) + , [ topeLEQT x z + | TopeEQT _ty y z : newTopes' <- tails newTopes + , TopeLEQT _ty x y' <- newTopes' <> oldTopes + , eqT y y' ] + + -- transitivity EQ-LEQ (2) + , [ topeLEQT x z + | TopeEQT _ty x y : newTopes' <- tails newTopes + , TopeLEQT _ty y' z <- newTopes' <> oldTopes + , eqT y y' ] + + -- transitivity EQ-LEQ (3) + , [ topeLEQT x z + | TopeLEQT _ty y z : newTopes' <- tails newTopes + , TopeEQT _ty x y' <- newTopes' <> oldTopes + , eqT y y' ] + + -- transitivity EQ-LEQ (4) + , [ topeLEQT x z + | TopeLEQT _ty x y : newTopes' <- tails newTopes + , TopeEQT _ty y' z <- newTopes' <> oldTopes + , eqT y y' ] + + -- FIXME: consequence of LEM for LEQ and antisymmetry for LEQ + , [ topeEQT x y | TopeLEQT _ty x y@Cube2_0T{} <- newTopes ] + , [ topeEQT x y | TopeLEQT _ty x@Cube2_1T{} y <- newTopes ] + , [ topeEQT x y | TopeLEQT _ty x y@CubeI_0T{} <- newTopes ] + , [ topeEQT x y | TopeLEQT _ty x@CubeI_1T{} y <- newTopes ] + + -- subtyping 2 <: II: endpoints and order of 2 lift to II + , [ topeEQT x cubeI_0T | TopeEQT _ty x Cube2_0T{} <- newTopes ] + , [ topeEQT cubeI_0T x | TopeEQT _ty Cube2_0T{} x <- newTopes ] + , [ topeEQT x cubeI_1T | TopeEQT _ty x Cube2_1T{} <- newTopes ] + , [ topeEQT cubeI_1T x | TopeEQT _ty Cube2_1T{} x <- newTopes ] + , [ topeLEQT x cubeI_0T | TopeLEQT _ty x Cube2_0T{} <- newTopes ] + , [ topeLEQT cubeI_0T x | TopeLEQT _ty Cube2_0T{} x <- newTopes ] + , [ topeLEQT x cubeI_1T | TopeLEQT _ty x Cube2_1T{} <- newTopes ] + , [ topeLEQT cubeI_1T x | TopeLEQT _ty Cube2_1T{} x <- newTopes ] + ] + +generateTopesForPointsM :: Distinct n => [TermT n] -> TypeCheck n [TermT n] +generateTopesForPointsM points = do + let endpoints = [cube2_0T, cube2_1T, cubeI_0T, cubeI_1T] + pairs = nubPairs $ concat + [ [ (x, y) + | x : points' <- tails (filter (\p -> not (p `elemT` endpoints)) points) + , y <- points' + , not (eqT x y) ] + ] + stars <- forM points $ \x -> do + xType <- typeOf x + return $ case xType of + CubeUnitT{} -> [topeEQT x cubeUnitStarT] + _ -> [] + topes <- forM pairs $ \(x, y) -> do + xType <- typeOf x + yType <- typeOf y + return $ case (xType, yType) of + (Cube2T{}, Cube2T{}) -> [topeOrT (topeLEQT x y) (topeLEQT y x)] + _ -> [] + return (concat (topes ++ stars)) + where + nubPairs [] = [] + nubPairs (p@(x, y) : ps) = + p : nubPairs (filter (\(x', y') -> not (eqT x x' && eqT y y')) ps) + +allTopePoints :: Distinct n => TermT n -> [TermT n] +allTopePoints = nubT . foldMap subPoints . nubT . topePoints + +topePoints :: TermT n -> [TermT n] +topePoints = \case + TopeTopT{} -> [] + TopeBottomT{} -> [] + TopeAndT _ l r -> topePoints l <> topePoints r + TopeOrT _ l r -> topePoints l <> topePoints r + TopeEQT _ x y -> [x, y] + TopeLEQT _ x y -> [x, y] + _ -> [] + +subPoints :: TermT n -> [TermT n] +subPoints = \case + p@(PairT _ x y) -> p : foldMap subPoints [x, y] + p@(Var _) -> [p] + p -> case typeInfoOf p of + Just TypeInfo{ infoType = CubeUnitT{} } -> [p] + Just TypeInfo{ infoType = Cube2T{} } -> [p] + _ -> [] + +-- * Simplifying the left-hand side + +-- | Simplify the context, including disjunctions. +simplifyLHSwithDisjunctions :: Distinct n => [ModalTope n] -> [[ModalTope n]] +simplifyLHSwithDisjunctions topes = map nubModalTopes $ + case topes of + [] -> [[]] + ModalTope _ _ TopeTopT{} : topes' -> simplifyLHSwithDisjunctions topes' + ModalTope mAcc mVar TopeBottomT{} : _ -> [[ModalTope mAcc mVar topeBottomT]] + ModalTope mAcc mVar (TopeAndT _ l r) : topes' -> + simplifyLHSwithDisjunctions (ModalTope mAcc mVar l : ModalTope mAcc mVar r : topes') + + -- NOTE: it is inefficient to expand disjunctions immediately + ModalTope mAcc mVar (TopeOrT _ l r) : topes' -> + simplifyLHSwithDisjunctions (ModalTope mAcc mVar l : topes') + <> simplifyLHSwithDisjunctions (ModalTope mAcc mVar r : topes') + + ModalTope mAcc mVar (TopeEQT _ (PairT _ x y) (PairT _ x' y')) : topes' -> + simplifyLHSwithDisjunctions + (ModalTope mAcc mVar (topeEQT x x') : ModalTope mAcc mVar (topeEQT y y') : topes') + ModalTope mAcc mVar (TypeModalT _ md inTope) : topes' -> + simplifyLHSwithDisjunctions (ModalTope mAcc (comp mVar md) inTope : topes') + t : topes' -> map (t :) (simplifyLHSwithDisjunctions topes') + +-- * Solving the right-hand side + +solveRHSM :: Distinct n => [ModalTope n] -> TermT n -> TypeCheck n Bool +solveRHSM modalTopes goal = + let topes = accessibleTopes modalTopes + in case goal of + _ | topeBottomT `elemT` topes -> return True + TopeTopT{} -> return True + TypeModalT _ty md inTope -> do + let shifted = applyModalityToTopes md modalTopes + resaturated = saturateTopes shifted + resaturatedInv <- saturateInv resaturated + solveRHSM resaturatedInv inTope + TopeEQT _ty (PairT _ty1 x y) (PairT _ty2 x' y') -> + solveRHSM modalTopes $ topeAndT (topeEQT x x') (topeEQT y y') + TopeEQT _ty (PairT TypeInfo{ infoType = CubeProductT _ cubeI cubeJ } x y) r -> + solveRHSM modalTopes $ topeAndT + (topeEQT x (firstT cubeI r)) + (topeEQT y (secondT cubeJ r)) + TopeEQT _ty l (PairT TypeInfo{ infoType = CubeProductT _ cubeI cubeJ } x y) -> + solveRHSM modalTopes $ topeAndT + (topeEQT (firstT cubeI l) x) + (topeEQT (secondT cubeJ l) y) + TopeEQT _ty l r + | or + [ eqT l r + , goal `elemT` topes + , topeEQT r l `elemT` topes + ] -> return True + TopeEQT _ty l r -> do + lType <- typeOf l + rType <- typeOf r + return $ case (lType, rType) of + (CubeUnitT{}, CubeUnitT{}) -> True + _ -> False + TopeLEQT _ty l r + | eqT l r -> return True + | solveRHS topes (topeEQT l r) -> return True + | solveRHS topes (topeEQT l cube2_0T) -> return True + | solveRHS topes (topeEQT r cube2_1T) -> return True + TopeAndT _ l r -> solveRHSM modalTopes l >>= \case + False -> return False + True -> solveRHSM modalTopes r + _ | goal `elemT` topes -> return True + TopeInvT{} -> do + goal' <- nfTope goal + case goal' of + TopeInvT{} -> return False + _ -> solveRHSM modalTopes goal' + TopeUninvT{} -> do + goal' <- nfTope goal + case goal' of + TopeUninvT{} -> return False + _ -> solveRHSM modalTopes goal' + TopeOrT _ l r -> do + found <- solveRHSM modalTopes l >>= \case + True -> return True + False -> solveRHSM modalTopes r + if found + then return True + else do + lems <- generateTopesForPointsM (allTopePoints goal) + let lems' = [ lem | lem@(TopeOrT _ t1 t2) <- lems, all (`notElemT` topes) [t1, t2] ] + (accessible, hidden) = partitionAccessible modalTopes + withTope t = hidden ++ saturateTopes (plainTope t : accessible) + + case lems' of + TopeOrT _ t1 t2 : _ -> + solveRHSM (withTope t1) goal >>= \case + False -> return False + True -> solveRHSM (withTope t2) goal + _ -> return False + _ -> return False + +solveRHS :: Distinct n => [TermT n] -> TermT n -> Bool +solveRHS topes tope = + case tope of + _ | topeBottomT `elemT` topes -> True + TopeTopT{} -> True + TopeEQT _ty (PairT _ty1 x y) (PairT _ty2 x' y') + | solveRHS topes (topeEQT x x') && solveRHS topes (topeEQT y y') -> True + TopeEQT _ty (PairT TypeInfo{ infoType = CubeProductT _ cubeI cubeJ } x y) r + | solveRHS topes (topeEQT x (firstT cubeI r)) + , solveRHS topes (topeEQT y (secondT cubeJ r)) -> True + TopeEQT _ty l (PairT TypeInfo{ infoType = CubeProductT _ cubeI cubeJ } x y) + | solveRHS topes (topeEQT (firstT cubeI l) x) + , solveRHS topes (topeEQT (secondT cubeJ l) y) -> True + TopeEQT _ty l r -> or + [ eqT l r + , tope `elemT` topes + , topeEQT r l `elemT` topes + ] + TopeLEQT _ty l r + | eqT l r -> True + | solveRHS topes (topeEQT l r) -> True + | solveRHS topes (topeEQT l cube2_0T) -> True + | solveRHS topes (topeEQT r cube2_1T) -> True + TopeAndT _ l r -> solveRHS topes l && solveRHS topes r + TopeOrT _ l r -> solveRHS topes l || solveRHS topes r + _ -> tope `elemT` topes + +-- | Accumulate a modality over a list of topes. +applyModalityToTopes :: TModality -> [ModalTope n] -> [ModalTope n] +applyModalityToTopes md = map (\mt -> mt { tModAccum = comp (tModAccum mt) md }) + +partitionAccessible :: [ModalTope n] -> ([ModalTope n], [ModalTope n]) +partitionAccessible topes = (filter isAccessible topes, filter (not . isAccessible) topes) + +-- * The checks the rest of the checker calls + +checkTope :: Distinct n => TermT n -> TypeCheck n Bool +checkTope tope = do + topes <- asks availableTopes + performing (ActionContextEntails topes tope) $ do + tope' <- nfTope tope + entailContextM tope' + +checkTopeEntails :: Distinct n => TermT n -> TypeCheck n Bool +checkTopeEntails tope = do + topes <- asks availableTopes + performing (ActionContextEntailedBy topes tope) $ do + contextTopes <- asks availableTopesNF + restrictionTope <- nfTope tope + let contextTopesRHS = foldr topeAndT topeTopT contextTopes + [plainTope restrictionTope] `entailM` contextTopesRHS + +checkEntails :: Distinct n => TermT n -> TermT n -> TypeCheck n Bool +checkEntails l r = do -- FIXME: add action + l' <- nfTope l + r' <- nfTope r + [plainTope l'] `entailM` r' + +contextEntails :: Distinct n => TermT n -> TypeCheck n () +contextEntails tope = do + topes <- asks availableTopes + performing (ActionContextEntails topes tope) $ do + topeIsEntailed <- checkTope tope + topes' <- asks availableTopesNF + -- When a hole is used in a cube/tope position (as the argument of a + -- shape-restricted function, say), the tope being checked mentions the hole + -- and cannot be decided. Treat it as satisfied (defer) rather than failing. + unless (topeIsEntailed || containsHole tope) $ + issueTypeError $ TypeErrorTopeNotSatisfied topes' tope + +-- | Is the local tope context contradictory (does it entail ⊥)? +contextEntailsBottom :: Distinct n => TypeCheck n Bool +contextEntailsBottom = asks ctxTopesEntailBottom >>= \case + Just entails -> pure entails + Nothing -> asks ctxTopesNF >>= (`entailM` topeBottomT) + +topesEquiv :: Distinct n => TermT n -> TermT n -> TypeCheck n Bool +topesEquiv expected actual = performing (ActionUnifyTerms expected actual) $ do + expected' <- nfT expected + actual' <- nfT actual + (&&) + <$> [plainTope expected'] `entailM` actual' + <*> [plainTope actual'] `entailM` expected' + +-- | Check that the local tope context is included in (entails) the union of the +-- given topes. This is the COVERAGE obligation of @recOR@: every point of the +-- context must be covered by some branch guard. +-- +-- Only coverage is required, not equivalence: branch guards may overhang the +-- context (when splitting with an already-defined shape, say), so we do not +-- require @OR(guards) |- context@. +contextEntailsUnion :: Distinct n => [TermT n] -> TypeCheck n () +contextEntailsUnion topes = do + ctxTopes' <- asks availableTopes + performing (ActionContextEntailsUnion ctxTopes' topes) $ do + contextTopes <- asks ctxTopesNF + topesNF <- mapM nfTope topes + let unionRHS = foldr topeOrT topeBottomT topesNF + entailContextM unionRHS >>= \case + -- a guard mentioning an (unfilled) hole can't be decided; defer coverage + False | not (any containsHole topesNF) -> + issueTypeError $ TypeErrorTopeNotSatisfied (accessibleTopes contextTopes) unionRHS + _ -> return () + +-- | Diagnose a @recOR@ branch guard or a restriction face against the local tope +-- context. There are three cases, by how the tope relates to the context: +-- +-- * DISJOINT — the tope and a consistent context have empty overlap (their +-- conjunction is ⊥). The face or branch is then vacuous everywhere, so this is +-- a hard error. +-- * OVERHANG — the tope is not entailed by the context but still overlaps it. +-- This is allowed and often intentional (splitting or restricting with an +-- already-defined shape, whose faces live on the whole cube rather than being +-- relativised to the context), so we only emit a non-fatal hint. +-- * CONTAINED — the tope entails the context: nothing to report. +checkTopeAgainstContext :: Distinct n => String -> TermT n -> TypeCheck n () +checkTopeAgainstContext what tope = do + -- a contradictory context is handled elsewhere (recBOT) + ctxEntailsBottom <- contextEntailsBottom + unless ctxEntailsBottom $ do + contextTopes <- asks ctxTopesNF + let topes = filter (not . eqT topeTopT) (accessibleTopes contextTopes) + disjoint <- (plainTope tope : contextTopes) `entailM` topeBottomT + -- a face or guard mentioning an (unfilled) hole can't be decided; defer + if disjoint && not (containsHole tope) + then issueTypeError (TypeErrorTopeContextDisjoint tope topes) + else do + -- The hint below is opt-in (#set-option "warn-overhang"): deciding + -- whether the tope overhangs costs a solver entailment per face and + -- guard, and overhang is legitimate. + warnOverhang <- asks ctxWarnOverhang + when warnOverhang $ do + entailed <- checkTopeEntails tope -- tope |- AND(accessible context) + unless entailed $ do + naming <- asks namingOfContext + traceTypeCheck Normal + (intercalate "\n" $ + [ "Warning: " <> what <> " overhangs the local tope context" + , " " <> ppTerm naming (untyped tope) + , "is not entailed by the local context (normalised)" + ] <> map ((" " <>) . ppTerm naming . untyped) topes) + (return ()) + +-- * Restrictions and η + +stripTypeRestrictions :: TermT n -> TermT n +stripTypeRestrictions (TypeRestrictedT _ty ty _restriction) = stripTypeRestrictions ty +stripTypeRestrictions t = t + +-- | The term a restriction face pins down, when one of the faces holds. +tryRestriction :: Distinct n => TermT n -> TypeCheck n (Maybe (TermT n)) +tryRestriction = \case + TypeRestrictedT _ _ rs -> go rs + _ -> pure Nothing + where + go [] = pure Nothing + go ((tope, term') : rs') = checkTope tope >>= \case + True -> pure (Just term') + False -> go rs' + +-- | Perform at most one η-expansion at the top level, to assist unification. +etaMatch + :: Distinct n + => Maybe (TermT n) -> TermT n -> TermT n -> TypeCheck n (TermT n, TermT n) +-- FIXME: double check the next 3 rules +etaMatch _mterm expected@TypeRestrictedT{} actual@TypeRestrictedT{} = pure (expected, actual) +etaMatch mterm expected (TypeRestrictedT _ty ty _rs) = etaMatch mterm expected ty +etaMatch (Just term) expected@TypeRestrictedT{} actual = + etaMatch (Just term) expected (typeRestrictedT actual [(topeTopT, term)]) +-- Subtyping on the interval. +etaMatch _mterm CubeIT{} Cube2T{} = pure (cubeIT, cubeIT) +etaMatch _mterm expected@LambdaT{} actual@LambdaT{} = pure (expected, actual) +etaMatch _mterm expected@PairT{} actual@PairT{} = pure (expected, actual) +etaMatch _mterm expected@LambdaT{} actual = do + actual' <- etaExpand actual + pure (expected, actual') +etaMatch _mterm expected actual@LambdaT{} = do + expected' <- etaExpand expected + pure (expected', actual) +etaMatch _mterm expected@PairT{} actual = do + actual' <- etaExpand actual + pure (expected, actual') +etaMatch _mterm expected actual@PairT{} = do + expected' <- etaExpand expected + pure (expected', actual) +etaMatch _mterm expected actual = pure (expected, actual) + +etaExpand :: Distinct n => TermT n -> TypeCheck n (TermT n) +etaExpand term@LambdaT{} = pure term +etaExpand term@PairT{} = pure term +etaExpand term = do + ty <- typeOf term + case stripTypeRestrictions ty of + TypeFunT _ty orig md param mtope ret -> do + scope <- asks ctxScope + pure $ withFreshIn scope $ \binder -> + let z = Var (Foil.nameOf binder) + body = appT (openWith (Foil.extendScope binder scope) (Foil.nameOf binder) ret) + (Foil.sink term) z + mtope' = fmap (\t -> ScopedAST binder (openWith (Foil.extendScope binder scope) (Foil.nameOf binder) t)) mtope + in lambdaT ty orig + (Just (LambdaParam md param mtope')) + (ScopedAST binder body) + + TypeSigmaT _ty _orig _md a b -> do + let firstTerm = firstT a term + bInstantiated <- instantiate b firstTerm + pure $ pairT ty firstTerm (secondT bInstantiated term) + + CubeProductT _ty a b -> pure $ + pairT ty (firstT a term) (secondT b term) + + _ -> pure term + +-- * Layers + +inCubeLayer :: Distinct n => TermT n -> TypeCheck n Bool +inCubeLayer = \case + RecBottomT{} -> pure False + UniverseT{} -> pure False + + UniverseCubeT{} -> pure True + CubeProductT{} -> pure True + CubeUnitT{} -> pure True + CubeUnitStarT{} -> pure True + Cube2T{} -> pure True + Cube2_0T{} -> pure True + Cube2_1T{} -> pure True + + t -> typeOf t >>= inCubeLayer + +inTopeLayer :: Distinct n => TermT n -> TypeCheck n Bool +inTopeLayer = \case + RecBottomT{} -> pure False + UniverseT{} -> pure False + + UniverseCubeT{} -> pure True + UniverseTopeT{} -> pure True + + CubeProductT{} -> pure True + CubeUnitT{} -> pure True + CubeUnitStarT{} -> pure True + Cube2T{} -> pure True + Cube2_0T{} -> pure True + Cube2_1T{} -> pure True + + TopeTopT{} -> pure True + TopeBottomT{} -> pure True + TopeAndT{} -> pure True + TopeOrT{} -> pure True + TopeEQT{} -> pure True + TopeLEQT{} -> pure True + + TypeFunT _ty orig md param _mtope ret -> + inScope orig md param ret inTopeLayer + + t -> typeOfUncomputed t >>= inTopeLayer + +-- * Weak head normal form + +-- | Memoise a term's WHNF on its top node without reducing the term itself. +-- +-- The returned term has the same (unreduced) structure, so free-variable and +-- @uses@ detection see exactly what the user wrote, while a later 'whnfT' is O(1) +-- via the cached form. Used when storing a definition's elaborated type and value, +-- where an in-place reduction could otherwise discard or expose a variable +-- occurrence. +memoizeWHNF :: Distinct n => TermT n -> TypeCheck n (TermT n) +memoizeWHNF t@(Var _) = pure t +memoizeWHNF t@(Node (AnnSig info sig)) = do + w <- whnfT t + pure (Node (AnnSig info { infoWHNF = Just w } sig)) + +whnfT :: Distinct n => TermT n -> TypeCheck n (TermT n) +-- A memoised weak head normal form is answered before entering 'performing', +-- which would push an action and rebuild the context just to look a value up. The +-- caches are hit constantly (every 'typeOf' consults one), and the bookkeeping +-- costs more than the answer. +whnfT t | Just info <- typeInfoOf t, Just t' <- infoWHNF info = pure t' +whnfT tt = performing (ActionWHNF tt) $ case tt of + -- universe constants + UniverseT{} -> pure tt + UniverseCubeT{} -> pure tt + UniverseTopeT{} -> pure tt + + -- cube layer (except vars, pairs, and applications) + CubeProductT{} -> nfTope tt + CubeUnitT{} -> pure tt + CubeUnitStarT{} -> pure tt + Cube2T{} -> pure tt + Cube2_0T{} -> pure tt + Cube2_1T{} -> pure tt + CubeIT{} -> pure tt + CubeI_0T{} -> pure tt + CubeI_1T{} -> pure tt + CubeFlipT{} -> nfTope tt + CubeUnflipT{} -> nfTope tt + + -- tope layer (except vars, pairs of points, and applications) + TopeTopT{} -> pure tt + TopeBottomT{} -> pure tt + TopeAndT{} -> nfTope tt + TopeOrT{} -> nfTope tt + TopeEQT{} -> nfTope tt + TopeLEQT{} -> nfTope tt + TopeInvT{} -> nfTope tt + TopeUninvT{} -> nfTope tt + + -- type layer terms that should not be evaluated further + LambdaT{} -> pure tt + PairT{} -> pure tt + ReflT{} -> pure tt + TypeFunT{} -> pure tt + TypeSigmaT{} -> pure tt + TypeIdT{} -> pure tt + TypeModalT{} -> pure tt + RecBottomT{} -> pure tt + TypeUnitT{} -> pure tt + UnitT{} -> pure tt + + -- type ascriptions are ignored, since we already have a typechecked term + TypeAscT _ty term _ty' -> whnfT term + + -- check if we have a cube or a tope term (if so, compute NF) + _ -> typeOf tt >>= \case + UniverseCubeT{} -> nfTope tt + UniverseTopeT{} -> nfTope tt + + TypeUnitT{} -> pure unitT -- compute an expression of Unit type to unit + -- FIXME: next line is ad hoc, should be improved! + TypeRestrictedT _info TypeUnitT{} _rs -> pure unitT + + -- check if we have a cube point term (if so, compute NF) + typeOf_tt -> typeOf typeOf_tt >>= \case + UniverseCubeT{} -> nfTope tt + + -- now we are in the type layer + _ -> fmap termIsWHNF $ do + tryRestriction typeOf_tt >>= \case + Just tt' -> whnfT tt' + Nothing -> case tt of + -- a hole is opaque: it never reduces, it is already a normal form + HoleT{} -> pure tt + t@(Var x) -> + valueOfVar x >>= \case + Nothing -> pure t + Just term -> whnfT term + + AppT{} -> do + scope <- asks ctxScope + uncurry (applySpine scope) (collectAppSpine tt) + + LetT _ty _orig _mparam val body -> + instantiate body val >>= whnfT + LetModT ty orig app inn mparam val body -> + (enterModality app $ whnfT val) >>= \case + ModAppT _ md t | md == inn -> do + val' <- enterModality md $ whnfT t + instantiate body val' >>= whnfT + b' | isRA inn -> do + bty <- typeOf b' >>= \case + TypeModalT _ _ t -> pure t + _ -> panicImpossible "not modal in letmod" + instantiate body (modExtractT bty app inn b') >>= whnfT + _ -> pure (LetModT ty orig app inn mparam val body) + FirstT ty t -> + whnfT t >>= \case + PairT _ l _r -> whnfT l + t' -> pure (FirstT ty t') + + SecondT ty t -> + whnfT t >>= \case + PairT _ _l r -> whnfT r + t' -> pure (SecondT ty t') + ModAppT ty md b -> + (enterModality md $ whnfT b) >>= \case + ModExtractT _ app inn t | inn == md -> enterModality (comp md app) $ whnfT t + b' -> pure $ ModAppT ty md b' + ModExtractT ty app inn b -> + (enterModality app $ whnfT b) >>= \case + ModAppT _ md t | inn == md -> enterModality inn $ whnfT t + b' -> pure (ModExtractT ty app inn b') + IdJT ty tA a tC d x p -> + whnfT p >>= \case + ReflT{} -> whnfT d + p' -> pure (IdJT ty tA a tC d x p') + + RecOrT _ty rs -> do + firstMatching rs >>= \case + Just tt' -> whnfT tt' + Nothing + | [tt'] <- nubT (map snd rs) -> whnfT tt' + | otherwise -> pure tt + + TypeRestrictedT ty type_ rs -> do + rs' <- traverse (\(tope, term) -> (,) <$> nfT tope <*> pure term) rs + case filter (not . eqT topeBottomT . fst) rs' of + [] -> whnfT type_ -- get rid of restrictions at BOT + rs'' -> TypeRestrictedT ty <$> whnfT type_ <*> pure rs'' + +-- | The branch of a @recOR@ (or the face of a restriction) whose guard holds. +firstMatching :: Distinct n => [(TermT n, TermT n)] -> TypeCheck n (Maybe (TermT n)) +firstMatching [] = pure Nothing +firstMatching ((tope, t) : rest) = checkTope tope >>= \case + True -> pure (Just t) + False -> firstMatching rest + +-- * Application, reducing a whole spine at once +-- +-- A curried application @f x y z@ is a left-nested tower of 'AppT'. Reducing it +-- one argument at a time rebuilds the intermediate lambdas — @f x@ produces +-- @\\ y z -> …@ only for the next argument to tear it apart — and each rebuild is +-- a full 'substituteT' traversal (~70% of beta reductions on sHoTT are such +-- spines). Instead, collect the spine, then peel the head's syntactic lambda +-- chain into a /single/ substitution: @\\ a b c -> body@ applied to @x y z@ maps +-- @{a↦x, b↦y, c↦z}@ and substitutes into @body@ once. +-- +-- Sound because 'whnfT' of a lambda is the identity — a lambda, its binder +-- shape-restricted or not, is already in weak head normal form — so the +-- intermediate lambdas this skips building would have been returned unchanged, +-- and substitution composes. Beta reduction ignores the binder's domain (the +-- shape restriction is a typing obligation, not enforced during reduction); the +-- tope and modality side-conditions fire only for a /neutral/ function of +-- shape-restricted function type, which is never a lambda. The moment the body +-- is not a syntactic lambda the substitution is applied and control returns to +-- 'whnfT' via 'applySpine'; a neutral head goes to 'applyWhnfFun', unchanged. + +-- | The head of an application spine and its arguments, in application order, +-- each paired with the type annotation of its 'AppT' node (needed to rebuild a +-- neutral application). +collectAppSpine :: TermT n -> (TermT n, [(TypeInfo (TermT n), TermT n)]) +collectAppSpine = go [] + where + go acc (AppT ty f x) = go ((ty, x) : acc) f + go acc h = (h, acc) + +-- | Apply a function term to a spine of arguments, reducing. +applySpine + :: Distinct n + => Foil.Scope n -> TermT n -> [(TypeInfo (TermT n), TermT n)] -> TypeCheck n (TermT n) +applySpine _ h [] = whnfT h +applySpine scope h pairs = whnfT h >>= \h' -> case h' of + LambdaT _ _ _ (ScopedAST binder body) | (_, x) : rest <- pairs -> + peelLambdas scope (Foil.addSubst Foil.identitySubst binder x) body rest + _ -> applyNeutral scope h' pairs + +-- | Peel the head's syntactic lambda chain into one substitution, then reduce. +-- @subst@ maps the binders consumed so far to their arguments; @body@ is the +-- current lambda's body, at the scope those binders extended into. +peelLambdas + :: forall i n. Distinct n + => Foil.Scope n -> Foil.Substitution TermT i n -> TermT i + -> [(TypeInfo (TermT n), TermT n)] -> TypeCheck n (TermT n) +peelLambdas scope subst body pairs = case pairs of + [] -> whnfT (substituteT scope subst body) + (_, x) : rest -> case body of + LambdaT _ _ _ (ScopedAST binder body') -> + peelLambdas scope (Foil.addSubst subst binder x) body' rest + _ -> applySpine scope (substituteT scope subst body) pairs + +-- | Apply a non-lambda (already WHNF) function to a spine, one argument at a +-- time: this is the type-directed part of application, unchanged from before. +applyNeutral + :: Distinct n + => Foil.Scope n -> TermT n -> [(TypeInfo (TermT n), TermT n)] -> TypeCheck n (TermT n) +applyNeutral _ h [] = pure h +applyNeutral scope h ((ty, x) : rest) = do + r <- applyWhnfFun ty h x + if null rest then pure r else applySpine scope r rest + +-- | Apply a non-lambda function @f'@ (already WHNF) to one argument @x@. A +-- shape-restricted function contributes a tope side-condition; a function whose +-- return type is restricted refines the application's type; everything else is a +-- neutral application. Extracted verbatim from the old single-argument @AppT@ case. +applyWhnfFun :: Distinct n => TypeInfo (TermT n) -> TermT n -> TermT n -> TypeCheck n (TermT n) +applyWhnfFun ty f' x = typeOf f' >>= \case + TypeFunT _ty _orig md _param (Just tope) (ScopedAST _ UniverseTopeT{}) -> do + x' <- enterModality md $ nfT x + sideCondition <- instantiate tope x' >>= nfT + pure (topeAndT (AppT ty f' x') sideCondition) + -- FIXME: this seems to be a hack, and will not work in all + -- situations! FIXME: for now, it seems to add ~2x slowdown + TypeFunT info _orig md _param _mtope ret@(ScopedAST _ TypeRestrictedT{}) + | TypeRestrictedT{} <- infoType info -> pure (AppT ty f' x) + | otherwise -> do + x' <- enterModality md $ whnfT x + ret' <- instantiate ret x' + tryRestriction ret' >>= \case -- FIXME: too many unnecessary checks? + Nothing -> pure (AppT ty { infoType = ret' } f' x') + Just tt' -> whnfT tt' + _ -> pure (AppT ty f' x) + +-- * Normal form of the tope layer + +nfTope :: Distinct n => TermT n -> TypeCheck n (TermT n) +nfTope tt = performing (ActionNF tt) $ fmap termIsNF $ case tt of + HoleT{} -> pure tt + Var x -> + valueOfVar x >>= \case + Nothing -> return tt + Just term -> nfTope term + + -- see if a normal form is already available + _ | Just info <- typeInfoOf tt, Just tt' <- infoNF info -> pure tt' + + -- universe constants + UniverseT{} -> pure tt + UniverseCubeT{} -> pure tt + UniverseTopeT{} -> pure tt + + -- cube layer constants + CubeUnitT{} -> pure tt + CubeUnitStarT{} -> pure tt + Cube2T{} -> pure tt + Cube2_0T{} -> pure tt + Cube2_1T{} -> pure tt + CubeIT{} -> pure tt + CubeI_0T{} -> pure tt + CubeI_1T{} -> pure tt + + -- type layer constants + TypeUnitT{} -> pure tt + UnitT{} -> pure tt + + -- cube layer with computation + CubeProductT _ty l r -> cubeProductT <$> nfTope l <*> nfTope r + + CubeFlipT ty t -> + nfTope t >>= \case + CubeUnflipT _ t' -> pure t' + Cube2_0T{} -> pure (modAppT (typeModalT cubeT Op cube2T) Op cube2_1T) + Cube2_1T{} -> pure (modAppT (typeModalT cubeT Op cube2T) Op cube2_0T) + CubeI_0T{} -> pure (modAppT (typeModalT cubeT Op cubeIT) Op cubeI_1T) + CubeI_1T{} -> pure (modAppT (typeModalT cubeT Op cubeIT) Op cubeI_0T) + t' -> pure (CubeFlipT ty t') + + CubeUnflipT ty t -> + nfTope t >>= \case + CubeFlipT _ t' -> pure t' + ModAppT _ Op Cube2_0T{} -> pure cube2_1T + ModAppT _ Op Cube2_1T{} -> pure cube2_0T + ModAppT _ Op CubeI_0T{} -> pure cubeI_1T + ModAppT _ Op CubeI_1T{} -> pure cubeI_0T + t' -> pure (CubeUnflipT ty t') + + -- tope layer constants + TopeTopT{} -> pure tt + TopeBottomT{} -> pure tt + + -- tope layer with computation + TopeAndT ty l r -> + nfTope l >>= \case + TopeBottomT{} -> pure topeBottomT + l' -> nfTope r >>= \case + TopeBottomT{} -> pure topeBottomT + r' -> pure (TopeAndT ty l' r') + + TopeOrT ty l r -> do + l' <- nfTope l + r' <- nfTope r + case (l', r') of + (TopeBottomT{}, _) -> pure r' + (_, TopeBottomT{}) -> pure l' + _ -> pure (TopeOrT ty l' r') + + TopeEQT ty l r -> TopeEQT ty <$> nfTope l <*> nfTope r + TopeLEQT ty l r -> TopeLEQT ty <$> nfTope l <*> nfTope r + + TopeInvT ty t -> + -- Match And/Or on the *unnormalised* input: nfTope of a shape-restricted App + -- produces a TopeAnd via shape-side-condition propagation, and distributing + -- inv over that synthetic conjunction loops forever, because the recursive + -- topeInvT renormalises the same App back into a TopeAnd. + case t of + TopeTopT _ -> pure $ modAppT topeT Op topeTopT + TopeBottomT _ -> pure $ modAppT topeT Op topeBottomT + TopeLEQT _ x y -> invOf topeLEQT x y + TopeEQT _ x y -> invOf topeEQT x y + TopeAndT _ phi psi -> nfTope $ + modAppT (typeModalT universeT Op topeT) Op + (topeAndT + (modExtractT topeT Id Op (topeInvT phi)) + (modExtractT topeT Id Op (topeInvT psi))) + TopeOrT _ phi psi -> nfTope $ + modAppT (typeModalT universeT Op topeT) Op + (topeOrT + (modExtractT topeT Id Op (topeInvT phi)) + (modExtractT topeT Id Op (topeInvT psi))) + _ -> + nfTope t >>= \case + TopeTopT _ -> pure topeTopT + TopeBottomT _ -> pure topeBottomT + TopeUninvT _ phi -> pure phi + TopeLEQT _ x y -> invOf topeLEQT x y + TopeEQT _ x y -> invOf topeEQT x y + t' -> pure (TopeInvT ty t') + where + invOf mk x y = do + xTy <- typeOf x + yTy <- typeOf y + nfTope $ + modAppT (typeModalT universeT Op topeT) Op + (mk (modExtractT topeT Id Op (cubeFlipT xTy y)) + (modExtractT topeT Id Op (cubeFlipT yTy x))) + + TopeUninvT ty t -> + case t of + ModAppT _ Op inner -> case inner of + TopeTopT _ -> pure topeTopT + TopeBottomT _ -> pure topeBottomT + TopeAndT _ phi psi -> + nfTope (topeAndT (topeUninvT phi) (topeUninvT psi)) + TopeOrT _ phi psi -> + nfTope (topeOrT (topeUninvT phi) (topeUninvT psi)) + _ -> + nfTope t >>= \case + TopeTopT _ -> pure topeTopT + TopeBottomT _ -> pure topeBottomT + TopeInvT _ phi -> pure phi + ModAppT _ Op inner'' -> case inner'' of + TopeLEQT _ x y -> uninvOf topeLEQT x y + TopeEQT _ x y -> uninvOf topeEQT x y + inner' -> + pure $ TopeUninvT ty + (modAppT (typeModalT universeT Op topeT) Op inner') + t' -> pure (TopeUninvT ty t') + _ -> + nfTope t >>= \case + TopeInvT _ phi -> pure phi + t'@(ModAppT _ Op _) -> nfTope (TopeUninvT ty t') + t' -> pure (TopeUninvT ty t') + where + uninvOf mk x y = do + xTy <- typeOf x + yTy <- typeOf y + nfTope $ + mk (cubeUnflipT xTy (modAppT (typeModalT cubeT Op xTy) Op y)) + (cubeUnflipT yTy (modAppT (typeModalT cubeT Op yTy) Op x)) + + -- type ascriptions are ignored, since we already have a typechecked term + TypeAscT _ty term _ty' -> nfTope term + + PairT ty l r -> PairT ty <$> nfTope l <*> nfTope r + + AppT ty f x -> + nfTope f >>= \case + LambdaT _ty _orig _arg body -> + instantiate body x >>= nfTope + f' -> typeOfUncomputed f' >>= \case + TypeFunT _ty _orig md _param (Just tope) (ScopedAST _ UniverseTopeT{}) -> do + x' <- enterModality md $ nfTope x + sideCondition <- instantiate tope x' >>= nfTope + pure (topeAndT (AppT ty f' x') sideCondition) + _ -> AppT ty f' <$> nfTope x + + FirstT ty t -> + nfTope t >>= \case + PairT _ty x _y -> pure x + t' -> pure (FirstT ty t') + + SecondT ty t -> + nfTope t >>= \case + PairT _ty _x y -> pure y + t' -> pure (SecondT ty t') + + LambdaT ty orig _mparam body + | TypeFunT _ty _origF md param mtope _ret <- infoType ty -> do + -- NOTE: the domain @param@ is left unnormalised: in the tope layer it may + -- be a shape (a function type into TOPE), which nfTope cannot normalise. + body' <- underScope orig md param Nothing body nfTope + pure (LambdaT ty orig (Just (LambdaParam md param mtope)) body') + LambdaT{} -> panicImpossible "lambda with a non-function type in the tope layer" + + ModAppT ty md b -> + (enterModality md $ nfTope b) >>= \case + ModExtractT _ _ inn t | inn == md -> pure t + b' -> pure $ ModAppT ty md b' + ModExtractT ty app inn b -> + (enterModality app $ nfTope b) >>= \case + ModAppT _ md t | inn == md -> pure t + b' -> pure $ ModExtractT ty app inn b' + LetModT ty orig app inn mparam val body -> + (enterModality app $ nfTope val) >>= \case + ModAppT _ md t | md == inn -> + instantiate body t >>= nfTope + b' | isRA inn -> do + bty <- typeOf b' >>= \case + TypeModalT _ _ t -> pure t + _ -> panicImpossible "not modal in letmod" + instantiate body (modExtractT bty app inn b') >>= nfTope + b' -> do + bty <- typeOf b' >>= \case + TypeModalT _ _ t -> pure t + _ -> panicImpossible "not modal in letmod" + val' <- enterModality app $ nfTope b' + body' <- underScope orig (comp app inn) bty Nothing body nfTope + pure (LetModT ty orig app inn mparam val' body') + + TypeModalT ty md inner -> TypeModalT ty md <$> (enterModality md $ nfTope inner) + LetT _ty _orig _mparam val body -> instantiate body val >>= nfTope + TypeFunT{} -> panicImpossible "exposed function type in the tope layer" + TypeSigmaT{} -> panicImpossible "dependent sum type in the tope layer" + TypeIdT{} -> panicImpossible "identity type in the tope layer" + ReflT{} -> panicImpossible "refl in the tope layer" + IdJT{} -> panicImpossible "idJ eliminator in the tope layer" + TypeRestrictedT{} -> panicImpossible "extension types in the tope layer" + + -- A recOR/recBOT is a term-level eliminator, never a tope. It should have been + -- rejected before reaching here (see the RecOr case of 'typecheck'); as a safety + -- net for any other path, report a type error rather than panicking. + RecOrT{} -> issueTypeError $ TypeErrorOther "a recOR cannot appear in the tope layer" + RecBottomT{} -> issueTypeError $ TypeErrorOther "a recBOT cannot appear in the tope layer" + +-- * Normal form + +nfT :: Distinct n => TermT n -> TypeCheck n (TermT n) +nfT tt = performing (ActionNF tt) $ case tt of + -- universe constants + UniverseT{} -> pure tt + UniverseCubeT{} -> pure tt + UniverseTopeT{} -> pure tt + + -- cube layer constants + CubeUnitT{} -> pure tt + CubeUnitStarT{} -> pure tt + Cube2T{} -> pure tt + Cube2_0T{} -> pure tt + Cube2_1T{} -> pure tt + CubeIT{} -> pure tt + CubeI_0T{} -> pure tt + CubeI_1T{} -> pure tt + + -- cube layer with computation + CubeProductT{} -> nfTope tt + CubeFlipT{} -> nfTope tt + CubeUnflipT{} -> nfTope tt + + -- tope layer constants + TopeTopT{} -> pure tt + TopeBottomT{} -> pure tt + + -- tope layer with computation + TopeAndT{} -> nfTope tt + TopeOrT{} -> nfTope tt + TopeEQT{} -> nfTope tt + TopeLEQT{} -> nfTope tt + TopeInvT{} -> nfTope tt + TopeUninvT{} -> nfTope tt + + -- type layer constants + ReflT ty _x -> pure (ReflT ty Nothing) + RecBottomT{} -> pure tt + TypeUnitT{} -> pure tt + UnitT{} -> pure tt + + -- type ascriptions are ignored, since we already have a typechecked term + TypeAscT _ty term _ty' -> nfT term + + -- now we are in the type layer + _ -> + typeOf tt >>= tryRestriction >>= \case + Just tt' -> nfT tt' + Nothing -> case tt of + -- a hole is opaque: it never reduces, it is already a normal form + HoleT{} -> pure tt + t@(Var x) -> + valueOfVar x >>= \case + Nothing -> pure t + Just term -> nfT term + + TypeFunT ty orig md param mtope ret -> do + param' <- enterModality md $ nfT param + case mtope of + Nothing -> do + ret' <- underScope orig md param' Nothing ret nfT + pure (TypeFunT ty orig md param' Nothing ret') + Just tope -> do + (tope', ret') <- underScope2 orig md param' tope ret $ \topeBody retBody -> do + topeNF <- nfT topeBody + retNF <- localTope topeNF (nfT retBody) + pure (topeNF, retNF) + pure (TypeFunT ty orig md param' (Just tope') ret') + + AppT ty f x -> + whnfT f >>= \case + LambdaT _ty _orig _arg body -> + instantiate body x >>= nfT + f' -> typeOf f' >>= \case + TypeFunT _ty _orig md _param (Just tope) (ScopedAST _ UniverseTopeT{}) -> do + x' <- enterModality md $ nfT x + sideCondition <- instantiate tope x' >>= nfT + pure (topeAndT (AppT ty f' x') sideCondition) + _ -> AppT ty <$> nfT f' <*> nfT x + LetT _ty _orig _mparam val body -> + instantiate body val >>= nfT + LetModT ty orig app inn mparam val body -> + (enterModality app $ whnfT val) >>= \case + ModAppT _ md t | md == inn -> do + val' <- enterModality md $ nfT t + instantiate body val' >>= nfT + b' | isRA inn -> do + bty <- typeOf b' >>= \case + TypeModalT _ _ t -> pure t + _ -> panicImpossible "not modal in letmod" + instantiate body (modExtractT bty app inn b') >>= nfT + b' -> do + bty <- typeOf b' >>= \case + TypeModalT _ _ t -> pure t + _ -> panicImpossible "not modal in letmod" + val' <- enterModality app $ nfT b' + body' <- underScope orig (comp app inn) bty Nothing body nfT + pure (LetModT ty orig app inn mparam val' body') + LambdaT ty orig _mparam body -> + case stripTypeRestrictions (infoType ty) of + TypeFunT _ty _orig md param mtope _ret -> do + param' <- enterModality md $ nfT param + case mtope of + Nothing -> do + body' <- underScope orig md param' Nothing body nfT + pure (LambdaT ty orig (Just (LambdaParam md param' Nothing)) body') + Just tope -> do + (tope', body') <- underScope2 orig md param' tope body $ \topeBody bodyBody -> do + topeNF <- nfT topeBody + bodyNF <- localTope topeNF (nfT bodyBody) + pure (topeNF, bodyNF) + pure (LambdaT ty orig (Just (LambdaParam md param' (Just tope'))) body') + _ -> panicImpossible "lambda with a non-function type" + + TypeSigmaT ty orig md a b -> do + a' <- enterModality md $ nfT a + b' <- underScope orig md a' Nothing b nfT + pure (TypeSigmaT ty orig md a' b') + PairT ty l r -> PairT ty <$> nfT l <*> nfT r + FirstT ty t -> + whnfT t >>= \case + PairT _ l _r -> nfT l + t' -> FirstT ty <$> nfT t' + SecondT ty t -> + whnfT t >>= \case + PairT _ _l r -> nfT r + t' -> SecondT ty <$> nfT t' + + TypeIdT ty x _tA y -> TypeIdT ty <$> nfT x <*> pure Nothing <*> nfT y + IdJT ty tA a tC d x p -> + whnfT p >>= \case + ReflT{} -> nfT d + p' -> IdJT ty <$> nfT tA <*> nfT a <*> nfT tC <*> nfT d <*> nfT x <*> nfT p' + + RecOrT _ty rs -> + firstMatching rs >>= \case + Just tt' -> nfT tt' + Nothing + | [tt'] <- nubT (map snd rs) -> nfT tt' + | otherwise -> pure tt + TypeModalT ty md b -> do + b' <- enterModality md $ nfT b + pure (TypeModalT ty md b') + ModAppT ty md b -> + (enterModality md $ whnfT b) >>= \case + ModExtractT _ app inn t | inn == md -> enterModality (comp app inn) $ nfT t + b' -> ModAppT ty md <$> (enterModality md $ nfT b') + ModExtractT ty app inn b -> + (enterModality app $ whnfT b) >>= \case + ModAppT _ md t | inn == md -> enterModality (comp app inn) $ nfT t + b' -> ModExtractT ty app inn <$> (enterModality app $ nfT b') + TypeRestrictedT ty type_ rs -> do + rs' <- forM rs $ \(tope, term) -> + nfTope tope >>= \case + TopeBottomT{} -> pure Nothing + tope' -> do + term' <- localTope tope' (nfT term) + return (Just (tope', term')) + case catMaybes rs' of + [] -> nfT type_ + rs'' -> TypeRestrictedT ty <$> nfT type_ <*> pure rs'' diff --git a/src/Rzk/TypeCheck/Judgements.hs b/src/Rzk/TypeCheck/Judgements.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/Judgements.hs @@ -0,0 +1,1185 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The judgements — @typecheck@ and @infer@ — and the hole inventory. +-- +-- The two belong together: checking a hole records its goal and context, and +-- recording a hole probes what could fill it, which typechecks and unifies +-- candidate terms. +module Rzk.TypeCheck.Judgements where + +import Control.Applicative ((<|>)) +import Control.Monad (forM, forM_, unless, when) +import Control.Monad.Except (catchError) +import Control.Monad.Reader (asks, local) +import Control.Monad.Writer.CPS (censor) +import Data.List (intercalate, tails) +import Data.Maybe (fromMaybe, isNothing) +import Data.String (fromString) + +import Control.Monad.Foil (Distinct) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil (AST (Var), ScopedAST (..)) + +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), TModality (..), + TypeInfo (..), VarIdent, + binderDisplayName, binderIsCompound, + binderLeaves, binderName, + freshenBinderLeaves, getVarIdent, + ppVarIdentWithLocation, + unmarkUnresolved) +import qualified Language.Rzk.Syntax as Rzk +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Display +import Rzk.TypeCheck.Error +import Rzk.TypeCheck.Eval +import Rzk.TypeCheck.Monad +import Rzk.TypeCheck.Render +import Rzk.TypeCheck.Unify + +-- * Layers of a goal + +isCubeType :: TermT n -> Bool +isCubeType = \case + CubeUnitT{} -> True + Cube2T{} -> True + CubeIT{} -> True + CubeProductT{} -> True + UniverseCubeT{} -> True + _ -> False + +-- | Is a (WHNF) goal type in the cube or tope layer, so that a hole of this type +-- is a cube point or a tope rather than a term? Used to suppress the +-- type-layer-specific hole candidates (@recOR@, @recBOT@), which cannot inhabit a +-- cube or a tope. +isCubeOrTopeType :: TermT n -> Bool +isCubeOrTopeType t = isCubeType t || case t of + UniverseTopeT{} -> True + _ -> False + +-- * Shadowing + +-- | The names in scope a new one would shadow. +doesShadowName :: VarIdent -> TypeCheck n [VarIdent] +doesShadowName name = asks (shadowedBy name) + +checkTopLevelDuplicate :: Distinct n => VarIdent -> TypeCheck n () +checkTopLevelDuplicate name = + doesShadowName name >>= \case + [] -> return () + collisions -> issueTypeError $ TypeErrorDuplicateTopLevel collisions name + +checkNameShadowing :: VarIdent -> TypeCheck n () +checkNameShadowing name = + doesShadowName name >>= \case + [] -> return () + collisions -> issueWarning $ + Rzk.printTree (getVarIdent name) <> " shadows an existing definition:" + <> unlines + [ " " <> ppVarIdentWithLocation name + , "previous top-level definitions found at" + , intercalate "\n" + [ " " <> ppVarIdentWithLocation prev | prev <- collisions ] ] + +-- * The hole inventory + +-- | A fresh hole of the given type. +mkHole :: TermT n -> TermT n +mkHole t = HoleT TypeInfo{ infoType = t, infoWHNF = Nothing, infoNF = Nothing } Nothing + +-- | How many /branching/ eliminators 'allEliminationsInto' will chain. +-- +-- A forced Π-application is free (see 'allEliminationsInto'), so this bounds only +-- the Σ/cube projections and @idJ@ steps, not the argument count of a spine. A +-- temporary fixed bound: branching is shallow in the goals seen so far (a few +-- projections), and a larger bound mostly adds self-referential spines (a built +-- result eliminated again). +maxEliminationDepth :: Int +maxEliminationDepth = 7 + +-- | Whether eliminating a value spends the search budget. A forced Π-application +-- is a 'SpineStep' — there is one way to fill the argument (with a hole), so +-- 'allEliminationsInto' applies it for free; a 'Branching' eliminator (a Σ/cube +-- projection or @idJ@) costs one against 'maxEliminationDepth'. +data ElimCost = SpineStep | Branching + deriving (Eq, Show) + +-- | All ways to eliminate a hypothesis into a value usable at a goal. +-- +-- Given a @target@ type and a hypothesis /term/, return every elimination spine +-- over that term whose type fits the target (or a subtype of it). Arguments +-- introduced by application are left as holes for the caller to fill later. A +-- value that already fits is returned as-is; a function is applied to holes; a +-- Σ-type (or anything that unfolds to one, e.g. @is-contr@) is projected, possibly +-- repeatedly — so @first (first (is-segal-A ? ? ? ? ?))@ is discovered. +-- +-- A Π-application is a forced spine step, so it extends the spine for free and +-- does not spend the budget. Only the genuinely branching eliminators count +-- against 'maxEliminationDepth', so the bound limits real search depth, not +-- argument count, and a lemma that must be applied to many holes is still reached. +allEliminationsInto + :: Distinct n => TermT n -> TermT n -> TypeCheck n [TermT n] +allEliminationsInto target = go maxEliminationDepth + where + go depth term = do + ty <- typeOf term + fits <- fitsInto term ty target + elims <- eliminatorsOf ty + let step (SpineStep, wrap) = go depth =<< wrap term + step (Branching, wrap) + | depth <= 0 = pure [] + | otherwise = go (depth - 1) =<< wrap term + deeper <- concat <$> mapM step elims + pure ([term | fits] <> deeper) + +-- | Whether a term of the given (whnf) type may stand where a value of the +-- @target@ type is expected: the two types unify under 'structuralHoleUnify', so a +-- hole acts as a wildcard leaf but a structural mismatch around it is still a +-- mismatch (an under-applied function does not match an extension-type goal, but a +-- partial application that genuinely fits an ordinary-function goal does). +-- +-- Outer type restrictions are stripped from both sides first: an extension-type +-- boundary is satisfied by later refinement, not by the choice of spine, and +-- matching against the restricted goal would reject the very spine that introduces +-- the holes meant to satisfy it (@f ?@ at a boundary goal, say). +-- +-- Holes or constraints recorded while probing are discarded, so this is a pure +-- yes\/no query. +fitsInto :: Distinct n => TermT n -> TermT n -> TermT n -> TypeCheck n Bool +fitsInto term ty target = do + ty' <- stripTypeRestrictions <$> whnfT ty + target' <- stripTypeRestrictions <$> whnfT target + censor (const []) $ local structuralHoleUnify + ((unify (Just term) target' ty' >> pure True) `catchError` \_ -> pure False) + +-- | The eliminators a value of the given (weak head normal) type admits, each as a +-- function wrapping the eliminated term, paired with its 'ElimCost'. +-- +-- A Π-type is eliminated by application to a fresh hole (a spine step); a Σ-type by +-- either projection; an identity type by path induction (@idJ@), with the motive +-- and base case left as holes. The projections and @idJ@ branch. Anything else +-- admits no simple eliminator. +eliminatorsOf + :: Distinct n + => TermT n -> TypeCheck n [(ElimCost, TermT n -> TypeCheck n (TermT n))] +eliminatorsOf ty = + case stripTypeRestrictions ty of + TypeFunT _ty _orig _md param _mtope ret -> + pure [ (SpineStep, \term -> do + let h = mkHole param + retAt <- instantiate ret h + pure (appT retAt term h)) ] + TypeSigmaT _ty _orig _md a b -> + pure [ (Branching, \term -> pure (firstT a term)) + , (Branching, \term -> do + bAt <- instantiate b (firstT a term) + pure (secondT bAt term)) ] + -- A cube point pair (a pattern-bound @(t , s) : 2 × 2@, say) projects to its + -- coordinates; rzk renders those projections back as the pattern names. + CubeProductT _ty a b -> + pure [ (Branching, \term -> pure (firstT a term)) + , (Branching, \term -> pure (secondT b term)) ] + -- A path @p : a =_A x@ is eliminated by path induction. The motive + -- @C : (z : A) → (a =_A z) → U@ is always a function, so we introduce it + -- straight away as @\\ b q → ?@ rather than leaving it a bare hole: the spine + -- @idJ A a (\\ b q → ?) ? x p@ then has type @C x p@, which β-reduces to that + -- inner hole — so J fits any goal (the player fills the motive and the base case + -- @d : C a refl@). The two holes are the motive predicate and the base. + TypeIdT _ty a mtA x -> do + tA <- maybe (typeOf a) pure mtA + scope <- asks ctxScope + let c = motiveOf scope a tA + dType = appT universeT + (appT (typeFunT (BinderVar Nothing) Id (typeIdT a (Just tA) a) Nothing + (closedScope scope universeT)) + c a) + (reflT (typeIdT a (Just tA) a) Nothing) + d = mkHole dType + motiveAt y p = appT universeT + (appT (typeFunT (BinderVar Nothing) Id (typeIdT a (Just tA) y) Nothing + (closedScope scope universeT)) + c y) p + pure [ (Branching, \p -> pure (idJT (motiveAt x p) tA a c d x p)) ] + _ -> pure [] + +-- | A scoped term that does not use its binder. +closedScope :: Distinct n => Foil.Scope n -> (forall l. TermT l) -> ScopedTermT n +closedScope scope t = Foil.withFresh scope $ \binder -> ScopedAST binder t + +-- | The motive @\\ b q → ?@ of a path induction: a type in the two motive binders, +-- left as a hole. +motiveOf :: Distinct n => Foil.Scope n -> TermT n -> TermT n -> TermT n +motiveOf scope a tA = + Foil.withFresh scope $ \bBinder -> + let scopeB = Foil.extendScope bBinder scope + b = Var (Foil.nameOf bBinder) + idTypeAtB = typeIdT (Foil.sink a) (Just (Foil.sink tA)) b + in Foil.withFresh scopeB $ \qBinder -> + let cBody = mkHole universeT + cInner = lambdaT + (typeFunT (BinderVar Nothing) Id idTypeAtB Nothing + (ScopedAST qBinder universeT)) + (BinderVar (Just "q")) Nothing + (ScopedAST qBinder cBody) + cType = typeFunT (BinderVar Nothing) Id tA Nothing + (ScopedAST bBinder + (typeFunT (BinderVar Nothing) Id idTypeAtB Nothing + (ScopedAST qBinder universeT))) + in lambdaT cType (BinderVar (Just "b")) Nothing (ScopedAST bBinder cInner) + +-- | The binder for a λ introduced over a domain type. +-- +-- A binder the type already gives as a pattern is kept as-is — it carries the +-- user's own names (@(t , s)@). Otherwise an /explicit/ (pre-whnf) Σ-type or +-- product domain is destructured into a fresh pair pattern, recursively for +-- products, so that a nameless @2 × 2 × 2@ parameter is introduced as +-- @((t1 , t2) , t3)@ rather than a single opaque variable. Any other domain keeps +-- its single binder. +-- +-- Leaves are named by what they range over: a cube-product component is a point, +-- named @tN@; a Σ component is a term, named @xN@. The names are display-only (the +-- body is a hole that does not mention them) and carry a shared running index, so +-- every leaf in the pattern is distinct. +destructuringBinder :: Binder -> TermT n -> Binder +destructuringBinder orig param = case orig of + BinderPair{} -> orig -- already a pattern: keep the user's names + _ -> case param of + CubeProductT{} -> fst (go (1 :: Int) param) + TypeSigmaT{} -> fst (go (1 :: Int) param) + _ -> orig -- not a product/Σ: leave the binder alone + where + -- a product/Σ becomes a pair; we recurse into a product's components (plain + -- types) but not under a Σ's binder (a scope). A leaf is named by its enclosing + -- constructor: @tN@ under a cube product, @xN@ under a Σ. + go n = \case + CubeProductT _ a b -> + let (l, n') = child "t" n a + (r, n'') = child "t" n' b + in (BinderPair l r, n'') + TypeSigmaT _ _ _md a _b -> + let (l, n') = child "x" n a + in (BinderPair l (BinderVar (Just (leaf "x" n'))), n' + 1) + _ -> (BinderVar (Just (leaf "t" n)), n + 1) -- unreached: go is called on products only + child pfx n = \case + c@CubeProductT{} -> go n c + c@TypeSigmaT{} -> go n c + _ -> (BinderVar (Just (leaf pfx n)), n + 1) + leaf pfx n = fromString (pfx <> show n :: String) + +-- | All ways to introduce a value /of/ a goal type by its head constructor, +-- leaving the constituents as holes: +-- +-- * a Π-type is introduced by a λ-abstraction over a hole body (@\\ x -> ?@); the +-- binder is taken from the type, so a pattern domain (a @Δ²@ point @(t , s)@, +-- say) is introduced as @\\ (t , s) -> ?@; +-- * a Σ-type or a cube product by a pair of holes (@(? , ?)@); +-- * an identity type by @refl@, but only when its two endpoints already agree +-- (otherwise @refl@ would not typecheck); +-- * the unit type by @unit@; +-- * the tope universe by each tope constructor — @TOP@, @BOT@, @? ≡ ?@, @? ≤ ?@, +-- @? ∧ ?@, @? ∨ ?@ — so a shape (a hole of type @TOPE@) can be built up by +-- tapping. +-- +-- Unlike 'allEliminationsInto' this does not search: a type has at most one +-- introduction form (the tope universe is the one exception), read off its head +-- constructor. Outer restrictions are stripped first, so an extension type is +-- introduced by the form of its underlying type (its boundary is met by later +-- refinement of the holes, not by the choice of constructor). +-- +-- The λ binder of a Π-introduction is freshened against the names already visible +-- at the hole, so introducing over a type whose own definition reuses an in-scope +-- name (@hom@, whose internal binder is @t@) yields @\\ t₁ -> ?@ rather than a @t@ +-- that shadows the existing one. +allIntroductionsOf + :: Distinct n => TermT n -> [VarIdent] -> TypeCheck n [TermT n] +allIntroductionsOf target inScopeNames = do + target' <- stripTypeRestrictions <$> whnfT target + scope <- asks ctxScope + case target' of + TypeFunT _ty orig _md param _mtope ret -> do + let binder = freshenBinderLeaves inScopeNames (destructuringBinder orig param) + pure $ Foil.withFresh scope $ \b -> + let retAt = openWith (Foil.extendScope b scope) (Foil.nameOf b) ret + in [ lambdaT target' binder Nothing (ScopedAST b (mkHole retAt)) ] + TypeSigmaT _ty _orig _md a b -> do + let h = mkHole a + bAt <- instantiate b h + pure [ pairT target' h (mkHole bAt) ] + CubeProductT _ty a b -> + pure [ pairT target' (mkHole a) (mkHole b) ] + TypeIdT _ty a _tA b -> do + agree <- endpointsAgree a b + pure [ reflT target' Nothing | agree ] + TypeUnitT{} -> pure [ unitT ] + -- the tope universe: every tope constructor builds a tope, so all are + -- introductions of a shape goal. Point arguments (of ≡, ≤) and tope arguments + -- (of ∧, ∨) are left as holes. + UniverseTopeT{} -> + let point = mkHole (mkHole cubeT) -- a point of an as-yet-unknown cube + tope = mkHole target' -- a tope (its type is the tope universe) + in pure [ topeTopT, topeBottomT + , topeEQT point point, topeLEQT point point + , topeAndT tope tope, topeOrT tope tope ] + _ -> pure [] + +-- | Whether the two endpoints of an identity type are definitionally equal, so that +-- @refl@ inhabits it. Like 'fitsInto', any holes or constraints recorded while +-- probing are discarded, leaving a pure yes\/no query. +endpointsAgree :: Distinct n => TermT n -> TermT n -> TypeCheck n Bool +endpointsAgree a b = + censor (const []) + ((unify Nothing a b >> pure True) `catchError` \_ -> pure False) + +-- | Ex falso: in a contradictory tope context @recBOT@ inhabits any type, so it is a +-- candidate for every goal there (and only there — elsewhere it would not +-- typecheck). Independent of the goal and of the local hypotheses. +recBottomCandidates :: Distinct n => TypeCheck n [TermT n] +recBottomCandidates = do + vacuous <- contextEntailsBottom + pure [ recBottomT | vacuous ] + +-- | Whether the local tope context is covered by the union of the given topes — the +-- coverage obligation of @recOR@, as a yes\/no query rather than a check that +-- issues an error. +coverageHolds :: Distinct n => [TermT n] -> TypeCheck n Bool +coverageHolds topes = do + topesNF <- mapM nfTope topes + entailContextM (foldr topeOrT topeBottomT topesNF) + +-- | Tope case-split moves: ways to build a value of the goal by @recOR@, splitting +-- the proof over a cover of the local tope context. Three sources, offered together +-- (the UI ranks and filters): +-- +-- * each disjunction @ψ ∨ φ@ already in the context becomes @recOR(ψ ↦ ?, φ ↦ ?)@ +-- — its cover is immediate; +-- * when the goal is an extension type, its restriction faces are a cover +-- candidate, offered only when they actually cover the context (so the move +-- typechecks); +-- * a generic two-way split @recOR(? ↦ ?, ? ↦ ?)@ with the guards left as holes, +-- for an unusual split the player fills in by hand. +-- +-- All three are offered only where a split makes sense — a cube variable is in +-- scope, the context has a non-trivial tope, or the goal is a restricted type — so +-- an ordinary (tope-free) goal is left alone. +recOrCandidates :: Distinct n => TermT n -> TypeCheck n [TermT n] +recOrCandidates goal = do + goalW <- whnfT goal + topes <- asks (filter (not . eqT topeTopT) . availableTopes) + locals <- asks localHypotheses + hasCube <- or <$> mapM (fmap isCubeType . whnfT . varType . snd) locals + let stripped = stripTypeRestrictions goalW + mkRecOr gs = recOrT stripped [ (g, mkHole stripped) | g <- gs ] + fromContext = [ mkRecOr [l, r] | TopeOrT _ l r <- topes ] + faces = case goalW of + TypeRestrictedT _ _ rs -> map fst rs + _ -> [] + isRestricted = case goalW of TypeRestrictedT{} -> True; _ -> False + inShape = hasCube || not (null topes) || isRestricted + generic = [ recOrT stripped [ (mkHole topeT, mkHole stripped) + , (mkHole topeT, mkHole stripped) ] + | inShape ] + fromFaces <- if length faces >= 2 + then do covered <- coverageHolds faces + pure [ mkRecOr faces | covered ] + else pure [] + pure (fromContext <> fromFaces <> generic) + +-- | The local hypotheses: everything in scope that is not a top-level entry. +localHypotheses :: Context n -> [(Foil.Name n, VarInfo n)] +localHypotheses = filter (not . varIsTopLevel . snd) . varsInScope + +-- | The allow-listed top-level lemmas a hole's candidate list may draw on. +lemmaHypotheses :: Context n -> [(Foil.Name n, VarInfo n)] +lemmaHypotheses ctx = + [ entry + | entry@(_, info) <- varsInScope ctx + , varIsTopLevel info + , Just name <- [binderName (varOrig info)] + , name `elem` ctxHintLemmas ctx + ] + +-- | Record the goal and local context at a hole (lenient mode only). +recordHole :: Distinct n => Maybe VarIdent -> TermT n -> TypeCheck n () +recordHole mname goalTy = recordHoleShape mname goalTy Nothing + +-- | Record a hole. When the hole is the argument of a shape-restricted function its +-- goal is a /shape/: the cube @goalTy@ together with a membership tope, which is a +-- scope over the shape's bound variable. It is rendered under that binder, so the +-- goal reads @(binder : goalTy | tope)@. +recordHoleShape + :: Distinct n + => Maybe VarIdent + -> TermT n + -> Maybe (Binder, ScopedTermT n) + -> TypeCheck n () +recordHoleShape mname goalTy mshape = do + goal' <- whnfT goalTy + locals <- asks localHypotheses + -- named top-level lemmas the caller allow-listed for hints. They feed the + -- candidate-elimination loop only — not the local context shown to the user, + -- since they are global definitions, not local hypotheses. + lemmaVars <- asks lemmaHypotheses + cubeFlags <- mapM (fmap isCubeType . whnfT . varType . snd) locals + topes <- asks (filter (not . eqT topeTopT) . availableTopes) + loc <- asks ctxLocation + naming <- asks namingOfContext + + -- for each local hypothesis (and allow-listed lemma), the elimination spines that + -- land in the goal (arguments left as holes). Probing must not leak holes into the + -- recorded output, hence the 'censor'. + candidates <- censor (const []) $ do + elims <- concat <$> + mapM (\(v, _) -> allEliminationsInto goalTy (Var v)) (locals ++ lemmaVars) + -- context-driven moves (independent of the goal's head and the hypotheses): ex + -- falso in a contradictory context, and tope case-splits. recOR and recBOT are + -- term-level eliminators, so they are offered only for a term goal — not when + -- the hole is a cube point or a tope, where they cannot appear. + let termLayer = not (isCubeOrTopeType goal') + recbot <- if termLayer then recBottomCandidates else pure [] + recor <- if termLayer then recOrCandidates goalTy else pure [] + pure (elims <> recbot <> recor) + + let render t = renderTerm naming (untyped t) + -- a pattern binder is shown as its pattern, e.g. (t , s); others by name + entryName v = case displayOf naming v of + (_, binder) | binderIsCompound binder -> binderDisplayName binder + (x, _) -> x + entries = [ HoleEntry (entryName v) (render (varType info)) | (v, info) <- locals ] + flagged = zip cubeFlags entries + -- names already visible at the hole, which an introduced binder must not + -- shadow: each local hypothesis by its display name, or the leaves of a + -- pattern hypothesis. + inScopeNames = + [ nm + | (v, _) <- locals + , nm <- case displayOf naming v of + (_, binder) | binderIsCompound binder -> binderLeaves binder + (x, _) -> [x] + ] + + -- The goal shape, rendered under the shape's own binder. The name is read back + -- from the naming rather than assumed: if the declared name is taken (the goal + -- @(t : 2 × 2 | Δ¹×Δ¹ t)@ under an enclosing @t@), the binder is refreshed, and + -- the tope must be shown under the /same/ name it is. + goalShape <- forM mshape $ \(orig, tope) -> + withBinder (BinderVar (binderName orig <|> Just "t")) Id goal' $ \binder -> do + topeAt <- openScoped binder tope + naming' <- asks namingOfContext + let (shapeBinder, _) = displayOf naming' (Foil.nameOf binder) + pure (shapeBinder, renderTerm naming' (untyped topeAt)) + + -- the introduction forms for the goal itself (constituents left as holes); the Π + -- binder is freshened against the names in scope so that it does not shadow. + introductions <- censor (const []) (allIntroductionsOf goalTy inScopeNames) + -- the goal cell: an SVG of the shape the hole must inhabit (an arrow, triangle or + -- square), drawn from an abstract inhabitant with the proof term hidden. 'Nothing' + -- when the goal is not a renderable shape. + diagram <- censor (const []) (renderGoalCellSVG goal') + + recordHoleInfo HoleInfo + { holeName = mname + , holeGoal = render goal' + , holeGoalShape = goalShape + , holeTermVars = [ e | (False, e) <- flagged ] + , holeCubeVars = [ e | (True, e) <- flagged ] + , holeTopes = map render topes + , holeCandidates = map render candidates + , holeIntroductions = map render introductions + , holeDiagram = diagram + , holeLocation = loc + } + +-- | Check a hole that appears as the argument of a shape-restricted function, whose +-- domain is the cube @cube@ restricted by @tope@ (a scope over the domain's bound +-- variable). Mirrors the hole case of 'typecheck', but records the shape as the +-- hole's goal so the diagnostic shows @(binder : cube | tope)@. +checkHoleAgainstShape + :: Distinct n + => Maybe VarIdent -> Binder -> TermT n -> ScopedTermT n + -> TypeCheck n (TermT n) +checkHoleAgainstShape mname orig cube tope = do + reject <- asks ctxHolesAreErrors + if reject + then issueTypeError (TypeErrorUnsolvedHole mname cube) + else do + recordHoleShape mname cube (Just (orig, tope)) + pure (holeT cube mname) + + +-- * Checking + +-- | Check a @recOR@ against a known expected type: each branch is checked against +-- it under its own guard, the branches must agree on their overlaps, and together +-- they must cover the context. +checkRecOrAgainst + :: Distinct n => TermT n -> [(Term n, Term n)] -> TypeCheck n (TermT n) +checkRecOrAgainst expected rs = do + rs' <- forM rs $ \(tope, rterm) -> do + tope' <- typecheck tope topeT + checkTopeAgainstContext "recOR branch guard" tope' + localTope tope' $ do + expected' <- pruneVacuousFaces expected + rterm' <- typecheck rterm expected' + return (tope', rterm') + sequence_ [ checkCoherence l r | l:rs'' <- tails rs', r <- rs'' ] + contextEntailsUnion (map fst rs') + return (recOrT expected rs') + +-- | Drop the restriction faces of an extension type that are vacuous in the current +-- tope context (their overlap with the context is the empty tope ⊥). A face +-- mentioning an unfilled hole cannot be decided, so it is kept. Non-extension types +-- are returned unchanged. Used when descending into a recOR branch, where the +-- sibling branches' faces are disjoint from the branch guard. +pruneVacuousFaces :: Distinct n => TermT n -> TypeCheck n (TermT n) +pruneVacuousFaces (TypeRestrictedT _info ty rs) = do + contextTopes <- asks ctxTopesNF + kept <- fmap concat $ forM rs $ \face@(tope, _) -> do + vacuous <- if containsHole tope + then return False + else (plainTope tope : contextTopes) `entailM` topeBottomT + return [ face | not vacuous ] + return $ case kept of + [] -> ty + _ -> typeRestrictedT ty kept +pruneVacuousFaces ty = return ty + +typecheck :: Distinct n => Term n -> TermT n -> TypeCheck n (TermT n) +typecheck term ty = performing (ActionTypeCheck term ty) $ case term of + -- An identifier that was not in scope: elaboration marked it, and this is where + -- it is reported, under the binders and topes it was written beneath. + Hole (Just name) | Just x <- unmarkUnresolved name -> + issueTypeError (TypeErrorUndefined x) + + -- A hole is checked against a known type (this is checking position): in strict + -- mode it is reported as an unsolved hole; in lenient mode its goal and context + -- are recorded and it is treated as inhabiting the expected type. + Hole mname -> do + reject <- asks ctxHolesAreErrors + if reject + then issueTypeError (TypeErrorUnsolvedHole mname ty) + else do + recordHole mname ty + return (holeT ty mname) + + _ -> whnfT ty >>= \case + + RecBottomT{} -> do + -- Even under an absurd tope context (where the expected type collapses to + -- recBOT), the term must still be well-formed in its own right, so that + -- ill-typed bodies are not silently admitted under a false hypothesis. We + -- synthesise its type, discard the result, and keep the recBOT elaboration. + _ <- infer term + return recBottomT + + tr@(TypeRestrictedT _ty ty' rs) -> case term of + -- A recOR against a restricted type: push the restriction into each branch + -- rather than stripping it first, so that a branch hole reports the boundary + -- faces it must satisfy under its guard tope, and not the bare underlying + -- type. Concrete branches still meet the faces, which are checked on each + -- branch's overlap with them (see the general case below). + RecOr branches -> checkRecOrAgainst tr branches + _ -> do + term' <- typecheck term ty' + -- NOTE: restriction faces need not be contained in the local tope context. + -- Each face is checked only on its overlap with the context, so an + -- overhanging face is harmless (we only hint); a face disjoint from the + -- context is vacuous, however, and is an error. + forM_ rs $ \(tope, rterm) -> do + checkTopeAgainstContext "restriction face" tope + localTope tope $ + unifyTerms rterm term' + return term' -- FIXME: correct? + + ty' -> case term of + Lambda orig mparam body -> + case ty' of + TypeFunT _ty _orig' md' param' mtope' ret -> do + -- The λ's own domain annotation, if it wrote one, must agree with the + -- domain of the type it is checked against. + case mparam of + Nothing -> return () + + Just (LambdaParam md param Nothing) -> do + when (md /= md') $ + issueTypeError (TypeErrorModalityMismatch md' md term) + paramType <- enterModality md $ infer param + -- an argument can be a shape, which is a function into TOPE; the + -- domain is then its cube, and its tope is the λ's shape tope. + mcube <- typeOf paramType >>= \case + TypeFunT _ty _orig _md cube _mtope (ScopedAST _ UniverseTopeT{}) -> do + mapM_ checkNameShadowing (binderLeaves orig) + pure (Just cube) + _kind -> pure Nothing + unifyTerms param' (fromMaybe paramType mcube) + mapM_ checkNameShadowing (binderLeaves orig) + case mcube of + Nothing -> return () + Just _ -> + withBinder orig md param' $ \binder -> do + -- eta expand the shape into a tope over the bound variable + let etaTope = appT topeT (Foil.sink paramType) (Var (Foil.nameOf binder)) + expected <- maybe (pure topeTopT) (openScoped binder) mtope' + unifyTerms expected etaTope + + Just (LambdaParam md param (Just tope)) -> do + when (md /= md') $ + issueTypeError (TypeErrorModalityMismatch md' md term) + param'' <- enterModality md $ typecheck param =<< typeOf param' + unifyTerms param' param'' + mapM_ checkNameShadowing (binderLeaves orig) + checkUnder orig md param' tope $ \binder topeTerm -> do + tope'' <- typecheck topeTerm topeT + expected <- maybe (pure topeTopT) (openScoped binder) mtope' + unifyTerms expected tope'' + + mapM_ checkNameShadowing (binderLeaves orig) + body' <- elaborateUnder orig md' param' Nothing body $ \binder bodyTerm -> do + mtopeIn <- traverse (openScoped binder) mtope' + maybe id localTope mtopeIn $ do + retIn <- openScoped binder ret + typecheck bodyTerm retIn + return (lambdaT ty' orig (Just (LambdaParam md' param' mtope')) body') + + _ -> issueTypeError $ TypeErrorUnexpectedLambda term ty + + Let orig annot val body -> do + val' <- performing (ActionCheckLetValue (binderName orig)) $ case annot of + Nothing -> infer val + Just bindType -> do + bindType' <- typecheck bindType universeT + typecheck val bindType' + bindTy <- typeOf val' + body' <- elaborateUnder orig Id bindTy (Just val') body $ \_binder bodyTerm -> + typecheck bodyTerm (Foil.sink ty') + return (letT ty' orig (Just bindTy) val' body') + + LetMod orig app inn annot val body -> do + val' <- performing (ActionCheckLetValue (binderName orig)) $ case annot of + Nothing -> enterModality app $ infer val + Just bindType -> do + bindType' <- infer bindType + bindUniv <- typeOf bindType' + enterModality app $ typecheck val (typeModalT bindUniv inn bindType') + bindTy <- typeOf val' >>= \case + o@(TypeModalT _ty md t) -> + if md == inn + then return t + else issueTypeError $ TypeErrorNotModal (untyped o) inn val' + o -> issueTypeError $ TypeErrorNotModal (untyped o) inn val' + bindVal <- whnfT val' >>= \case + ModAppT _ty _m t -> pure (Just t) + o | isRA inn -> pure (Just (modExtractT bindTy app inn o)) + _ -> pure Nothing + body' <- elaborateUnder orig (comp app inn) bindTy bindVal body $ \_binder bodyTerm -> + typecheck bodyTerm (Foil.sink ty') + return (letModT ty' orig app inn (Just bindTy) val' body') + + Pair l r -> + case ty' of + CubeProductT _ty a b -> do + l' <- typecheck l a + r' <- typecheck r b + return (pairT ty' l' r') + TypeSigmaT _ty _orig md a b -> do + l' <- enterModality md $ typecheck l a + bAt <- instantiate b l' + r' <- typecheck r bAt + return (pairT ty' l' r') + _ -> issueTypeError $ TypeErrorUnexpectedPair term ty + + Refl mx -> + case ty' of + TypeIdT _ty y _tA z -> do + tA <- typeOf y + forM_ mx $ \(x, mxty) -> do + forM_ mxty $ \xty -> do + xty' <- typecheck xty universeT + unifyTerms tA xty' + x' <- typecheck x tA + unifyTerms x' y >> unifyTerms y x' + unifyTerms x' z >> unifyTerms z x' + when (isNothing mx) $ + unifyTerms y z >> unifyTerms z y + return (reflT ty' (Just (y, Just tA))) + _ -> issueTypeError $ TypeErrorUnexpectedRefl term ty + + ModExtract{} -> panicImpossible "extract is an internal term and cannot be typechecked" + + ModApp md body -> case ty' of + TypeModalT _ty md' tpe -> do + when (md /= md') $ issueTypeError $ + TypeErrorModalityMismatch md' md term + body' <- enterModality md $ typecheck body tpe + return $ modAppT ty' md body' + _ -> issueTypeError $ TypeErrorNotModal term md ty' + + -- In checking position the common type is already known, so we push it into + -- every branch instead of inferring each one and unifying. This is what lets a + -- bare hole branch (recOR(φ ↦ ?, …)) be checked against the expected type and + -- recorded, rather than hitting TypeErrorCannotInferHole via the inference + -- rule. A recOR is a term-level eliminator, not a tope; rejecting it when it is + -- checked against the tope universe keeps it out of the tope layer, where it + -- would otherwise hit a panic. + RecOr rs -> case ty' of + UniverseTopeT{} -> issueTypeError $ + TypeErrorOther "a recOR cannot be used as a tope" + _ -> checkRecOrAgainst ty' rs + + -- A neutral term is inferred, then its type unified with the expected one. In + -- lenient (hole-checking) mode a term that still carries an unfilled hole is a + -- work in progress, so a failure of that final unification is tolerated: the + -- holes recorded while inferring the term stand, and we accept the term rather + -- than rejecting the whole sketch. The mismatch is typically incidental to the + -- missing pieces — an extension-type boundary face that only fails to line up + -- because an argument hole sits in the wrong place (@f t@ vs @x@), where + -- neither side is itself a hole, so the per-term deferral in unification cannot + -- see it. Strict mode (the default, and CI) still rejects the mismatch. + _ -> do + term' <- infer term + inferredType <- typeOf term' + lenient <- not <$> asks ctxHolesAreErrors + if lenient && containsHole term' + then unifyTypes term' ty' inferredType `catchError` \_ -> return () + else unifyTypes term' ty' inferredType + return term' + +-- * Inference + +inferAs :: Distinct n => TermT n -> Term n -> TypeCheck n (TermT n) +inferAs expectedKind term = do + term' <- infer term + ty <- typeOf term' + kind <- typeOf ty + unifyTypes ty expectedKind kind + return term' + +infer :: Distinct n => Term n -> TypeCheck n (TermT n) +infer tt = performing (ActionInfer tt) $ case tt of + Hole (Just name) | Just x <- unmarkUnresolved name -> + issueTypeError (TypeErrorUndefined x) + Hole _mname -> issueTypeError (TypeErrorCannotInferHole tt) + Var x -> do + topLevel <- isTopLevelVar x + unless topLevel $ do + varMod <- modalityOfVar x + locks <- locksOfVar x + unless (coe varMod locks) $ + issueTypeError $ TypeErrorUnaccessibleVar x varMod locks + pure (Var x) + + Universe -> pure universeT + UniverseCube -> pure cubeT + UniverseTope -> pure topeT + + CubeUnit -> pure cubeUnitT + CubeUnitStar -> pure cubeUnitStarT + + Cube2 -> pure cube2T + Cube2_0 -> pure cube2_0T + Cube2_1 -> pure cube2_1T + + CubeI -> pure cubeIT + CubeI_0 -> pure cubeI_0T + CubeI_1 -> pure cubeI_1T + CubeProduct l r -> do + l' <- typecheck l cubeT + r' <- typecheck r cubeT + return (cubeProductT l' r') + + CubeFlip t -> do + t' <- infer t + typeOf t' >>= \case + CubeIT{} -> pure $ cubeFlipT cubeIT t' + Cube2T{} -> pure $ cubeFlipT cube2T t' + ty -> do + tyStr <- ppInContext ty + issueTypeError $ TypeErrorOther $ + "flip expects an interval cube (2 or 𝕀); got " <> tyStr + CubeUnflip t -> do + t' <- infer t + typeOf t' >>= \case + TypeModalT _ Op CubeIT{} -> pure $ cubeUnflipT cubeIT t' + TypeModalT _ Op Cube2T{} -> pure $ cubeUnflipT cube2T t' + ty -> do + tyStr <- ppInContext ty + issueTypeError $ TypeErrorOther $ + "unflip expects an interval cube (2 or 𝕀) under _op; got " <> tyStr + + Pair l r -> do + l' <- infer l + r' <- infer r + lt <- typeOf l' + rt <- typeOf r' + typeOf lt >>= \case + -- Γ ⊢ l ⇒ (I : CUBE) + -- Γ ⊢ r ⇒ (J : CUBE) + -- ——————————————————————————— + -- Γ ⊢ (l, r) ⇒ (I × J : CUBE) + UniverseCubeT{} -> return (pairT (cubeProductT lt rt) l' r') + -- Γ ⊢ l ⇒ (A : U) + -- Γ ⊢ r ⇒ (B : U) + -- ——————————————————————————— + -- Γ ⊢ (l, r) ⇒ (A × B : U) where A × B = Σ (_ : A), B + _ -> do + -- NOTE: infer as a non-dependent pair! + rtScope <- constScope rt + return (pairT (typeSigmaT (BinderVar Nothing) Id lt rtScope) l' r') + + First t -> do + t' <- infer t + fmap stripTypeRestrictions (typeOf t') >>= \case + RecBottomT{} -> pure recBottomT -- FIXME: is this ok? + TypeSigmaT _ty _orig _md lt _rt -> + return (firstT lt t') + CubeProductT _ty l _r -> + return (firstT l t') + ty -> issueTypeError $ TypeErrorNotPair t' ty + + Second t -> do + t' <- infer t + fmap stripTypeRestrictions (typeOf t') >>= \case + RecBottomT{} -> pure recBottomT -- FIXME: is this ok? + TypeSigmaT _ty _orig _md lt rt -> do + rtAt <- instantiate rt (firstT lt t') + return (secondT rtAt t') + CubeProductT _ty _l r -> + return (secondT r t') + ty -> issueTypeError $ TypeErrorNotPair t' ty + + TypeUnit -> pure typeUnitT + Unit -> pure unitT + + TopeTop -> pure topeTopT + TopeBottom -> pure topeBottomT + + TopeEQ l r -> do + l' <- inferAs cubeT l + lt <- typeOf l' + r' <- typecheck r lt + return (topeEQT l' r') + + TopeLEQ l r -> do + l' <- inferAs cubeT l + r' <- inferAs cubeT r + lTy <- typeOf l' + rTy <- typeOf r' + case (lTy, rTy) of + (Cube2T{}, Cube2T{}) -> return (topeLEQT l' r') + (CubeIT{}, CubeIT{}) -> return (topeLEQT l' r') + (CubeIT{}, Cube2T{}) -> do + r'' <- typecheck r cubeIT + return (topeLEQT l' r'') + (Cube2T{}, CubeIT{}) -> do + l'' <- typecheck l cubeIT + return (topeLEQT l'' r') + _ -> do + lStr <- ppInContext lTy + rStr <- ppInContext rTy + issueTypeError $ TypeErrorOther $ + "the (t ≤ s) tope expects points in interval cubes (2 or 𝕀); got " + <> lStr <> " and " <> rStr + + TopeAnd l r -> do + l' <- typecheck l topeT + r' <- typecheck r topeT + return (topeAndT l' r') + + TopeOr l r -> do + l' <- typecheck l topeT + r' <- typecheck r topeT + return (topeOrT l' r') + + TopeInv t -> do + t' <- typecheck t topeT + return (topeInvT t') + + TopeUninv t -> do + t' <- typecheck t (typeModalT universeT Op topeT) + return (topeUninvT t') + + RecBottom -> do + contextEntails topeBottomT + return recBottomT + + RecOr rs -> do + ttts <- forM rs $ \(tope, term) -> do + tope' <- typecheck tope topeT + -- NOTE: branch guards need not be contained in the context. recOR requires + -- only coverage (context |- OR(guards)); a guard may overhang the context (when + -- splitting with a named shape, say). checkTopeAgainstContext warns on overhang + -- and errors only if the guard is disjoint from the context (a vacuous branch). + checkTopeAgainstContext "recOR branch guard" tope' + localTope tope' $ do + term' <- inferAs universeT term + ty <- typeOf term' + return (tope', (term', ty)) + let rs' = map (fmap fst) ttts + ts = map (fmap snd) ttts + sequence_ [ checkCoherence l r | l:rs'' <- tails rs', r <- rs'' ] + contextEntailsUnion (map fst ttts) + return (recOrT (recOrT universeT ts) rs') + + TypeFun orig md a Nothing b -> do + a' <- enterModality md $ infer a + typeOf a' >>= \case + -- an argument can be a type + UniverseT{} -> + case a' of + -- except if it is the TOPE universe + UniverseTopeT{} -> + issueTypeError $ TypeErrorOther "tope params are illegal" + _ -> do + mapM_ checkNameShadowing (binderLeaves orig) + b' <- elaborateUnder orig md a' Nothing b $ \_binder bTerm -> + typecheck bTerm universeT + return (typeFunT orig md a' Nothing b') + -- an argument can be a cube + UniverseCubeT{} -> do + mapM_ checkNameShadowing (binderLeaves orig) + b' <- elaborateUnder orig md a' Nothing b $ \_binder bTerm -> + typecheck bTerm universeT + return (typeFunT orig md a' Nothing b') + -- an argument can be a shape + TypeFunT _ty _orig _md cube mtope (ScopedAST _ UniverseTopeT{}) -> do + mapM_ checkNameShadowing (binderLeaves orig) + (tope', b') <- checkUnder orig md cube b $ \binder bTerm -> do + -- eta expand a' into a tope over the bound variable + let etaTope = appT topeT (Foil.sink a') (Var (Foil.nameOf binder)) + tope' <- case mtope of + Nothing -> pure etaTope + Just tope'' -> do + inner <- openScoped binder tope'' + pure (topeAndT inner etaTope) + bTyped <- localTope etaTope $ typecheck bTerm universeT + pure (ScopedAST binder tope', ScopedAST binder bTyped) + return (typeFunT orig md cube (Just tope') b') + ty -> issueTypeError $ TypeErrorInvalidArgumentType a ty + + TypeFun orig md cube (Just tope) ret -> do + cube' <- enterModality md $ typecheck cube cubeT + mapM_ checkNameShadowing (binderLeaves orig) + (tope', ret') <- checkUnder orig md cube' tope $ \binder topeTerm -> do + topeTyped <- typecheck topeTerm topeT + retTerm <- openScoped binder ret + retTyped <- localTope topeTyped $ typecheck retTerm universeT + pure (ScopedAST binder topeTyped, ScopedAST binder retTyped) + return (typeFunT orig md cube' (Just tope') ret') + + TypeSigma orig md a b -> do + a' <- enterModality md $ typecheck a universeT + mapM_ checkNameShadowing (binderLeaves orig) + b' <- elaborateUnder orig md a' Nothing b $ \_binder bTerm -> + typecheck bTerm universeT + return (typeSigmaT orig md a' b') + + TypeId x (Just tA) y -> do + tA' <- typecheck tA universeT + x' <- typecheck x tA' + y' <- typecheck y tA' + return (typeIdT x' (Just tA') y') + + TypeId x Nothing y -> do + x' <- inferAs universeT x + tA <- typeOf x' + y' <- typecheck y tA + return (typeIdT x' (Just tA) y') + + App f x -> do + f' <- inferAs universeT f + fmap stripTypeRestrictions (typeOf f') >>= \case + TypeFunT _ty orig md a mtope b -> do + -- A hole argument to a shape-restricted function carries the shape as its + -- goal: record (binder : a | tope) rather than just the cube a. + x' <- enterModality md $ case (x, mtope) of + (Hole mname, Just tope) -> checkHoleAgainstShape mname orig a tope + _ -> typecheck x a + bAt <- instantiate b x' + let result = appT bAt f' x' + case b of + ScopedAST _ UniverseTopeT{} -> + case mtope of + Nothing -> return result + Just tope -> do + topeAt <- instantiate tope x' + return (topeAndT topeAt result) + _ -> do + -- FIXME: need to check? + forM_ mtope $ \tope -> do + topeAt <- instantiate tope x' + contextEntails topeAt + return result + ty -> issueTypeError $ TypeErrorNotFunction f' ty + + Lambda _orig Nothing _body -> + issueTypeError $ TypeErrorCannotInferBareLambda tt + + Lambda orig (Just (LambdaParam md ty Nothing)) body -> do + ty' <- enterModality md $ infer ty + mcube <- typeOf ty' >>= \case + -- an argument can be a type + UniverseT{} -> + case ty' of + -- except if it is the TOPE universe + UniverseTopeT{} -> + issueTypeError $ TypeErrorOther "tope params are illegal" + _ -> return Nothing + -- an argument can be a cube + UniverseCubeT{} -> return Nothing + -- an argument can be a shape + TypeFunT _ty _orig _md cube _mtope (ScopedAST _ UniverseTopeT{}) -> do + mapM_ checkNameShadowing (binderLeaves orig) + return (Just cube) + kind -> issueTypeError $ TypeErrorInvalidArgumentType ty kind + mapM_ checkNameShadowing (binderLeaves orig) + let param = fromMaybe ty' mcube + case mcube of + Nothing -> do + (body', ret) <- checkUnder orig md param body $ \binder bodyTerm -> do + body' <- infer bodyTerm + ret <- typeOf body' + pure (ScopedAST binder body', ScopedAST binder ret) + return (lambdaT (typeFunT orig md param Nothing ret) orig + (Just (LambdaParam md param Nothing)) body') + Just _ -> do + (tope', body', ret) <- checkUnder orig md param body $ \binder bodyTerm -> do + -- eta expand the shape into a tope over the bound variable + let etaTope = appT topeT (Foil.sink ty') (Var (Foil.nameOf binder)) + body' <- localTope etaTope $ infer bodyTerm + ret <- typeOf body' + pure (ScopedAST binder etaTope, ScopedAST binder body', ScopedAST binder ret) + return (lambdaT (typeFunT orig md param (Just tope') ret) orig + (Just (LambdaParam md param (Just tope'))) body') + + Lambda orig (Just (LambdaParam md cube (Just tope))) body -> do + cube' <- enterModality md $ typecheck cube cubeT + mapM_ checkNameShadowing (binderLeaves orig) + (tope', body', ret) <- checkUnder orig md cube' tope $ \binder topeTerm -> do + topeTyped <- infer topeTerm + bodyTerm <- openScoped binder body + body' <- localTope topeTyped $ infer bodyTerm + ret <- typeOf body' + pure (ScopedAST binder topeTyped, ScopedAST binder body', ScopedAST binder ret) + return (lambdaT (typeFunT orig md cube' (Just tope') ret) orig + (Just (LambdaParam md cube' (Just tope'))) body') + + Let orig annot val body -> do + val' <- performing (ActionCheckLetValue (binderName orig)) $ case annot of + Nothing -> infer val + Just ty -> do + bindTy <- typecheck ty universeT + typecheck val bindTy + bindTy <- typeOf val' + (body', ret) <- checkUnderWith orig Id bindTy (Just val') body $ \binder bodyTerm -> do + body' <- infer bodyTerm + ret <- typeOf body' + pure (ScopedAST binder body', ScopedAST binder ret) + retAt <- instantiate ret val' + return (letT retAt orig (Just bindTy) val' body') + + LetMod orig app inn annot val body -> do + val' <- performing (ActionCheckLetValue (binderName orig)) $ case annot of + Nothing -> enterModality app $ infer val + Just bindType -> do + bindType' <- infer bindType + bindUniv <- typeOf bindType' + enterModality app $ typecheck val (typeModalT bindUniv inn bindType') + bindTy <- typeOf val' >>= \case + o@(TypeModalT _ty md t) -> + if md == inn + then return t + else issueTypeError $ TypeErrorNotModal (untyped o) inn val' + o -> issueTypeError $ TypeErrorNotModal (untyped o) inn val' + bindVal <- whnfT val' >>= \case + ModAppT _ty _m t -> pure (Just t) + o | isRA inn -> pure (Just (modExtractT bindTy app inn o)) + _ -> pure Nothing + (body', ret) <- checkUnderWith orig (comp app inn) bindTy bindVal body $ \binder bodyTerm -> do + body' <- infer bodyTerm + ret <- typeOf body' + pure (ScopedAST binder body', ScopedAST binder ret) + retAt <- instantiate ret val' + return (letModT retAt orig app inn (Just bindTy) val' body') + + Refl Nothing -> issueTypeError $ TypeErrorCannotInferBareRefl tt + Refl (Just (x, Nothing)) -> do + x' <- inferAs universeT x + ty <- typeOf x' + return (reflT (typeIdT x' (Just ty) x') (Just (x', Just ty))) + Refl (Just (x, Just ty)) -> do + ty' <- typecheck ty universeT + x' <- typecheck x ty' + return (reflT (typeIdT x' (Just ty') x') (Just (x', Just ty'))) + + IdJ tA a tC d x p -> do + tA' <- typecheck tA universeT + a' <- typecheck a tA' + typeOf_C <- motiveType tA' a' + tC' <- typecheck tC typeOf_C + univScope <- constScope universeT + let typeOf_d = + appT universeT + (appT (typeFunT (BinderVar Nothing) Id (typeIdT a' (Just tA') a') Nothing univScope) + tC' a') + (reflT (typeIdT a' (Just tA') a') Nothing) + d' <- typecheck d typeOf_d + x' <- typecheck x tA' + p' <- typecheck p (typeIdT a' (Just tA') x') + let ret = + appT universeT + (appT (typeFunT (BinderVar Nothing) Id (typeIdT a' (Just tA') x') Nothing univScope) + tC' x') + p' + return (idJT ret tA' a' tC' d' x' p') + + TypeAsc term ty -> do + ty' <- inferAs universeT ty -- this works on types AND cubes + term' <- typecheck term ty' + return (typeAscT term' ty') + + TypeRestricted ty rs -> do + ty' <- typecheck ty universeT + rs' <- forM rs $ \(tope, term) -> do + tope' <- typecheck tope topeT + term' <- localTope tope' $ typecheck term ty' + return (tope', term') + sequence_ [ checkCoherence l r | l:rs'' <- tails rs', r <- rs'' ] + return (typeRestrictedT ty' rs') + + TypeModal md ty -> do + ty' <- enterModality md $ infer ty + universeTy <- typeOf ty' + _ <- case universeTy of + UniverseT{} -> pure universeTy + UniverseCubeT{} -> pure universeTy + UniverseTopeT{} -> pure universeTy + _ -> issueTypeError $ TypeErrorNotTypeInModal universeTy + return (typeModalT universeTy md ty') + + ModApp md term -> do + term' <- enterModality md $ infer term + ty <- typeOf term' + tyUniv <- typeOf ty + return $ modAppT (typeModalT tyUniv md ty) md term' + + ModExtract{} -> panicImpossible "extract is an internal term and cannot be inferred" + +-- | The type of the motive of a path induction: @(z : A) → (a =_A z) → U@. +motiveType :: Distinct n => TermT n -> TermT n -> TypeCheck n (TermT n) +motiveType tA a = do + scope <- asks ctxScope + pure $ Foil.withFresh scope $ \zBinder -> + let scopeZ = Foil.extendScope zBinder scope + idType = typeIdT (Foil.sink a) (Just (Foil.sink tA)) (Var (Foil.nameOf zBinder)) + in Foil.withFresh scopeZ $ \pBinder -> + typeFunT (BinderVar Nothing) Id tA Nothing + (ScopedAST zBinder + (typeFunT (BinderVar Nothing) Id idType Nothing + (ScopedAST pBinder universeT))) diff --git a/src/Rzk/TypeCheck/Monad.hs b/src/Rzk/TypeCheck/Monad.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/Monad.hs @@ -0,0 +1,177 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RecordWildCards #-} + +-- | The checker's monad. +-- +-- @TypeCheck n@ is the old @TypeCheck var@ with the scope index in place of the +-- variable type. The error channel, though, is /not/ indexed: an error carries +-- the context it was raised in (see "Rzk.TypeCheck.Error"). That is what makes +-- 'inContext' a one-liner — running a judgement in an inner scope is just running +-- it under a different reader, with nothing to re-index on the way out. The old +-- @closeScope@ had to wrap the error one binder deeper and re-emit the holes. +module Rzk.TypeCheck.Monad where + +import Control.Monad (unless) +import Control.Monad.Except (Except, MonadError (throwError), + runExcept) +import Control.Monad.Reader (ReaderT (..), ask, asks, local) +import Control.Monad.Trans (lift) +import Control.Monad.Trans.Writer.CPS (WriterT, runWriterT) +import Control.Monad.Writer.CPS (tell) +import Debug.Trace (trace) + +import Control.Monad.Foil (Distinct) +import qualified Control.Monad.Foil as Foil + +import Language.Rzk.Foil.Names (VarIdent) +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Display +import Rzk.TypeCheck.Error + +-- | A binding shown in a hole's local context: the display name and its type, +-- already rendered. +data HoleEntry = HoleEntry + { holeEntryName :: VarIdent + , holeEntryType :: Rendered + } deriving (Eq, Show) + +-- | The structured goal and context at a hole, recorded in lenient mode (see +-- 'allowHoles'). Everything is rendered to user-facing names at record time, so +-- 'HoleInfo' is independent of the scope it came from. Local hypotheses are split +-- into ordinary term variables and cube variables (the cube/tope layer is +-- specific to Rzk); the global environment is deliberately excluded — it belongs +-- in a searchable inventory, not the goal panel. +data HoleInfo = HoleInfo + { holeName :: Maybe VarIdent -- ^ the @?name@, if the hole was named + , holeGoal :: Rendered -- ^ expected type (the goal), kept symbolic + , holeGoalShape :: Maybe (VarIdent, Rendered) + -- ^ when the goal is a /shape/ (the hole is the argument of a + -- shape-restricted function), the shape's bound variable and its tope: the + -- goal then reads @(binder : holeGoal | tope)@. 'Nothing' for an ordinary + -- goal. (Extension-type goals need no special handling — they are already a + -- restricted type in 'holeGoal'.) + , holeTermVars :: [HoleEntry] -- ^ local hypotheses whose type is not a cube + , holeCubeVars :: [HoleEntry] -- ^ local cube variables (type is a cube) + , holeTopes :: [Rendered] -- ^ local tope assumptions (excluding ⊤) + , holeCandidates :: [Rendered] + -- ^ elimination spines over the local hypotheses whose type fits the goal, + -- with applied arguments left as holes. Already rendered, like the rest. + , holeIntroductions :: [Rendered] + -- ^ introduction forms for the goal type, built from its head constructor + -- with the constituents left as holes. Already rendered, like the rest. + , holeDiagram :: Maybe String + -- ^ an SVG of the goal cell, when the goal is a renderable shape (an arrow, + -- triangle, or square up to dimension 3). + , holeLocation :: Maybe LocationInfo + } deriving (Eq, Show) + +type TypeCheck n = + ReaderT (Context n) + (WriterT [HoleInfo] (Except TypeErrorInScopedContext)) + +-- | Run a judgement in the empty context, discarding the holes it records. +runTypeCheck :: TypeCheck Foil.VoidS a -> Either TypeErrorInScopedContext a +runTypeCheck tc = fst <$> runExcept (runWriterT (runReaderT tc emptyContext)) + +-- | Run a judgement in a given context, discarding the holes it records. +runTypeCheckIn :: Context n -> TypeCheck n a -> Either TypeErrorInScopedContext a +runTypeCheckIn ctx tc = fst <$> runExcept (runWriterT (runReaderT tc ctx)) + +-- | Run a judgement in another scope's context. +-- +-- The error channel and the hole channel are shared and carry no scope index, so +-- there is nothing to translate: this is 'runReaderT' with the inner scope's +-- context, lifted back. Holes recorded inside are told into the same writer, and +-- an error thrown inside already carries its own context. +inContext :: Context l -> TypeCheck l a -> TypeCheck n a +inContext ctx = lift . flip runReaderT ctx + +-- * Errors + +-- | Raise a type error, capturing the context it happened in. +issueTypeError :: Distinct n => TypeError n -> TypeCheck n a +issueTypeError err = do + ctx <- ask + throwError (TypeErrorInScopedContext ctx err) + +issueWarning :: String -> TypeCheck n () +issueWarning message = trace ("Warning: " <> message) (return ()) + +-- * Tracing + +trace' :: Verbosity -> Verbosity -> String -> a -> a +trace' Silent _ _ = id +trace' Normal Debug _ = id +trace' _ _ msg = trace msg + +traceTypeCheck :: Verbosity -> String -> TypeCheck n a -> TypeCheck n a +traceTypeCheck verbosity msg action = do + configuredVerbosity <- asks ctxVerbosity + trace' configuredVerbosity verbosity msg action + +localVerbosity :: Verbosity -> TypeCheck n a -> TypeCheck n a +localVerbosity verbosity = local $ \ctx -> ctx { ctxVerbosity = verbosity } + +localRenderBackend :: Maybe RenderBackend -> TypeCheck n a -> TypeCheck n a +localRenderBackend backend = local $ \ctx -> ctx { ctxRenderBackend = backend } + +localHideTerm :: Bool -> TypeCheck n a -> TypeCheck n a +localHideTerm hide = local $ \ctx -> ctx { ctxRenderHideTerm = hide } + +localWarnOverhang :: Bool -> TypeCheck n a -> TypeCheck n a +localWarnOverhang warn = local $ \ctx -> ctx { ctxWarnOverhang = warn } + +-- | Render the enclosed action with the proof term hidden. +hidingTerm :: TypeCheck n a -> TypeCheck n a +hidingTerm = localHideTerm True + +-- * Variance + +switchVariance :: TypeCheck n a -> TypeCheck n a +switchVariance = local $ \ctx -> ctx { ctxCovariance = switch (ctxCovariance ctx) } + where + switch Covariant = Contravariant + switch Contravariant = Covariant + switch Invariant = Invariant + +setVariance :: Covariance -> TypeCheck n a -> TypeCheck n a +setVariance variance = local $ \ctx -> ctx { ctxCovariance = variance } + +-- * The judgement stack + +-- | The depth of nested judgements at which type checking gives up. Well-typed +-- input stays far below it; the cap catches a non-terminating search. +-- FIXME: expose as a parameter (@--max-depth@ and @rzk.yaml@). +maxActionStackDepth :: Int +maxActionStackDepth = 1000 + +performing :: Distinct n => Action n -> TypeCheck n a -> TypeCheck n a +performing action tc = do + ctx@Context{..} <- ask + unless (ctxActionStackDepth < maxActionStackDepth) $ + issueTypeError $ TypeErrorOther "maximum depth reached" + let ctx' = ctx + { ctxActionStack = action : ctxActionStack + , ctxActionStackDepth = ctxActionStackDepth + 1 + } + -- The trace message is built only when it is actually printed: at normal + -- verbosity rendering the action's terms on every judgement would cost a + -- thunk per judgement. + if ctxVerbosity <= Debug + then trace (ppAction (namingOfContext ctx) ctxActionStackDepth action) $ + local (const ctx') tc + else local (const ctx') tc + +-- * Holes + +recordHoleInfo :: HoleInfo -> TypeCheck n () +recordHoleInfo info = lift (tell [info]) + +-- * Locations + +withLocation :: LocationInfo -> TypeCheck n a -> TypeCheck n a +withLocation loc = local $ \ctx -> ctx { ctxLocation = Just loc } diff --git a/src/Rzk/TypeCheck/NbE.hs b/src/Rzk/TypeCheck/NbE.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/NbE.hs @@ -0,0 +1,297 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Normalisation by evaluation, used as an all-or-nothing fast path for +-- conversion checking. +-- +-- 'nbeConvertible' evaluates both sides into a value domain with closures +-- (sharing by construction: a definition's value is evaluated once per +-- occurrence, not once per copy, and Haskell's laziness makes the evaluation +-- call-by-need) and compares the values structurally, with one-step η for +-- lambdas and pairs mirroring 'Rzk.TypeCheck.Eval.etaMatch'. It answers only +-- 'True' ("definitely convertible") or 'False' ("do not know") — never a +-- definite inequality — so a caller falls back to the ordinary unification on +-- 'False' and the fast path cannot change what typechecks, only how fast. +-- +-- Soundness is a subset argument: 'True' is answered only for terms that are +-- βδ-convertible up to α and the one-step η above, with every construct whose +-- /reduction/ consults the context — @recOR@ guard selection, holes, the +-- modal constructs — evaluating to an opaque 'VAbort' that poisons the +-- comparison into 'False'. Extension types and @recBOT@ are compared +-- structurally (see the note at their 'eval' case): a structurally identical +-- pair of restricted types is also accepted by the ordinary unification, +-- through reflexive coverage and the cross-face coherences already proved at +-- formation. Every 'True' is therefore also a success of the old unification. +-- +-- The evaluator is a pure function of the 'Context': 'valueOfVar' is a plain +-- reader-only lookup, and fresh variables for comparing closures are de +-- Bruijn levels ('NLevel'), so the foil scope machinery is never extended and +-- no quote function is needed. +-- +-- == Attribution +-- +-- None of the underlying techniques are ours. Semantic conversion checking — +-- evaluate both sides into a value domain with closures and compare the +-- values, applying functions to fresh generic values — is the algorithm of +-- Coquand, /An algorithm for type-checking dependent types/ (Science of +-- Computer Programming 26, 1996), the implementation-level core of +-- normalisation by evaluation (Berger and Schwichtenberg, LICS 1991). The +-- concrete implementation shape follows the style popularised by András +-- Kovács' <https://github.com/AndrasKovacs/smalltt smalltt> and +-- <https://github.com/AndrasKovacs/elaboration-zoo elaboration-zoo>: +-- environment machines with closures, de Bruijn levels for fresh variables, +-- and demand-driven definition unfolding (our 'unfoldNeu' — unfold at an +-- elimination or on a comparison mismatch, comparing neutral spines first — +-- is a simplified form of smalltt's glued evaluation). For the fragment this +-- module deliberately aborts on (tope-indexed reduction such as @recOR@), +-- the template is cubical: Sterling and Angiuli, /Normalization for Cubical +-- Type Theory/ (LICS 2021), and its implementation lineage in @cooltt@. +-- What is specific to rzk is only the packaging: the all-or-nothing +-- gating ('True' or do-not-know, never refute), and 'VAbort' poisoning of +-- the context-sensitive fragment so that the fast path stays sound by a +-- subset argument. +module Rzk.TypeCheck.NbE (nbeConvertible) where + +import Control.Monad.Reader (asks) +import Data.Bifoldable (bifoldMap) +import Data.Bifunctor (bimap) +import qualified Data.IntMap as IntMap +import Data.Monoid (All (..)) +import Data.ZipMatchK (zipMatch2) +import Unsafe.Coerce (unsafeCoerce) + +import Control.Monad.Foil (NameBinder) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil (AST (Node, Var), + ScopedAST (..)) +import Control.Monad.Free.Foil.Annotated (AnnSig (..)) + +import Language.Rzk.Foil.Syntax +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Monad + +-- * The value domain + +data Val n + = VLam (Closure n) + -- ^ A lambda: its body under the environment it was evaluated in. + | VNeutral (Neu n) + -- ^ A stuck elimination spine over a variable. + | VCon (TermSig (Closure n) (Val n)) + -- ^ Any other node, its term fields evaluated and its scoped fields + -- closed over the environment. Covers constructors (pairs, @refl@), + -- types (Π, Σ, identity, universes) and the cube/tope operators, which + -- are compared structurally only (reflexivity is entailment). + | VAbort AbortReason + -- ^ A construct outside the context-insensitive fragment. Poisons the + -- comparison: 'conv' answers 'False' the moment it meets one. The + -- reason records which construct, for diagnostics. + +-- | Why evaluation gave up: which context-sensitive construct was met. +data AbortReason + = AbortHole + | AbortRecOr + | AbortModal + | AbortStuckElim + -- ^ An elimination of a non-canonical, non-neutral value (an abort + -- propagating through an application, projection or @idJ@). + deriving (Eq, Ord, Show, Enum, Bounded) + +data Neu n + = NVar (Foil.Name n) + -- ^ An ambient variable (its definition, if any, is unfolded on demand + -- by 'unfoldNeu'). + | NLevel Int + -- ^ A fresh variable minted while comparing closures. + | NApp (Neu n) (Val n) + | NFirst (Neu n) + | NSecond (Neu n) + | NIdJ (Val n) (Val n) (Val n) (Val n) (Val n) (Neu n) + +-- | A scoped term closed over its environment. The environment maps the raw +-- ids of the binders passed on the way down to values; a missing id belongs +-- to the ambient scope @n@ (the same invariant 'peelLambdas' relies on for +-- its substitution). +-- +-- One binder, not @NameBinders i l@: every scope field of every 'TermSig' +-- constructor is a unary 'ScopedAST' (even a pair-pattern lambda binds one +-- variable operationally), so a multi-binder closure would have nothing to +-- be built from without peeling syntactic lambda chains in 'eval'. Peeling +-- (the eval/apply arity optimisation of Marlow and Peyton Jones' fast +-- curry) does not pay here the way spine-batching paid at the term level: +-- an intermediate 'VLam' costs one closure and one persistent +-- 'IntMap.insert', not a 'substituteT' traversal, and η-comparison and +-- partial application want one-argument-at-a-time semantics anyway. +data Closure n where + Closure :: Env n -> NameBinder i l -> TermT l -> Closure n + +-- | Lazy on purpose: forcing an entry would evaluate it, and evaluation is +-- call-by-need. +type Env n = IntMap.IntMap (Val n) + +-- * Evaluation + +eval :: forall i n. Context n -> Env n -> TermT i -> Val n +eval ctx env = \case + Var x -> case IntMap.lookup (Foil.nameId x) env of + Just v -> v + -- An env miss is an ambient name; kept neutral here, unfolded on demand. + Nothing -> VNeutral (NVar (unsafeCoerce x)) + + AppT _ty f x -> applyVal ctx (eval ctx env f) (eval ctx env x) + LambdaT _ty _orig _mparam (ScopedAST binder body) -> + VLam (Closure env binder body) + LetT _ty _orig _mparam val (ScopedAST binder body) -> + eval ctx (IntMap.insert (Foil.nameId (Foil.nameOf binder)) (eval ctx env val) env) body + FirstT _ty t -> projVal ctx NFirst fstOf (eval ctx env t) + SecondT _ty t -> projVal ctx NSecond sndOf (eval ctx env t) + TypeAscT _ty term _ty' -> eval ctx env term + IdJT _ty tA a tC d x p -> + let vd = eval ctx env d + in case forceVal ctx (eval ctx env p) of + VCon ReflF{} -> vd + VNeutral np -> VNeutral + (NIdJ (eval ctx env tA) (eval ctx env a) (eval ctx env tC) + vd (eval ctx env x) np) + VAbort r -> VAbort r + _ -> VAbort AbortStuckElim + + -- The context-sensitive fragment. A @recOR@ reduces by deciding its guards + -- against the tope context, and a hole defers by design, so both abort. The + -- modal constructs reduce under 'enterModality', which eval does not track. + -- + -- An extension type ('TypeRestrictedT') and @recBOT@ do /not/ abort: they + -- fall through to the generic constructor case below and are compared + -- structurally. For two restricted types with structurally identical + -- underlying types and face lists this is sound: the ordinary unification + -- proves the same pair by reflexive coverage (each face entails the + -- disjunction containing itself) and by re-checking the cross-face + -- coherences that were already proved when the type was formed (entailment + -- is monotone in the tope context). Two @recBOT@s unify unconditionally. + HoleT{} -> VAbort AbortHole + RecOrT{} -> VAbort AbortRecOr + TypeModalT{} -> VAbort AbortModal + ModAppT{} -> VAbort AbortModal + ModExtractT{} -> VAbort AbortModal + LetModT{} -> VAbort AbortModal + + -- everything else is a plain constructor: evaluate the fields + Node (AnnSig _info sig) -> + VCon (bimap (\(ScopedAST binder body) -> Closure env binder body) (eval ctx env) sig) + where + fstOf l _r = l + sndOf _l r = r + +-- | β, and δ at the head of an elimination, exactly where 'whnfT' unfolds. +applyVal :: Context n -> Val n -> Val n -> Val n +applyVal ctx f v = case f of + VLam closure -> applyClosure ctx closure v + VNeutral neu -> case unfoldNeu ctx neu of + Just f' -> applyVal ctx f' v + Nothing -> VNeutral (NApp neu v) + VAbort r -> VAbort r + _ -> VAbort AbortStuckElim + +applyClosure :: Context n -> Closure n -> Val n -> Val n +applyClosure ctx (Closure env binder body) v = + eval ctx (IntMap.insert (Foil.nameId (Foil.nameOf binder)) v env) body + +-- | Project from a pair value, or stay neutral. +projVal + :: Context n + -> (Neu n -> Neu n) -> (Val n -> Val n -> Val n) + -> Val n -> Val n +projVal ctx neu pick v = case forceVal ctx v of + VCon (PairF l r) -> pick l r + VNeutral n -> VNeutral (neu n) + VAbort r -> VAbort r + _ -> VAbort AbortStuckElim + +-- | Unfold a neutral's head definition once (replaying the spine), if it has one. +-- A top-level definition's value is cached (see 'cachedDefVal'); a local value +-- (rare at the head of a neutral) is evaluated in place. +unfoldNeu :: Context n -> Neu n -> Maybe (Val n) +unfoldNeu ctx = \case + NVar x -> eval ctx IntMap.empty <$> varValue (lookupVarInfo x ctx) + NLevel _ -> Nothing + NApp n v -> (\f -> applyVal ctx f v) <$> unfoldNeu ctx n + NFirst n -> projVal ctx NFirst (\l _ -> l) <$> unfoldNeu ctx n + NSecond n -> projVal ctx NSecond (\_ r -> r) <$> unfoldNeu ctx n + NIdJ tA a tC d x n -> + (\vp -> case forceVal ctx vp of + VCon ReflF{} -> d + VNeutral np -> VNeutral (NIdJ tA a tC d x np) + VAbort r -> VAbort r + _ -> VAbort AbortStuckElim) + <$> unfoldNeu ctx n + +-- | Unfold definitions at the head until the value is canonical or truly stuck. +forceVal :: Context n -> Val n -> Val n +forceVal ctx (VNeutral n) | Just v <- unfoldNeu ctx n = forceVal ctx v +forceVal _ v = v + +-- * Conversion + +-- | 'False' means "do not know", never a definite inequality. +conv :: Context n -> Int -> Val n -> Val n -> Bool +conv ctx lvl l r = case (forceVal ctx l, forceVal ctx r) of + (VAbort _, _) -> False + (_, VAbort _) -> False + + (VLam c1, VLam c2) -> + conv ctx (lvl + 1) (applyClosure ctx c1 (freshV lvl)) (applyClosure ctx c2 (freshV lvl)) + -- one-step η for lambdas, as in 'etaMatch' + (VLam c1, v2) -> + conv ctx (lvl + 1) (applyClosure ctx c1 (freshV lvl)) (applyVal ctx v2 (freshV lvl)) + (v1, VLam c2) -> + conv ctx (lvl + 1) (applyVal ctx v1 (freshV lvl)) (applyClosure ctx c2 (freshV lvl)) + + -- one-step η for pairs + (VCon (PairF a b), VNeutral n) -> + conv ctx lvl a (VNeutral (NFirst n)) && conv ctx lvl b (VNeutral (NSecond n)) + (VNeutral n, VCon (PairF a b)) -> + conv ctx lvl (VNeutral (NFirst n)) a && conv ctx lvl (VNeutral (NSecond n)) b + + (VCon s1, VCon s2) -> case zipMatch2 s1 s2 of + Nothing -> False + Just s -> getAll (bifoldMap + (All . uncurry (convClosure ctx lvl)) + (All . uncurry (conv ctx lvl)) + s) + + (VNeutral n1, VNeutral n2) -> convNeu ctx lvl n1 n2 + _ -> False + where + freshV = VNeutral . NLevel + +convClosure :: Context n -> Int -> Closure n -> Closure n -> Bool +convClosure ctx lvl c1 c2 = + conv ctx (lvl + 1) (applyClosure ctx c1 fresh) (applyClosure ctx c2 fresh) + where + fresh = VNeutral (NLevel lvl) + +convNeu :: Context n -> Int -> Neu n -> Neu n -> Bool +convNeu ctx lvl = go + where + go (NVar x) (NVar y) = Foil.nameId x == Foil.nameId y + go (NLevel i) (NLevel j) = i == j + go (NApp n v) (NApp n' v') = go n n' && conv ctx lvl v v' + go (NFirst n) (NFirst n') = go n n' + go (NSecond n) (NSecond n') = go n n' + go (NIdJ tA a tC d x n) (NIdJ tA' a' tC' d' x' n') = + go n n' + && conv ctx lvl tA tA' && conv ctx lvl a a' && conv ctx lvl tC tC' + && conv ctx lvl d d' && conv ctx lvl x x' + go _ _ = False + +-- * Entry point + +-- | Are the two terms definitely convertible? 'False' means "do not know" — +-- fall back to the ordinary unification. +nbeConvertible :: TermT n -> TermT n -> TypeCheck n Bool +nbeConvertible t1 t2 = asks $ \ctx -> + conv ctx 0 (eval ctx IntMap.empty t1) (eval ctx IntMap.empty t2) + diff --git a/src/Rzk/TypeCheck/Render.hs b/src/Rzk/TypeCheck/Render.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/Render.hs @@ -0,0 +1,429 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Drawing a term as an SVG diagram of a cube. +-- +-- The geometry lives in "Rzk.Render.Geometry"; what is here is the part that +-- knows about terms: which subshape of the cube a tope carves out, which term +-- inhabits each of them, and what to label it with. +module Rzk.TypeCheck.Render where + +import Control.Monad (forM) +import Control.Monad.Reader (asks) +import Data.List (intercalate, (\\)) +import Data.Maybe (catMaybes) + +import Control.Monad.Foil (Distinct) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil (AST (Var)) + +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), TModality (..), + binderName) +import Rzk.Render.Geometry +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Display +import Rzk.TypeCheck.Eval +import Rzk.TypeCheck.Monad + +-- * The subshapes of a cube + +cube2powerT :: Int -> TermT n +cube2powerT 1 = cube2T +cube2powerT dim = cubeProductT (cube2powerT (dim - 1)) cube2T + +splits :: [a] -> [([a], [a])] +splits [] = [([], [])] +splits (x:xs) = ([], x:xs) : [ (x : before, after) | (before, after) <- splits xs ] + +verticesFrom :: [TermT n] -> [(ShapeId, TermT n)] +verticesFrom ts = combine <$> mapM mk ts + where + mk t = [("0", topeEQT t cube2_0T), ("1", topeEQT t cube2_1T)] + combine xs = ([concat (map fst xs)], foldr1 topeAndT (map snd xs)) + +subTopes2 :: Int -> TermT n -> [(ShapeId, TermT n)] +-- 1-dim +subTopes2 1 t = + [ (words "0", topeEQT t cube2_0T) + , (words "1", topeEQT t cube2_1T) + , (words "0 1", topeTopT) ] +-- 2-dim +subTopes2 2 ts = + -- vertices + [ (words "00", topeEQT t cube2_0T `topeAndT` topeEQT s cube2_0T) + , (words "01", topeEQT t cube2_0T `topeAndT` topeEQT s cube2_1T) + , (words "10", topeEQT t cube2_1T `topeAndT` topeEQT s cube2_0T) + , (words "11", topeEQT t cube2_1T `topeAndT` topeEQT s cube2_1T) + -- edges and the diagonal + , (words "00 01", topeEQT t cube2_0T) + , (words "10 11", topeEQT t cube2_1T) + , (words "00 10", topeEQT s cube2_0T) + , (words "01 11", topeEQT s cube2_1T) + , (words "00 11", topeEQT s t) + -- triangles + , (words "00 01 11", topeLEQT t s) + , (words "00 10 11", topeLEQT s t) + ] + where + t = firstT cube2T ts + s = secondT cube2T ts +-- 3-dim +subTopes2 3 t = + -- vertices + [ (words "000", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_0T) + , (words "001", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_1T) + , (words "010", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_0T) + , (words "011", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_1T) + , (words "100", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_0T) + , (words "101", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_1T) + , (words "110", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_0T) + , (words "111", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_1T) + -- edges + , (words "000 001", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_0T) + , (words "010 011", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 cube2_1T) + , (words "000 010", topeEQT t1 cube2_0T `topeAndT` topeEQT t3 cube2_0T) + , (words "001 011", topeEQT t1 cube2_0T `topeAndT` topeEQT t3 cube2_1T) + , (words "100 101", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_0T) + , (words "110 111", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 cube2_1T) + , (words "100 110", topeEQT t1 cube2_1T `topeAndT` topeEQT t3 cube2_0T) + , (words "101 111", topeEQT t1 cube2_1T `topeAndT` topeEQT t3 cube2_1T) + , (words "000 100", topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_0T) + , (words "001 101", topeEQT t2 cube2_0T `topeAndT` topeEQT t3 cube2_1T) + , (words "010 110", topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_0T) + , (words "011 111", topeEQT t2 cube2_1T `topeAndT` topeEQT t3 cube2_1T) + -- face diagonals + , (words "000 011", topeEQT t1 cube2_0T `topeAndT` topeEQT t2 t3) + , (words "100 111", topeEQT t1 cube2_1T `topeAndT` topeEQT t2 t3) + , (words "000 101", topeEQT t2 cube2_0T `topeAndT` topeEQT t1 t3) + , (words "010 111", topeEQT t2 cube2_1T `topeAndT` topeEQT t1 t3) + , (words "000 110", topeEQT t3 cube2_0T `topeAndT` topeEQT t1 t2) + , (words "001 111", topeEQT t3 cube2_1T `topeAndT` topeEQT t1 t2) + -- the long diagonal + , (words "000 111", topeEQT t3 t2 `topeAndT` topeEQT t2 t1) + -- face triangles + , (words "000 001 011", topeEQT t1 cube2_0T `topeAndT` topeLEQT t2 t3) + , (words "000 010 011", topeEQT t1 cube2_0T `topeAndT` topeLEQT t3 t2) + , (words "100 101 111", topeEQT t1 cube2_1T `topeAndT` topeLEQT t2 t3) + , (words "100 110 111", topeEQT t1 cube2_1T `topeAndT` topeLEQT t3 t2) + , (words "000 001 101", topeEQT t2 cube2_0T `topeAndT` topeLEQT t1 t3) + , (words "000 100 101", topeEQT t2 cube2_0T `topeAndT` topeLEQT t3 t1) + , (words "010 011 111", topeEQT t2 cube2_1T `topeAndT` topeLEQT t1 t3) + , (words "010 110 111", topeEQT t2 cube2_1T `topeAndT` topeLEQT t3 t1) + , (words "000 010 110", topeEQT t3 cube2_0T `topeAndT` topeLEQT t1 t2) + , (words "000 100 110", topeEQT t3 cube2_0T `topeAndT` topeLEQT t2 t1) + , (words "001 011 111", topeEQT t3 cube2_1T `topeAndT` topeLEQT t1 t2) + , (words "001 101 111", topeEQT t3 cube2_1T `topeAndT` topeLEQT t2 t1) + -- diagonal triangles + , (words "000 001 111", topeEQT t1 t2 `topeAndT` topeLEQT t2 t3) + , (words "000 010 111", topeEQT t1 t3 `topeAndT` topeLEQT t1 t2) + , (words "000 100 111", topeEQT t2 t3 `topeAndT` topeLEQT t2 t1) + , (words "000 011 111", topeLEQT t1 t2 `topeAndT` topeEQT t2 t3) + , (words "000 101 111", topeLEQT t2 t1 `topeAndT` topeEQT t1 t3) + , (words "000 110 111", topeLEQT t3 t1 `topeAndT` topeEQT t1 t2) + -- tetrahedra + , (words "000 001 011 111", topeLEQT t1 t2 `topeAndT` topeLEQT t2 t3) + , (words "000 010 011 111", topeLEQT t1 t3 `topeAndT` topeLEQT t3 t2) + , (words "000 001 101 111", topeLEQT t2 t1 `topeAndT` topeLEQT t1 t3) + , (words "000 100 101 111", topeLEQT t2 t3 `topeAndT` topeLEQT t3 t1) + , (words "000 010 110 111", topeLEQT t3 t1 `topeAndT` topeLEQT t1 t2) + , (words "000 100 110 111", topeLEQT t3 t2 `topeAndT` topeLEQT t2 t1) + ] + where + t1 = firstT cube2T (firstT (cube2powerT 2) t) + t2 = secondT cube2T (firstT (cube2powerT 2) t) + t3 = secondT cube2T t +subTopes2 dim _ = error (show dim <> " dimensions are not supported") + +componentWiseEQT :: Int -> TermT n -> TermT n -> TermT n +componentWiseEQT 1 t s = topeEQT t s +componentWiseEQT 2 t s = topeAndT + (componentWiseEQT 1 (firstT cube2T t) (firstT cube2T s)) + (componentWiseEQT 1 (secondT cube2T t) (secondT cube2T s)) +componentWiseEQT 3 t s = topeAndT + (componentWiseEQT 2 (firstT (cube2powerT 2) t) (firstT (cube2powerT 2) s)) + (componentWiseEQT 1 (secondT cube2T t) (secondT cube2T s)) +componentWiseEQT dim _ _ = error ("cannot work with " <> show dim <> " dimensions") +-- * Rendering + +-- | Is the variable an anonymous one (written @_@)? Its cells are left +-- unlabelled. +isAnonymous :: Foil.Name n -> TypeCheck n Bool +isAnonymous x = asks ((== Just "_") . binderName . varOrig . lookupVarInfo x) + +-- | Render a term in the current context. +ppInContext :: TermT n -> TypeCheck n String +ppInContext t = do + naming <- asks namingOfContext + pure (ppTerm naming (untyped t)) + +renderObjectsFor + :: Distinct n + => String -> Int -> TermT n -> TermT n + -> TypeCheck n [(ShapeId, RenderObjectData)] +renderObjectsFor mainColor dim t term = fmap catMaybes $ + forM (subTopes2 dim t) $ \(shapeId, tope) -> + checkTopeEntails tope >>= \case + False -> return Nothing + True -> typeOf term >>= \case + UniverseTopeT{} -> localTope term $ checkTopeEntails tope >>= \case + False -> return Nothing + True -> return $ Just (shapeId, RenderObjectData + { renderObjectDataLabel = "" + , renderObjectDataFullLabel = "" + , renderObjectDataColor = "orange" -- FIXME: orange for topes? + }) + _ -> do + term' <- localTope tope $ whnfT term + let argIsOfT arg = + null (freeVarsOfTermT arg \\ freeVarsOfTermT t) + label <- case term' of + AppT _ (Var z) arg -> isAnonymous z >>= \case + True -> return "" + False + | argIsOfT arg -> ppInContext (Var z) + | otherwise -> ppInContext term' + _ -> ppInContext term' + color <- case term' of + Var{} -> return "purple" + AppT _ (Var x) arg -> isAnonymous x >>= \case + True -> return mainColor + False + | argIsOfT arg -> return "purple" + | otherwise -> return mainColor + _ -> return mainColor + hide <- asks ctxRenderHideTerm + return $ Just (shapeId, hideTermData hide mainColor RenderObjectData + { renderObjectDataLabel = label + , renderObjectDataFullLabel = label + , renderObjectDataColor = color + }) + +renderObjectsInSubShapeFor + :: Distinct n + => String -> Int -> [Foil.Name n] -> Foil.Name n + -> TermT n -> TermT n -> TermT n + -> TypeCheck n [(ShapeId, RenderObjectData)] +renderObjectsInSubShapeFor mainColor dim sub super retType f x = fmap catMaybes $ do + let reduceContext + = foldr topeOrT topeBottomT + . map (foldr topeAndT topeTopT) + . map (filter (\tope -> all (`notElem` freeVarsOfTermT tope) sub)) + . map (map tTope) + . map saturateTopes + . simplifyLHSwithDisjunctions + contextTopes <- asks (reduceContext . ctxTopesNF) + contextTopes' <- localTope (componentWiseEQT dim (Var super) x) $ + asks (reduceContext . ctxTopesNF) + forM (subTopes2 dim (Var super)) $ \(shapeId, tope) -> + checkEntails tope contextTopes >>= \case + False -> return Nothing + True -> do + term <- localTope tope (whnfT (appT retType f (Var super))) + let argIsSuper arg = null (freeVarsOfTermT arg \\ [super]) + label <- typeOf term >>= \case + UniverseTopeT{} -> return "" + _ -> case term of + AppT _ (Var z) arg -> isAnonymous z >>= \case + True -> return "" + False + | argIsSuper arg -> ppInContext (Var z) + | otherwise -> ppInContext term + _ -> ppInContext term + color <- checkEntails tope contextTopes' >>= \case + True -> case term of + Var{} -> return "purple" + AppT _ (Var z) arg -> isAnonymous z >>= \case + True -> return mainColor + False + | argIsSuper arg -> return "purple" + | otherwise -> return mainColor + _ -> return mainColor + False -> return "gray" + hide <- asks ctxRenderHideTerm + return $ Just (shapeId, hideTermData hide mainColor RenderObjectData + { renderObjectDataLabel = label + , renderObjectDataFullLabel = label + , renderObjectDataColor = color + }) + +renderForSubShapeSVG + :: Distinct n + => String -> Int -> [Foil.Name n] -> Foil.Name n + -> TermT n -> TermT n -> TermT n + -> TypeCheck n String +renderForSubShapeSVG mainColor dim sub super retType f x = do + objects <- renderObjectsInSubShapeFor mainColor dim sub super retType f x + pure (drawCube dim (map mk objects)) + where + mk (shapeId, renderData) = (intercalate "-" (map fill shapeId), renderData) + fill xs = xs <> replicate (3 - length xs) '1' + +renderForSVG + :: Distinct n => String -> Int -> TermT n -> TermT n -> TypeCheck n String +renderForSVG mainColor dim t term = do + objects <- renderObjectsFor mainColor dim t term + pure (drawCube dim (map mk objects)) + where + mk (shapeId, renderData) = (intercalate "-" (map fill shapeId), renderData) + fill xs = xs <> replicate (3 - length xs) '1' + +drawCube :: Int -> [(String, RenderObjectData)] -> String +drawCube dim objects = + renderCube defaultCamera rotation (`lookup` objects) + where + rotation :: Double + rotation = if dim > 2 then pi/7 else 0 + +-- | The dimension of a cube, if it is a power of the directed interval. +dimOf :: TermT n -> Maybe Int +dimOf = \case + Cube2T{} -> Just 1 + CubeProductT _ l r -> (+) <$> dimOf l <*> dimOf r + -- WARNING: breaks for 2 * (2 * 2) + _ -> Nothing + +maxRenderDim :: Int +maxRenderDim = 3 + +renderTermSVGFor + :: Distinct n + => String -- ^ main colour + -> Int -- ^ dimensions accumulated so far (0 to 3) + -> (Maybe (TermT n, TermT n), [Foil.Name n]) -- ^ the accumulated point, and its cube + -> TermT n -- ^ the term to render + -> TypeCheck n (Maybe String) +renderTermSVGFor mainColor accDim (mp, xs) t = do + t' <- whnfT t + ty <- typeOf t' + case t of -- check the unevaluated term + AppT _info f x -> renderApp f x + TypeFunT _ _orig' md' _ _ _ + | null xs -> withBinder (BinderVar (Just "_")) md' t' $ \binder -> + renderTermSVGFor "blue" 0 (Nothing, []) (Var (Foil.nameOf binder)) -- blue for types + + _ -> case t' of -- check the evaluated term + AppT _info f x -> renderApp f x + TypeFunT _ _orig' md' _ _ _ + | null xs -> withBinder (BinderVar (Just "_")) md' t' $ \binder -> + renderTermSVGFor "blue" 0 (Nothing, []) (Var (Foil.nameOf binder)) + + _ -> case ty of -- check the type of the term + TypeFunT _ orig md arg mtope ret + | Just dim <- dimOf arg, accDim + dim <= maxRenderDim -> + underArg orig md arg mtope ret t' (accDim + dim) True + | null xs -> + underArg orig md arg mtope ret t' accDim False + _ -> renderAccumulated t' + where + renderAccumulated t' = traverse (\(p', _) -> renderForSVG mainColor accDim p' t') mp + + renderApp f x = typeOf f >>= \case + TypeFunT _ fOrig md fArg mtopeArg ret + | Just dim <- dimOf fArg, dim <= maxRenderDim -> + inScopeMaybeTope fOrig md fArg mtopeArg $ \binder -> do + ret' <- openScoped binder ret + -- FIXME: breaks for 2 * (2 * 2), but works for 2 * 2 * 2 = (2 * 2) * 2 + Just <$> renderForSubShapeSVG mainColor dim + (map Foil.sink xs) (Foil.nameOf binder) + ret' (Foil.sink f) (Foil.sink x) + _ -> do + t' <- whnfT t + renderAccumulated t' + + -- Go under the domain of a function type, assuming its shape tope if it has + -- one, and render the body there. + underArg orig md arg mtope ret t' accDim' extend = + inScopeMaybeTope orig md arg mtope $ \binder -> do + let z = Var (Foil.nameOf binder) + arg' = Foil.sink arg + body <- case t' of + LambdaT _ _orig _marg lamBody -> openScoped binder lamBody + _ -> do + ret' <- openScoped binder ret + pure (appT ret' (Foil.sink t') z) + let mp' | extend = join' (fmap (both Foil.sink) mp) arg' z + | otherwise = fmap (both Foil.sink) mp + xs' | extend = Foil.nameOf binder : map Foil.sink xs + | otherwise = map Foil.sink xs + renderTermSVGFor mainColor accDim' (mp', xs') body + + both f (x, y) = (f x, f y) + + join' Nothing Cube2T{} x = Just (x, cube2T) + join' (Just (p, pt)) Cube2T{} x = Just (p', pt') + where + pt' = cubeProductT pt cube2T + p' = pairT pt' p x + join' p (CubeProductT _ l r) x = + join' (join' p l (firstT l x)) r (secondT r x) + join' _ _ _ = Nothing -- FIXME: error? + +-- | Enter a binder and assume the shape tope it carries, if any. +inScopeMaybeTope + :: Distinct n + => Binder -> TModality -> TermT n -> Maybe (ScopedTermT n) + -> (forall l. (Foil.DExt n l, Distinct l) => Foil.NameBinder n l -> TypeCheck l a) + -> TypeCheck n a +inScopeMaybeTope orig md ty mtope k = + withBinder orig md ty $ \binder -> + case mtope of + Nothing -> k binder + Just tope -> do + tope' <- openScoped binder tope + localTope tope' (k binder) + +renderTermSVG :: Distinct n => TermT n -> TypeCheck n (Maybe String) +renderTermSVG = renderTermSVGFor "red" 0 (Nothing, []) -- red for terms, by default + +-- | Render the goal /cell/ for a (shape) type: introduce an abstract inhabitant +-- and render it with the proof term hidden. Under a boundary tope an abstract +-- inhabitant of an extension type reduces to the prescribed face value, so the +-- cell shows its given edges with a blank interior — the shape to inhabit, not an +-- answer. 'Nothing' for a non-shape type (a 0-cell, or a non-cube goal). +renderGoalCellSVG :: Distinct n => TermT n -> TypeCheck n (Maybe String) +renderGoalCellSVG ty = + hidingTerm $ withBinder (BinderVar (Just "_")) Id ty $ \binder -> + renderTermSVG' (Var (Foil.nameOf binder)) + +renderTermSVG' :: forall n. Distinct n => TermT n -> TypeCheck n (Maybe String) +renderTermSVG' t = whnfT t >>= \t' -> typeOf t >>= \case + TypeFunT _ orig md arg mtope ret -> + inScopeMaybeTope orig md arg mtope $ \binder -> + case t' of + LambdaT _ _orig _marg lamBody -> + openScoped binder lamBody >>= \case + AppT _info f x -> typeOf f >>= \case + TypeFunT _ fOrig md2 fArg mtope2 _ret + | Just dim <- dimOf fArg -> do + ret' <- openScoped binder ret + inScopeMaybeTope fOrig md2 fArg mtope2 $ \binder2 -> + Just <$> renderForSubShapeSVG "red" dim + [Foil.sink (Foil.nameOf binder)] (Foil.nameOf binder2) + (Foil.sink ret') (Foil.sink f) (Foil.sink x) + _ -> renderApplied binder t' arg ret + _ -> renderApplied binder t' arg ret + _ -> renderApplied binder t' arg ret + _t' -> return Nothing + +-- | Render a term of a function type by applying it to the variable it abstracts +-- over, and drawing that. +renderApplied + :: Foil.DExt n l + => Foil.NameBinder n l -> TermT n -> TermT n -> ScopedTermT n + -> TypeCheck l (Maybe String) +renderApplied binder t' arg ret = do + ret' <- openScoped binder ret + let z = Var (Foil.nameOf binder) + applied = appT ret' (Foil.sink t') z + case dimOf arg of + Just dim | dim <= maxRenderDim -> + Just <$> renderForSVG "red" dim z applied + _ -> renderTermSVG' applied diff --git a/src/Rzk/TypeCheck/Unify.hs b/src/Rzk/TypeCheck/Unify.hs new file mode 100644 --- /dev/null +++ b/src/Rzk/TypeCheck/Unify.hs @@ -0,0 +1,469 @@ +{-# OPTIONS_GHC -fno-warn-name-shadowing #-} +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE FlexibleContexts #-} +{-# LANGUAGE GADTs #-} +{-# LANGUAGE LambdaCase #-} +{-# LANGUAGE PatternSynonyms #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | Unification, which in rzk is really subtyping: an extension type's faces, a +-- shape's tope and the variance of the position all take part. +module Rzk.TypeCheck.Unify where + +import Control.Monad (forM_, unless, when) +import Control.Monad.Except (catchError, throwError) +import Control.Monad.Reader (asks) +import Data.Maybe (fromMaybe) +import Data.Tuple (swap) + +import Control.Monad.Foil (DExt, Distinct, NameBinder) +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil (AST (Var)) + +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder, TModality (..), + TypeInfo (..)) +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Display (panicImpossible) +import Rzk.TypeCheck.Error +import Rzk.TypeCheck.Eval +import Rzk.TypeCheck.Monad +import Rzk.TypeCheck.NbE (nbeConvertible) + +-- | Open two scoped terms under /one/ binder, so that the two sides of a +-- comparison are compared as functions of the same variable. +inScope2 + :: Distinct n + => Binder -> TModality -> TermT n + -> ScopedTermT n -> ScopedTermT n + -> (forall l. (DExt n l, Distinct l) + => NameBinder n l -> TermT l -> TermT l -> TypeCheck l a) + -> TypeCheck n a +inScope2 orig md ty s1 s2 k = do + scope <- asks ctxScope + withScopedT2 scope s1 s2 $ \binder body1 body2 -> + underBinder binder orig md ty Nothing (k binder body1 body2) + +-- | α-equivalence in the ambient scope. +alphaEq :: Distinct n => TermT n -> TermT n -> TypeCheck n Bool +alphaEq l r = do + scope <- asks ctxScope + pure (alphaEqT scope l r) + +unifyTopes :: Distinct n => TermT n -> TermT n -> TypeCheck n () +unifyTopes l r = do + equiv <- (&&) + <$> [plainTope l] `entailM` r + <*> [plainTope r] `entailM` l + unless equiv $ + issueTypeError (TypeErrorTopesNotEquivalent l r) + +unify + :: Distinct n + => Maybe (TermT n) -> TermT n -> TermT n -> TypeCheck n () +unify mterm expected actual = performUnification `catchError` \typeError -> do + inAllSubContexts (throwError typeError) performUnification + where + performUnification = unifyInCurrentContext mterm expected actual + +-- | The syntactic fast path. +-- +-- α-equivalence, not the structural equality the old representation used: two +-- terms that differ only in a binder's name are the same term, and saying so here +-- saves the whole unification below. +unifyViaDecompose :: Distinct n => TermT n -> TermT n -> TypeCheck n () +unifyViaDecompose expected actual = do + same <- alphaEq expected actual + if same + then return () + else do + -- The NbE fast path: a shared-evaluation βδη-conversion check over the + -- context-insensitive fragment. 'True' is definite (see the module's + -- soundness note); 'False' only means "do not know", and unification + -- proceeds unchanged. It must run /before/ the application decomposition + -- below: decomposing @f x@ against @g y@ compares the arguments pairwise, + -- which for βδ-equal but structurally different applications creates + -- false subgoals (e.g. @16 =? 128@ from @16 · 16 =? 128 + 128@) that the + -- old path then grinds through only to fail and unwind. + fastPath <- nbeConvertible expected actual + if fastPath + then return () + else case (expected, actual) of + (AppT _ f x, AppT _ g y) -> do + unify Nothing f g + setVariance Invariant $ unify Nothing x y + _ -> issueTypeError (TypeErrorOther "cannot decompose") + +unifyTypes :: Distinct n => TermT n -> TermT n -> TermT n -> TypeCheck n () +unifyTypes = unify . Just + +unifyTerms :: Distinct n => TermT n -> TermT n -> TypeCheck n () +unifyTerms = unify Nothing + +checkCoherence + :: Distinct n + => (TermT n, TermT n) -> (TermT n, TermT n) -> TypeCheck n () +checkCoherence (ltope, lterm) (rtope, rterm) = + performing (ActionCheckCoherence (ltope, lterm) (rtope, rterm)) $ + localTope (topeAndT ltope rtope) $ do + ltype <- stripTypeRestrictions <$> typeOf lterm -- FIXME: why strip? + rtype <- stripTypeRestrictions <$> typeOf rterm -- FIXME: why strip? + -- FIXME: do we need to unify types here or is it included in unification of terms? + unifyTerms ltype rtype + unifyTerms lterm rterm + +unifyInCurrentContext + :: forall n. Distinct n + => Maybe (TermT n) -> TermT n -> TermT n -> TypeCheck n () +unifyInCurrentContext mterm expected actual = performing action $ do + inBottom <- contextEntailsBottom + unless inBottom $ + -- NOTE: the decomposition gives a small, but noticeable speedup + unifyViaDecompose expected actual `catchError` \_ -> do + expectedVal <- whnfT expected + actualVal <- whnfT actual + mea <- asks ctxCovariance >>= \case + Covariant -> Just <$> etaMatch mterm expectedVal actualVal + Contravariant -> Just . swap <$> etaMatch mterm actualVal expectedVal + Invariant -> traceTypeCheck Debug "invariant" $ do + -- FIXME: inefficient + traceTypeCheck Debug "invariant->covariant" $ + setVariance Covariant $ unifyInCurrentContext mterm expectedVal actualVal + traceTypeCheck Debug "invariant->contravariant" $ + setVariance Contravariant $ unifyInCurrentContext mterm expectedVal actualVal + return Nothing + case mea of + Nothing -> return () + -- A hole (in lenient mode) stands for a term of the expected type, so it + -- unifies with anything; accept it rather than falling through to the + -- dispatch below (which would panic on an unexpected term). + Just (expected', actual') | isHoleT expected' || isHoleT actual' -> return () + Just (expected', actual') -> do + same <- alphaEq expected' actual' + unless same $ dispatch expected' actual' + where + action = case mterm of + Nothing -> ActionUnifyTerms expected actual + Just term -> ActionUnify term expected actual + + dispatch :: TermT n -> TermT n -> TypeCheck n () + dispatch expected' actual' = + case actual' of + RecBottomT{} -> return () + RecOrT _ty rs' -> + case expected' of + RecOrT _ty rs -> sequence_ (checkCoherence <$> rs <*> rs') + _ -> + forM_ rs' $ \(tope, term) -> + localTope tope $ + unifyTerms expected' term + _ -> typeOf expected' >>= typeOf >>= \case + UniverseCubeT{} -> contextEntails (topeEQT expected' actual') + _ -> unifyStructurally expected' actual' + + unifyStructurally :: TermT n -> TermT n -> TypeCheck n () + unifyStructurally expected' actual' = do + -- A hole stands for a term of the expected type, so a unification that would + -- otherwise fail is deferred when either side still contains an (unfilled) + -- hole — including one nested in a larger term, e.g. @f ?@ checked against an + -- extension-type boundary. The hole may also sit in the tope context rather + -- than the terms: a hole standing for a whole shape point makes the enclosing + -- 'recOR' split over hole-dependent faces, and a branch reduction can drop the + -- hole from the terms while the assumed face (@π₁ ? ≤ π₂ ?@, say) still + -- mentions it. Such a branch is only entered because the hole is unfilled, so + -- a mismatch under it is deferred too. 'structuralHoleUnify' turns this off, + -- keeping a structural mismatch around a hole an error. + defer <- asks ctxDeferHoleMismatches + topeContextHasHole <- asks (any (containsHole . tTope) . ctxTopes) + let holePresent = defer && + (containsHole expected' || containsHole actual' || topeContextHasHole) + + err :: TypeCheck n () + err + | holePresent = return () + | otherwise = + case mterm of + Nothing -> issueTypeError (TypeErrorUnifyTerms expected' actual') + Just term -> issueTypeError (TypeErrorUnify term expected' actual') + + -- The same error, raised from inside a binder: the terms are sunk into + -- the inner scope, which is a coercion. (The old representation had to + -- shift each of them with @S <$>@.) + errIn :: DExt n l => TypeCheck l () + errIn + | holePresent = return () + | otherwise = + case mterm of + Nothing -> issueTypeError + (TypeErrorUnifyTerms (Foil.sink expected') (Foil.sink actual')) + Just term -> issueTypeError + (TypeErrorUnify (Foil.sink term) (Foil.sink expected') (Foil.sink actual')) + + def = do + same <- alphaEq expected' actual' + unless same err + + case expected' of + Var{} -> def + + UniverseT{} -> def + UniverseCubeT{} -> def + UniverseTopeT{} -> def + + TypeUnitT{} -> def + UnitT{} -> return () -- Unit always unifies! + + CubeUnitT{} -> def + CubeUnitStarT{} -> def + Cube2T{} -> def + Cube2_0T{} -> def + Cube2_1T{} -> def + CubeIT{} -> def + CubeI_0T{} -> def + CubeI_1T{} -> def + CubeProductT _ l r -> + case actual' of + CubeProductT _ l' r' -> do + unifyTerms l l' + unifyTerms r r' + _ -> err + + PairT _ty l r -> + case actual' of + PairT _ty' l' r' -> do + unifyTerms l l' + unifyTerms r r' + -- one part of eta-expansion for pairs + -- FIXME: add symmetric version! + _ -> err + + FirstT _ty t -> + case actual' of + FirstT _ty' t' -> unifyTerms t t' + _ -> err + + SecondT _ty t -> + case actual' of + SecondT _ty' t' -> unifyTerms t t' + _ -> err + + TopeTopT{} -> unifyTopes expected' actual' + TopeBottomT{} -> unifyTopes expected' actual' + TopeEQT{} -> unifyTopes expected' actual' + TopeLEQT{} -> unifyTopes expected' actual' + TopeAndT{} -> unifyTopes expected' actual' + TopeOrT{} -> unifyTopes expected' actual' + TopeInvT{} -> unifyTopes expected' actual' + TopeUninvT{} -> unifyTopes expected' actual' + + RecBottomT{} -> return () -- unifies with anything + RecOrT _ty rs -> + -- IMPORTANT: matching on actual' here would be redundant, but that is + -- not obvious; take care when refactoring. + forM_ rs $ \(tope, term) -> + localTope tope $ + unifyTerms term actual' + + TypeFunT _ty _orig md cube mtope ret -> + case actual' of + TypeFunT _ty' orig' md' cube' mtope' ret' -> do + when (md /= md') $ + issueTypeError (TypeErrorOther $ "modality mismatch in function type: expected " <> show md <> " but got " <> show md') + switchVariance $ -- unifying in the negative position! + unifyTerms cube cube' -- FIXME: unifyCubes + inScope2 orig' md cube' ret ret' $ \binder retBody retBody' -> do + -- The tope checks below are subtyping checks with a fixed direction + -- relative to (subtype, supertype). Which side is the subtype + -- depends on the ambient variance: under Covariant the actual type + -- must be a subtype of the expected one; under Contravariant (inside + -- a domain) the roles are reversed. Invariant is normally handled + -- upstream by running both directions; it is handled here as well + -- for safety. + variance <- asks ctxCovariance + scope <- asks ctxScope + let openTope = fmap (openWith scope (Foil.nameOf binder)) + mtopeIn = openTope mtope + mtopeIn' = openTope mtope' + case retBody' of + UniverseTopeT{} -> do + -- This is the case for tope families (shapes). + -- + -- (Λ → TOPE) <: (Δ → TOPE) since if φ : Λ → TOPE then φ ⊢ Δ. + -- We DO NOT take the tope context Φ into account! + expectedTopeNF <- fromMaybe topeTopT <$> traverse nfT mtopeIn + actualTopeNF <- fromMaybe topeTopT <$> traverse nfT mtopeIn' + let subEntailsSuper subNF superNF = do + entails <- [plainTope subNF] `entailM` superNF + unless (entails || containsHole subNF || containsHole superNF) $ + issueTypeError (TypeErrorTopeNotSatisfied [subNF] superNF) + case variance of + Covariant -> subEntailsSuper actualTopeNF expectedTopeNF + Contravariant -> subEntailsSuper expectedTopeNF actualTopeNF + Invariant -> do + subEntailsSuper actualTopeNF expectedTopeNF + subEntailsSuper expectedTopeNF actualTopeNF + _ -> do + -- this is the case for Π-types and extension types + -- + -- Ξ | Φ | Γ ⊢ {t : I | φ} → A t <: {s : J | ψ} → B s + -- when Ξ | Φ, ψ ⊢ φ + expectedTopeNF <- fromMaybe topeTopT <$> traverse nfT mtopeIn + actualTopeNF <- fromMaybe topeTopT <$> traverse nfT mtopeIn' + let superEntailsSub superNF subNF = + localTope superNF $ contextEntails subNF + case variance of + Covariant -> superEntailsSub expectedTopeNF actualTopeNF + Contravariant -> superEntailsSub actualTopeNF expectedTopeNF + Invariant -> do + superEntailsSub expectedTopeNF actualTopeNF + superEntailsSub actualTopeNF expectedTopeNF + case mterm of + Nothing -> unifyTerms retBody retBody' + Just term -> + unifyTypes + (appT retBody' (Foil.sink term) (Var (Foil.nameOf binder))) + retBody retBody' + _ -> err + + TypeSigmaT _ty _orig md a b -> + case actual' of + TypeSigmaT _ty' orig' md' a' b' -> do + when (md /= md') $ + issueTypeError (TypeErrorOther $ "modality mismatch in sigma type: expected " <> show md <> " but got " <> show md') + unify Nothing a a' + inScope2 orig' md a' b b' $ \_binder bBody bBody' -> + unify Nothing bBody bBody' + _ -> err + + TypeIdT _ty x tA y -> + case actual' of + TypeIdT _ty' x' tA' y' -> do + -- The underlying types must be compared: without this check the + -- routine equates identity types over different types whenever the + -- endpoints unify, accepting a free homotopy (a path in the type of + -- functions) where an endpoint-fixing one (a path in a hom-type) is + -- expected. Compared invariantly: subtyping between the underlying + -- types must not leak into equality of identity types over them. + mapM_ (\(t1, t2) -> setVariance Invariant (unify Nothing t1 t2)) + ((,) <$> tA <*> tA') + unify Nothing x x' + unify Nothing y y' + _ -> err + + AppT _ty f x -> + case actual' of + AppT _ty' f' x' -> do + unify Nothing f f' + setVariance Invariant $ + unify Nothing x x' + _ -> err + + LambdaT ty _orig _mparam body -> + case stripTypeRestrictions (infoType ty) of + TypeFunT _ty _origF md param mtope _ret -> + case actual' of + LambdaT ty' orig' _mparam' body' -> + case stripTypeRestrictions (infoType ty') of + TypeFunT _ty' _origF' md' param' mtope' _ret' -> do + when (md /= md') $ + issueTypeError (TypeErrorOther $ "modality mismatch in lambda: expected " <> show md <> " but got " <> show md') + unify Nothing param param' -- we (should) have already checked this in types! + inScope2 orig' md param body body' $ \binder bodyIn bodyIn' -> do + scope <- asks ctxScope + let openTope = fmap (openWith scope (Foil.nameOf binder)) + case (openTope mtope, openTope mtope') of + (Just tope, Just tope') -> do + unify Nothing tope tope' -- we (should) have already checked this in types! + localTope tope $ unify Nothing bodyIn bodyIn' + (Nothing, Nothing) -> + unify Nothing bodyIn bodyIn' + _ -> errIn + _ -> err + _ -> err + _ -> err + + LetT{} -> panicImpossible "let at the root of WHNF" + LetModT _ orig app inn _ val body -> + case actual' of + LetModT _ _ app' inn' _ val' body' + | app == app', inn == inn' -> do + unify Nothing val val' + bty <- typeOf val >>= \case + TypeModalT _ _ t -> pure t + _ -> panicImpossible "not modal in letmod" + inScope2 orig (comp app inn) bty body body' $ \_binder bodyIn bodyIn' -> + unify Nothing bodyIn bodyIn' + _ -> err + + ReflT ty _x | TypeIdT _ty x _tA y <- infoType ty -> + case actual' of + ReflT ty' _x' | TypeIdT _ty' x' _tA' y' <- infoType ty' -> do + unify Nothing x x' + unify Nothing y y' + _ -> err + ReflT{} -> panicImpossible "refl with a non-identity type!" + + IdJT _ty a b c d e f -> + case actual' of + IdJT _ty' a' b' c' d' e' f' -> do + unify Nothing a a' + unify Nothing b b' + unify Nothing c c' + unify Nothing d d' + unify Nothing e e' + unify Nothing f f' + _ -> err + + TypeAscT{} -> panicImpossible "type ascription at the root of WHNF" + + TypeRestrictedT _ty ty rs -> + case actual' of + TypeRestrictedT _ty' ty' rs' -> do + unify mterm ty ty' + -- The faces of the supertype must be covered by the faces of the + -- subtype (the subtype is at least as specified), with the boundary + -- terms agreeing on overlaps. Which side is the subtype depends on the + -- ambient variance. + variance <- asks ctxCovariance + let subCoversSuper subRs superRs = sequence_ + [ localTope tope $ do + -- FIXME: can do less entails checks? + contextEntails (foldr topeOrT topeBottomT (map fst subRs)) + forM_ subRs $ \(tope', term') -> + localTope tope' $ + unify Nothing term term' + | (tope, term) <- superRs + ] + case variance of + Covariant -> subCoversSuper rs' rs + Contravariant -> subCoversSuper rs rs' + Invariant -> do + subCoversSuper rs' rs + subCoversSuper rs rs' + _ -> err -- FIXME: need better unification for restrictions + + TypeModalT _ty m ty -> + case actual' of + TypeModalT _ty' m' ty' -> do + when (m' /= m) err + enterModality m $ unify Nothing ty ty' + _ -> err + ModAppT _ty m ty -> + case actual' of + ModAppT _ty' m' ty' -> do + when (m' /= m) err + enterModality m $ unify Nothing ty ty' + _ -> err + ModExtractT _ty app inn te -> + case actual' of + ModExtractT _ty' app' inn' te' -> do + when (app' /= app) err + when (inn' /= inn) err + enterModality app $ unify Nothing te te' + _ -> err + + -- defensive: a hole nested anywhere also defers here rather than panicking + -- on an otherwise unexpected shape + _ | holePresent -> return () + _ -> panicImpossible "unexpected term in UNIFY" diff --git a/test/Rzk/BinderTypesSpec.hs b/test/Rzk/BinderTypesSpec.hs --- a/test/Rzk/BinderTypesSpec.hs +++ b/test/Rzk/BinderTypesSpec.hs @@ -8,7 +8,7 @@ import qualified Data.Text as T -import Language.Rzk.Free.Syntax (RzkPosition (RzkPosition), +import Language.Rzk.Foil.Names (RzkPosition (RzkPosition), getVarIdent) import qualified Language.Rzk.Syntax as Rzk import Language.Rzk.Syntax (VarIdent' (VarIdent)) @@ -23,15 +23,14 @@ binderTypesOf src = case Rzk.parseModule src of Left err -> error ("parse error: " <> T.unpack err) - Right m -> case defaultTypeCheck (localVerbosity Silent (typecheckModulesWithLocation [("<test>", m)])) of - Left err -> error ("typecheck threw: " <> ppTypeErrorInScopedContext' BottomUp err) - Right decls -> - let ds = concatMap snd decls - in [ (pos, view t) - | (v, t) <- binderTypesInScopeOf ds ds - , let VarIdent (RzkPosition _ mpos) _ = getVarIdent v - , Just pos <- [mpos] - ] + Right m -> case typecheckModules [("<test>", m)] of + Left err -> error ("typecheck threw: " <> ppTypeErrorInScopedContext BottomUp err) + Right checked -> + [ (pos, view t) + | (v, t) <- binderTypesOfFile checked "<test>" + , let VarIdent (RzkPosition _ mpos) _ = getVarIdent v + , Just pos <- [mpos] + ] where view (TypeView t) = show t view (ShapeView c tope) = show c <> " | " <> show tope diff --git a/test/Rzk/DiagnosticSpec.hs b/test/Rzk/DiagnosticSpec.hs --- a/test/Rzk/DiagnosticSpec.hs +++ b/test/Rzk/DiagnosticSpec.hs @@ -22,9 +22,9 @@ case Rzk.parseModule src of Left err -> error ("parse error: " <> T.unpack err) Right m -> case typecheckModulesWithHoles [("<test>", m)] of - Left err -> [diagnoseTypeError BottomUp err] - Right (_, errors, holes) -> - map (diagnoseTypeError BottomUp) errors ++ map diagnoseHole holes + Left err -> [diagnoseTypeError BottomUp err] + Right (checked, holes) -> + map (diagnoseTypeError BottomUp) (checkedErrors checked) ++ map diagnoseHole holes spec :: Spec spec = do diff --git a/test/Rzk/FoilCoreSpec.hs b/test/Rzk/FoilCoreSpec.hs new file mode 100644 --- /dev/null +++ b/test/Rzk/FoilCoreSpec.hs @@ -0,0 +1,212 @@ +{-# LANGUAGE DataKinds #-} +{-# LANGUAGE OverloadedStrings #-} +{-# LANGUAGE RankNTypes #-} +{-# LANGUAGE ScopedTypeVariables #-} + +-- | The free-foil core: the surface conversions, α-equivalence, and the typing +-- context. +-- +-- The context tests are the load-bearing ones. Entering a binder sinks the +-- context by coercion (see "Rzk.TypeCheck.Context"), which is sound but unsafe if +-- the argument is ever wrong, so these check the things the argument promises: +-- that an entry stays intact and keeps its meaning however deeply it is sunk. +module Rzk.FoilCoreSpec (spec) where + +import qualified Control.Monad.Foil as Foil +import Control.Monad.Free.Foil (AST (Var), ScopedAST (..), + alphaEquiv) +import qualified Data.Text as T +import Test.Hspec + +import Language.Rzk.Foil.Convert (toTermClosed) +import Language.Rzk.Foil.Print (fromTermClosed) +import Language.Rzk.Foil.Syntax +import Language.Rzk.Foil.Names (Binder (..), TModality (..), + VarIdent, binderName) +import qualified Language.Rzk.Syntax as Rzk +import Rzk.TypeCheck.Context +import Rzk.TypeCheck.Display (namingOfContext, ppName, ppTerm) +import Rzk.TypeCheck.Error (OutputDirection (..), + ppTypeErrorInScopedContext) +import Rzk.TypeCheck.Eval (nfT, whnfT) +import Rzk.TypeCheck.Judgements (infer, typecheck) +import Rzk.TypeCheck.Monad (runTypeCheck) + +-- | Parse a term of the surface syntax, or fail loudly. +parse :: T.Text -> Rzk.Term +parse t = + case Rzk.parseTerm t of + Left err -> error ("cannot parse " <> show t <> ": " <> T.unpack err) + Right term -> term + +-- | Parse a closed term into the core. +core :: T.Text -> Term Foil.VoidS +core = toTermClosed . parse + +-- | Parse, elaborate to the core, and print back as surface syntax. +roundTrip :: T.Text -> T.Text +roundTrip = T.pack . Rzk.printTree . fromTermClosed . core + +-- | Are two closed terms α-equivalent? +equivalent :: T.Text -> T.Text -> Bool +equivalent l r = alphaEquiv Foil.emptyScope (core l) (core r) + +-- | A hypothesis of the given type, with no value and no modality. +hypothesis :: VarIdent -> TermT n -> VarInfo n +hypothesis name ty = VarInfo + { varType = ty + , varValue = Nothing + , varModality = Id + , varModAccum = Id + , varOrig = BinderVar (Just name) + , varIsAssumption = False + , varIsTopLevel = False + , varDeclaredAssumptions = [] + , varLocation = Nothing + } + +spec :: Spec +spec = do + -- The terms are closed (a free variable has no name to resolve to in an empty + -- scope), so each type-level example binds its own A and B. + describe "surface syntax round-trips through the core" $ do + let it_roundTrips t expected = + it (T.unpack t) $ roundTrip t `shouldBe` expected + + it_roundTrips "\\ x -> x" "\\ x → x" + it_roundTrips "\\ (t, s) -> t" "\\ (t, s) → t" + it_roundTrips "\\ A -> \\ (x : A) -> x" "\\ A → \\ (x : A) → x" + it_roundTrips "\\ A -> \\ B -> (x : A) -> B" "\\ A → \\ B → (x : A) → B" + it_roundTrips "\\ A -> \\ B -> A -> B" "\\ A → \\ B → A → B" + it_roundTrips "\\ A -> \\ B -> Sigma (x : A), B" "\\ A → \\ B → Σ (x : A), B" + it_roundTrips "\\ (t, s) -> first (t, s)" "\\ (t, s) → π₁ (t, s)" + it_roundTrips "\\ A -> \\ (x : A) -> refl_{x : A}" "\\ A → \\ (x : A) → refl_{ x : A }" + it_roundTrips "\\ t -> \\ s -> t === s" "\\ t → \\ s → t ≡ s" + + describe "α-equivalence ignores binder names" $ do + it "\\ x -> x is \\ y -> y" $ + equivalent "\\ x -> x" "\\ y -> y" `shouldBe` True + + -- The old representation derived Eq structurally, so it compared the binder + -- names too and called these two unequal. This is the behaviour change. + it "\\ x -> \\ y -> x is not \\ x -> \\ y -> y" $ + equivalent "\\ x -> \\ y -> x" "\\ x -> \\ y -> y" `shouldBe` False + + it "a pair pattern binds one variable, and its projections are right" $ do + equivalent "\\ (t, s) -> t" "\\ (a, b) -> a" `shouldBe` True + equivalent "\\ (t, s) -> t" "\\ (a, b) -> b" `shouldBe` False + + it "two holes with different names are different terms" $ + equivalent "?a" "?b" `shouldBe` False + + describe "the context" $ do + it "resolves a name bound three binders up" $ do + let ctx0 = emptyContext + withFreshBinder ctx0 (hypothesis "A" universeT) $ \bA ctxA -> + withFreshBinder ctxA (hypothesis "x" (Var (Foil.nameOf bA))) $ \_bx ctxx -> + withFreshBinder ctxx (hypothesis "y" cubeT) $ \_by ctxy -> do + -- 'A' was bound at the outermost scope and has been sunk twice. + case lookupNamed "A" ctxy of + Nothing -> expectationFailure "A is not in scope" + Just nameA -> do + let info = lookupVarInfo nameA ctxy + binderName (varOrig info) `shouldBe` Just "A" + alphaEquiv (ctxScope ctxy) (untyped (varType info)) (untyped universeT) + `shouldBe` True + + it "keeps a sunk hypothesis pointing at the name it was typed by" $ do + -- x : A, where A is itself a bound name. After sinking x's entry into a + -- deeper scope, its type must still be *that* name, not a stale or + -- renamed one: this is what the coercion in 'enterBinder' promises. + withFreshBinder emptyContext (hypothesis "A" universeT) $ \bA ctxA -> do + let nameA = Foil.nameOf bA + withFreshBinder ctxA (hypothesis "x" (Var nameA)) $ \_bx ctxx -> + withFreshBinder ctxx (hypothesis "y" cubeT) $ \_by ctxy -> + case lookupNamed "x" ctxy of + Nothing -> expectationFailure "x is not in scope" + Just nameX -> do + let info = lookupVarInfo nameX ctxy + case untyped (varType info) of + Var name -> Foil.nameId name `shouldBe` Foil.nameId nameA + _ -> expectationFailure "the type of x is no longer a variable" + + it "lets the outer binder keep its name when an inner one shadows it" $ + -- Display names are claimed oldest binding first (see 'ctxBound'), so the + -- inner 'x' is the one refreshed. The order cannot be read off the name + -- ids: free-foil refreshes a binder only on a clash, so after a + -- substitution an inner binder may carry a smaller id than an outer one. + withFreshBinder emptyContext (hypothesis "x" universeT) $ \bOuter ctxOuter -> + withFreshBinder ctxOuter (hypothesis "x" universeT) $ \bInner ctxInner -> do + let naming = namingOfContext ctxInner + ppName naming (Foil.sink (Foil.nameOf bOuter)) `shouldBe` "x" + ppName naming (Foil.nameOf bInner) `shouldNotBe` "x" + + it "records the names in scope for the shadowing check" $ + withFreshBinder emptyContext (hypothesis "A" universeT) $ \_bA ctxA -> + shadowedBy "A" ctxA `shouldBe` ["A" :: VarIdent] + + describe "evaluation" $ do + -- The identity on the directed interval, applied to an endpoint. A cube-layer + -- term, so this drives the whole reduction path: whnfT dispatches on the + -- layer, nfTope reduces the redex, and the argument is substituted into the + -- body (invalidating the memo on the way). + let identityOn2 :: TermT Foil.VoidS + identityOn2 = Foil.withFresh Foil.emptyScope $ \binder -> + let t = BinderVar (Just "t") + ty = typeFunT t Id cube2T Nothing (ScopedAST binder cube2T) + in lambdaT ty t (Just (LambdaParam Id cube2T Nothing)) + (ScopedAST binder (Var (Foil.nameOf binder))) + + applied = appT cube2T identityOn2 cube2_0T + + it "reduces (\\ t -> t) 0₂ to 0₂" $ + case runTypeCheck (whnfT applied) of + Left err -> expectationFailure (ppTypeErrorInScopedContext TopDown err) + Right result -> + alphaEquiv Foil.emptyScope (untyped result) (untyped cube2_0T) + `shouldBe` True + + it "does not reduce the unapplied identity" $ + case runTypeCheck (whnfT identityOn2) of + Left err -> expectationFailure (ppTypeErrorInScopedContext TopDown err) + Right result -> + alphaEquiv Foil.emptyScope (untyped result) (untyped cube2_0T) + `shouldBe` False + + describe "the checker" $ do + -- Parse, elaborate, infer, normalise, and print back: the whole pipeline of + -- the new core, end to end. + let inferAndShow :: T.Text -> Either String String + inferAndShow t = + case runTypeCheck (infer (core t) >>= nfT) of + Left err -> Left (ppTypeErrorInScopedContext TopDown err) + Right result -> Right (ppTerm (namingOfContext emptyContext) (untyped result)) + + checkAndShow :: T.Text -> T.Text -> Either String String + checkAndShow t ty = + case runTypeCheck (infer (core ty) >>= typecheck (core t) >>= nfT) of + Left err -> Left (ppTypeErrorInScopedContext TopDown err) + Right result -> Right (ppTerm (namingOfContext emptyContext) (untyped result)) + + it "infers and evaluates (\\ (x : Unit) -> x) unit" $ + inferAndShow "(\\ (x : Unit) -> x) unit" `shouldBe` Right "unit" + + it "infers a dependent function type" $ + inferAndShow "(A : U) -> A -> A" `shouldBe` Right "(A : U) → A → A" + + it "checks the identity against its type" $ + -- the elaborated lambda carries the domain it was checked against + checkAndShow "\\ A -> \\ (x : A) -> x" "(A : U) -> A -> A" + `shouldBe` Right "\\ (A : U) → \\ (x : A) → x" + + it "rejects a term that does not have the expected type" $ + case checkAndShow "\\ A -> \\ (x : A) -> A" "(A : U) -> A -> A" of + Left err -> err `shouldContain` "cannot unify" + Right t -> expectationFailure ("expected a type error, got " <> t) + + -- A cube domain with a pair pattern: the binder binds one variable whose + -- components are projections, and the pattern is shown back. + it "checks a function from a cube point" $ + checkAndShow "\\ A -> \\ (a : A) -> \\ ((t, s) : 2 * 2) -> a" + "(A : U) -> (a : A) -> (t : 2 * 2) -> A" + `shouldBe` Right "\\ (A : U) → \\ (a : A) → \\ ((t, s) : 2 × 2) → a" diff --git a/test/Rzk/HolesSpec.hs b/test/Rzk/HolesSpec.hs --- a/test/Rzk/HolesSpec.hs +++ b/test/Rzk/HolesSpec.hs @@ -14,7 +14,7 @@ import System.FilePath ((</>)) import qualified Language.Rzk.Syntax as Rzk -import Language.Rzk.Free.Syntax (VarIdent) +import Language.Rzk.Foil.Names (VarIdent) import Rzk.Diagnostic (typeErrorTagInScopedContext) import Rzk.TypeCheck @@ -27,8 +27,8 @@ case Rzk.parseModule src of Left err -> error ("parse error: " <> T.unpack err) Right m -> case typecheckModulesWithHoles [("<test>", m)] of - Left err -> error ("typecheck threw: " <> ppTypeErrorInScopedContext' BottomUp err) - Right (_, _, holes) -> holes + Left err -> error ("typecheck threw: " <> ppTypeErrorInScopedContext BottomUp err) + Right (_, holes) -> holes -- | Like 'holesOf', but allow-lists the given named top-level lemmas for the -- candidate hints (see 'withHintLemmas'\/'typecheckModulesWithHolesAndLemmas'). @@ -37,8 +37,8 @@ case Rzk.parseModule src of Left err -> error ("parse error: " <> T.unpack err) Right m -> case typecheckModulesWithHolesAndLemmas lemmas [("<test>", m)] of - Left err -> error ("typecheck threw: " <> ppTypeErrorInScopedContext' BottomUp err) - Right (_, _, holes) -> holes + Left err -> error ("typecheck threw: " <> ppTypeErrorInScopedContext BottomUp err) + Right (_, holes) -> holes names :: [HoleEntry] -> [String] names = map (show . holeEntryName) @@ -52,7 +52,7 @@ Left err -> error ("parse error: " <> T.unpack err) Right m -> case typecheckModulesWithHoles [("<test>", m)] of Left err -> [typeErrorTagInScopedContext err] - Right (_, errs, _) -> map typeErrorTagInScopedContext errs + Right (checked, _) -> map typeErrorTagInScopedContext (checkedErrors checked) -- | Like 'holesOf'/'errTagsOf', but reads a module from @test/files/@ (so a -- large example need not be inlined). Honours @RZK_TEST_ROOT@ like the other @@ -64,8 +64,9 @@ case Rzk.parseModule src of Left err -> error ("parse error: " <> T.unpack err) Right m -> case typecheckModulesWithHoles [(name, m)] of - Left err -> error ("typecheck threw: " <> ppTypeErrorInScopedContext' BottomUp err) - Right (_, errs, hs) -> pure (hs, map typeErrorTagInScopedContext errs) + Left err -> error ("typecheck threw: " <> ppTypeErrorInScopedContext BottomUp err) + Right (checked, hs) -> + pure (hs, map typeErrorTagInScopedContext (checkedErrors checked)) spec :: Spec spec = do diff --git a/test/Rzk/TypeCheckSpec.hs b/test/Rzk/TypeCheckSpec.hs --- a/test/Rzk/TypeCheckSpec.hs +++ b/test/Rzk/TypeCheckSpec.hs @@ -17,20 +17,18 @@ takeFileName) import System.FilePath.Glob (compile, globDir1) -import Language.Rzk.Free.Syntax (VarIdent) import qualified Language.Rzk.Syntax as Rzk -import Rzk.Diagnostic (typeErrorTag) -import Rzk.TypeCheck (Context (..), Decl', LocationInfo (..), - OutputDirection (..), TypeError (..), - TypeErrorInContext (..), - TypeErrorInScopedContext (..), - Verbosity (..), defaultTypeCheck, - localVerbosity, ppTypeErrorInScopedContext', - typecheckModulesWithLocation, - typecheckModulesWithLocation') +import Rzk.Diagnostic (locationOfTypeError, + typeErrorTagInScopedContext) +import Rzk.TypeCheck (Checked, Context (..), + LocationInfo (..), + OutputDirection (..), + TypeErrorInScopedContext, + Verbosity (..), checkedErrors, + checkedModules, emptyContext, + ppTypeErrorInScopedContext) import Test.Hspec -import Unsafe.Coerce (unsafeCoerce) data Expect = Expect { expectStatus :: String @@ -52,24 +50,19 @@ <*> o .:? "modules" <*> o .:? "api" --- | Strip 'ScopedTypeError' layers; take the leaf 'TypeError'. --- Scoped layers change the type parameter ('Inc'); we only need the constructor name, so 'unsafeCoerce' is used for recursion (same shape at runtime). -peelTypeError :: TypeErrorInScopedContext VarIdent -> TypeError VarIdent -peelTypeError = \case - PlainTypeError e -> typeErrorError e - ScopedTypeError _ e -> peelTypeError (unsafeCoerce e) - -errorLine :: TypeErrorInScopedContext VarIdent -> Maybe Int -errorLine = \case - PlainTypeError e -> - location (typeErrorContext e) >>= locationLine - ScopedTypeError _ e -> errorLine (unsafeCoerce e) +-- | The line an error was raised on. +-- +-- An error carries the context it was raised in, so there are no binder layers to +-- peel: the old representation nested the error one Inc deeper at every binder, and +-- this had to unsafeCoerce its way back out. +errorLine :: TypeErrorInScopedContext -> Maybe Int +errorLine err = locationOfTypeError err >>= locationLine --- | The constructor name of a type error, used to match @error_tag@ in --- fixtures. This is the library's 'typeErrorTag' (also used for diagnostic --- codes), aliased here so the two cannot drift apart. -typeErrorConstructorName :: TypeError VarIdent -> String -typeErrorConstructorName = typeErrorTag +-- | The constructor name of a type error, used to match @error_tag@ in fixtures. +-- This is the library's own tag (also used for diagnostic codes), so the two cannot +-- drift apart. +typeErrorConstructorName :: TypeErrorInScopedContext -> String +typeErrorConstructorName = typeErrorTagInScopedContext casesRoot :: FilePath casesRoot = "test/typecheck/cases" @@ -104,32 +97,41 @@ Right m -> fmap (fmap ((relPath, m) :)) $ loadModules rest -- | Run the checker with @verbosity = Silent@ so @traceTypeCheck Normal@ does not --- clutter @stack test@ output (CLI keeps default @Normal@ via @emptyContext@). -runStrict :: [(FilePath, Rzk.Module)] -> Either (TypeErrorInScopedContext VarIdent) [(FilePath, [Decl'])] -runStrict = defaultTypeCheck . localVerbosity Silent . typecheckModulesWithLocation +-- clutter @stack test@ output (the CLI keeps the default @Normal@). +silently :: Context n -> Context n +silently ctx = ctx { ctxVerbosity = Silent } -runCollect :: [(FilePath, Rzk.Module)] -> Either (TypeErrorInScopedContext VarIdent) ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent]) -runCollect = defaultTypeCheck . localVerbosity Silent . typecheckModulesWithLocation' +-- | Strict: the first error stops the run and is returned. +runStrict :: [(FilePath, Rzk.Module)] -> Either TypeErrorInScopedContext Checked +runStrict ms = case checkedModules ms (silently emptyContext) of + Left err -> Left err + Right (checked, _holes) -> case checkedErrors checked of + err : _ -> Left err + [] -> Right checked -assertExpect :: String -> Expect -> Either (TypeErrorInScopedContext VarIdent) [(FilePath, [Decl'])] -> IO () +-- | Collect: every error is returned, and the run continues past them. +runCollect :: [(FilePath, Rzk.Module)] -> Either TypeErrorInScopedContext Checked +runCollect ms = fst <$> checkedModules ms (silently emptyContext) + +assertExpect :: String -> Expect -> Either TypeErrorInScopedContext Checked -> IO () assertExpect _label Expect{..} (Right _) | expectStatus /= "ok" = expectationFailure "expected type error (status: error), but typechecking succeeded" assertExpect label Expect{..} (Left err) | expectStatus == "ok" = expectationFailure $ "unexpected type error in " <> label <> ":\n" - <> ppTypeErrorInScopedContext' BottomUp err + <> ppTypeErrorInScopedContext BottomUp err assertExpect label Expect{..} (Left err) | expectStatus == "error" = do - let tag = typeErrorConstructorName (peelTypeError err) + let tag = typeErrorConstructorName err case expectErrorTag of Nothing -> expectationFailure "expect.yaml missing error_tag for status: error" Just want | want /= tag -> expectationFailure $ "wrong error constructor in " <> label <> ": wanted " <> want <> ", got " <> tag <> "\nFull message:\n" - <> ppTypeErrorInScopedContext' BottomUp err + <> ppTypeErrorInScopedContext BottomUp err Just _ -> pure () case expectMessageContains of Nothing -> pure () Just subs -> do - let msg = ppTypeErrorInScopedContext' BottomUp err + let msg = ppTypeErrorInScopedContext BottomUp err mapM_ (\s -> unless (s `isInfixOf` msg) $ expectationFailure $ "in " <> label <> ", message missing substring " <> show s <> ":\n" <> msg) subs @@ -146,10 +148,11 @@ assertExpect label Expect{expectStatus = st} _ = expectationFailure $ "in " <> label <> ", unknown status " <> show st -assertExpectCollect :: String -> Expect -> Either (TypeErrorInScopedContext VarIdent) ([(FilePath, [Decl'])], [TypeErrorInScopedContext VarIdent]) -> IO () +assertExpectCollect :: String -> Expect -> Either TypeErrorInScopedContext Checked -> IO () assertExpectCollect _label _ (Left err) = - expectationFailure $ "unexpected fatal error: " <> ppTypeErrorInScopedContext' BottomUp err -assertExpectCollect label Expect{..} (Right (_decls, errs)) = case expectStatus of + expectationFailure $ "unexpected fatal error: " <> ppTypeErrorInScopedContext BottomUp err +assertExpectCollect label Expect{..} (Right checked) = case checkedErrors checked of + errs -> case expectStatus of "ok" | not (null errs) -> expectationFailure $ "in " <> label <> ", expected ok but got errors: " <> show (length errs) "ok" -> pure () @@ -157,7 +160,7 @@ [] -> expectationFailure $ "in " <> label <> ", expected type errors but got none" err : _ -> do - let tag = typeErrorConstructorName (peelTypeError err) + let tag = typeErrorConstructorName err case expectErrorTag of Nothing -> expectationFailure "expect.yaml missing error_tag for status: error" Just want | want /= tag -> @@ -167,7 +170,7 @@ case expectMessageContains of Nothing -> pure () Just subs -> do - let msg = ppTypeErrorInScopedContext' BottomUp err + let msg = ppTypeErrorInScopedContext BottomUp err mapM_ (\s -> unless (s `isInfixOf` msg) $ expectationFailure $ "in " <> label <> ", message missing substring " <> show s) subs diff --git a/test/typecheck/cases/happy-nbe-church-conversion.expect.yaml b/test/typecheck/cases/happy-nbe-church-conversion.expect.yaml new file mode 100644 --- /dev/null +++ b/test/typecheck/cases/happy-nbe-church-conversion.expect.yaml @@ -0,0 +1,4 @@ +status: ok +regression_for: + - nbe-conversion-fastpath + - unifyViaDecompose-false-subgoals diff --git a/test/typecheck/cases/happy-nbe-church-conversion.rzk b/test/typecheck/cases/happy-nbe-church-conversion.rzk new file mode 100644 --- /dev/null +++ b/test/typecheck/cases/happy-nbe-church-conversion.rzk @@ -0,0 +1,41 @@ +#lang rzk-1 + +-- Church numerals: the definitional equalities below hold only after full +-- βδ-normalisation of structurally different applications, which exercises +-- the NbE conversion fast path (Rzk.TypeCheck.NbE). Kept small so that the +-- ordinary unification path also checks this file quickly. + +#define CN : U + := (X : U) → (X → X) → X → X + +#define czero : CN + := \ X s x → x + +#define csucc (n : CN) : CN + := \ X s x → s (n X s x) + +#define cadd (m n : CN) : CN + := \ X s x → m X s (n X s x) + +#define cmul (m n : CN) : CN + := \ X s → m X (n X s) + +#define cexp (m n : CN) : CN + := \ X → n (X → X) (m X) + +#define c1 : CN := csucc czero +#define c2 : CN := cadd c1 c1 +#define c4 : CN := cadd c2 c2 +#define c8 : CN := cadd c4 c4 +#define c16 : CN := cadd c8 c8 +#define c64 : CN := cadd (cadd c16 c16) (cadd c16 c16) + +-- 8 * 8 = 64, mul against an addition chain +#define test-mul : cmul c8 c8 = c64 := refl + +-- 2 ^ 4 = 16, exp against a doubling chain +#define test-exp : cexp c2 c4 = c16 := refl + +-- endpoints as inline applications (regression: these must not be +-- decomposed into the false subgoal 4 =? 16) +#define test-inline : cmul c4 c4 = cadd c8 c8 := refl diff --git a/test/typecheck/cases/happy-set-option-warn-overhang.expect.yaml b/test/typecheck/cases/happy-set-option-warn-overhang.expect.yaml new file mode 100644 --- /dev/null +++ b/test/typecheck/cases/happy-set-option-warn-overhang.expect.yaml @@ -0,0 +1,4 @@ +status: ok +regression_for: + - warn-overhang-option + - checkTopeAgainstContext-opt-in-hint diff --git a/test/typecheck/cases/happy-set-option-warn-overhang.rzk b/test/typecheck/cases/happy-set-option-warn-overhang.rzk new file mode 100644 --- /dev/null +++ b/test/typecheck/cases/happy-set-option-warn-overhang.rzk @@ -0,0 +1,16 @@ +#lang rzk-1 + +-- The overhang hint is opt-in: deciding whether a restriction face or recOR +-- guard overhangs the local tope context costs a solver entailment per face, +-- so it is off by default and enabled with this option. The definition below +-- overhangs (see happy-restrict-face-not-contained); with the option on it +-- still typechecks — the hint is non-fatal — and the option name must be +-- recognised by #set-option and #unset-option. + +#set-option "warn-overhang" = "yes" + +#define faceOverhang (t : 2 * 2 | first t === 0_2) + : Unit [ (first t === 0_2) \/ (second t === 0_2) |-> unit ] + := unit + +#unset-option "warn-overhang" diff --git a/test/typecheck/cases/ill-nbe-church-unequal.expect.yaml b/test/typecheck/cases/ill-nbe-church-unequal.expect.yaml new file mode 100644 --- /dev/null +++ b/test/typecheck/cases/ill-nbe-church-unequal.expect.yaml @@ -0,0 +1,5 @@ +status: error +error_tag: TypeErrorUnifyTerms +line: 24 +regression_for: + - nbe-conversion-fastpath diff --git a/test/typecheck/cases/ill-nbe-church-unequal.rzk b/test/typecheck/cases/ill-nbe-church-unequal.rzk new file mode 100644 --- /dev/null +++ b/test/typecheck/cases/ill-nbe-church-unequal.rzk @@ -0,0 +1,24 @@ +#lang rzk-1 + +-- A wrong Church-numeral equation must still be rejected: the NbE fast path +-- (Rzk.TypeCheck.NbE) answers only "definitely convertible" or "do not +-- know", so inequality must surface from the ordinary unification. + +#define CN : U + := (X : U) → (X → X) → X → X + +#define czero : CN + := \ X s x → x + +#define csucc (n : CN) : CN + := \ X s x → s (n X s x) + +#define cadd (m n : CN) : CN + := \ X s x → m X s (n X s x) + +#define c1 : CN := csucc czero +#define c2 : CN := cadd c1 c1 +#define c4 : CN := cadd c2 c2 + +-- 2 + 2 is not 2 +#define test-wrong : cadd c2 c2 = c2 := refl