{-# 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.Reader        (ask, asks, local)
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 :: forall (n :: S) a. (VarInfo n -> a) -> Name n -> TypeCheck n a
infoOfVar VarInfo n -> a
f Name n
x = (Context n -> a)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (VarInfo n -> a
f (VarInfo n -> a) -> (Context n -> VarInfo n) -> Context n -> a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name n -> Context n -> VarInfo n
forall (n :: S). Name n -> Context n -> VarInfo n
lookupVarInfo Name n
x)

valueOfVar :: Foil.Name n -> TypeCheck n (Maybe (TermT n))
valueOfVar :: forall (n :: S). Name n -> TypeCheck n (Maybe (TermT n))
valueOfVar = (VarInfo n -> Maybe (TermT n))
-> Name n -> TypeCheck n (Maybe (TermT n))
forall (n :: S) a. (VarInfo n -> a) -> Name n -> TypeCheck n a
infoOfVar VarInfo n -> Maybe (TermT n)
forall (n :: S). VarInfo n -> Maybe (TermT n)
varValue

typeOfVar :: Foil.Name n -> TypeCheck n (TermT n)
typeOfVar :: forall (n :: S). Name n -> TypeCheck n (TermT n)
typeOfVar = (VarInfo n -> TermT n) -> Name n -> TypeCheck n (TermT n)
forall (n :: S) a. (VarInfo n -> a) -> Name n -> TypeCheck n a
infoOfVar VarInfo n -> TermT n
forall (n :: S). VarInfo n -> TermT n
varType

modalityOfVar :: Foil.Name n -> TypeCheck n TModality
modalityOfVar :: forall (n :: S). Name n -> TypeCheck n TModality
modalityOfVar = (VarInfo n -> TModality) -> Name n -> TypeCheck n TModality
forall (n :: S) a. (VarInfo n -> a) -> Name n -> TypeCheck n a
infoOfVar VarInfo n -> TModality
forall (n :: S). VarInfo n -> TModality
varModality

locksOfVar :: Foil.Name n -> TypeCheck n TModality
locksOfVar :: forall (n :: S). Name n -> TypeCheck n TModality
locksOfVar = (VarInfo n -> TModality) -> Name n -> TypeCheck n TModality
forall (n :: S) a. (VarInfo n -> a) -> Name n -> TypeCheck n a
infoOfVar VarInfo n -> TModality
forall (n :: S). VarInfo n -> TModality
varModAccum

isTopLevelVar :: Foil.Name n -> TypeCheck n Bool
isTopLevelVar :: forall (n :: S). Name n -> TypeCheck n Bool
isTopLevelVar = (VarInfo n -> Bool) -> Name n -> TypeCheck n Bool
forall (n :: S) a. (VarInfo n -> a) -> Name n -> TypeCheck n a
infoOfVar VarInfo n -> Bool
forall (n :: S). VarInfo n -> Bool
varIsTopLevel

-- | Is a surface name defined?
checkDefinedVar :: Distinct n => VarIdent -> TypeCheck n ()
checkDefinedVar :: forall (n :: S). Distinct n => VarIdent -> TypeCheck n ()
checkDefinedVar VarIdent
name = (Context n -> Maybe (Name n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (Name n))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (VarIdent -> Context n -> Maybe (Name n)
forall (n :: S). VarIdent -> Context n -> Maybe (Name n)
lookupNamed VarIdent
name) ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Maybe (Name n))
-> (Maybe (Name n)
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) ())
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) ()
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Maybe (Name n)
Nothing -> TypeError n
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) ()
forall (n :: S) a. Distinct n => TypeError n -> TypeCheck n a
issueTypeError (VarIdent -> TypeError n
forall (n :: S). VarIdent -> TypeError n
TypeErrorUndefined VarIdent
name)
  Just Name n
_  -> ()
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) ()
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

typeOfUncomputed :: TermT n -> TypeCheck n (TermT n)
typeOfUncomputed :: forall (n :: S). TermT n -> TypeCheck n (TermT n)
typeOfUncomputed = \case
  Var Name n
x -> Name n -> TypeCheck n (TermT n)
forall (n :: S). Name n -> TypeCheck n (TermT n)
typeOfVar Name n
x
  TermT n
t     -> case TermT n -> Maybe (TypeInfo (TermT n))
forall (n :: S). TermT n -> Maybe (TypeInfo (TermT n))
typeInfoOf TermT n
t of
    Just TypeInfo (TermT n)
info -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n
forall term. TypeInfo term -> term
infoType TypeInfo (TermT n)
info)
    Maybe (TypeInfo (TermT n))
Nothing   -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"a node with no annotation"

typeOf :: Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf :: forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
t = TermT n -> TypeCheck n (TermT n)
forall (n :: S). TermT n -> TypeCheck n (TermT n)
typeOfUncomputed TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
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 :: forall (n :: S). TermT n -> TypeCheck n [Name n]
freeVarsDeep TermT n
t = do
  ctx <- ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Context n)
forall r (m :: * -> *). MonadReader r m => m r
ask
  let typeOfName Name n
v = VarInfo n -> TermT n
forall (n :: S). VarInfo n -> TermT n
varType (Name n -> Context n -> VarInfo n
forall (n :: S). Name n -> Context n -> VarInfo n
lookupVarInfo Name n
v Context n
ctx)

      -- a node's own free variables, and those of its type
      partial TermT n
term = case TermT n -> Maybe (TypeInfo (TermT n))
forall (n :: S). TermT n -> Maybe (TypeInfo (TermT n))
typeInfoOf TermT n
term of
        Maybe (TypeInfo (TermT n))
Nothing   -> TermT n -> [Name n]
forall (n :: S). TermT n -> [Name n]
freeVarsOfTermT TermT n
term
        Just TypeInfo (TermT n)
info -> TermT n -> [Name n]
forall (n :: S). TermT n -> [Name n]
freeVarsOfTermT TermT n
term [Name n] -> [Name n] -> [Name n]
forall a. Semigroup a => a -> a -> a
<> TermT n -> [Name n]
forall (n :: S). TermT n -> [Name n]
freeVarsOfTermT (TypeInfo (TermT n) -> TermT n
forall term. TypeInfo term -> term
infoType TypeInfo (TermT n)
info)

      go [Name n]
vars [Name n]
latest
        | [Name n] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name n]
new  = [Name n]
vars
        | Bool
otherwise = [Name n] -> [Name n] -> [Name n]
go ([Name n]
new [Name n] -> [Name n] -> [Name n]
forall a. Semigroup a => a -> a -> a
<> [Name n]
vars) ((Name n -> [Name n]) -> [Name n] -> [Name n]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (TermT n -> [Name n]
forall (n :: S). TermT n -> [Name n]
partial (TermT n -> [Name n]) -> (Name n -> TermT n) -> Name n -> [Name n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name n -> TermT n
typeOfName) [Name n]
new)
        where
          new :: [Name n]
new = (Name n -> Bool) -> [Name n] -> [Name n]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name n -> [Name n] -> Bool
forall (n :: S). Name n -> [Name n] -> Bool
`notElemName` [Name n]
vars) ([Name n] -> [Name n]
forall (n :: S). [Name n] -> [Name n]
nubNames [Name n]
latest)

  pure (go [] (partial t))

nubNames :: [Foil.Name n] -> [Foil.Name n]
nubNames :: forall (n :: S). [Name n] -> [Name n]
nubNames = (Name n -> Name n -> Bool) -> [Name n] -> [Name n]
forall a. (a -> a -> Bool) -> [a] -> [a]
nubBy (\Name n
a Name n
b -> Name n -> Id
forall (l :: S). Name l -> Id
Foil.nameId Name n
a Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Name n -> Id
forall (l :: S). Name l -> Id
Foil.nameId Name n
b)

elemName :: Foil.Name n -> [Foil.Name n] -> Bool
elemName :: forall (n :: S). Name n -> [Name n] -> Bool
elemName Name n
x = (Name n -> Bool) -> [Name n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name n
y -> Name n -> Id
forall (l :: S). Name l -> Id
Foil.nameId Name n
x Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Name n -> Id
forall (l :: S). Name l -> Id
Foil.nameId Name n
y)

notElemName :: Foil.Name n -> [Foil.Name n] -> Bool
notElemName :: forall (n :: S). Name n -> [Name n] -> Bool
notElemName Name n
x = Bool -> Bool
not (Bool -> Bool) -> ([Name n] -> Bool) -> [Name n] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name n -> [Name n] -> Bool
forall (n :: S). Name n -> [Name n] -> Bool
elemName Name n
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 :: forall (n :: S).
Distinct n =>
ScopedTermT n -> TermT n -> TypeCheck n (TermT n)
instantiate ScopedTermT n
scoped TermT n
arg = do
  scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
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, DExt n l)
  => TModality -> TermT n -> Maybe (TermT n) -> NameBinder n l
  -> TypeCheck n [ModalTope l]
discreteAxiomOf :: forall (n :: S) (l :: S).
(Distinct n, DExt n l) =>
TModality
-> TermT n
-> Maybe (TermT n)
-> NameBinder n l
-> TypeCheck n [ModalTope l]
discreteAxiomOf TModality
Flat TermT n
ty Maybe (TermT n)
mval NameBinder n l
binder = TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
ty TypeCheck n (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         [ModalTope l])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope l]
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Cube2T{} -> TermT l
-> TermT l
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope l]
endpoints TermT l
forall (n :: S). TermT n
cube2_0T TermT l
forall (n :: S). TermT n
cube2_1T
    CubeIT{} -> TermT l
-> TermT l
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope l]
endpoints TermT l
forall (n :: S). TermT n
cubeI_0T TermT l
forall (n :: S). TermT n
cubeI_1T
    TermT n
_        -> [ModalTope l]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope l]
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
  where
    point :: TypeCheck n (TermT l)
    point :: TypeCheck n (TermT l)
point = case Maybe (TermT n)
mval of
      Maybe (TermT n)
Nothing -> TermT l -> TypeCheck n (TermT l)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Name l -> TermT l
forall (n :: S) (binder :: S -> S -> *) (sig :: * -> * -> *).
Name n -> AST binder sig n
Var (NameBinder n l -> Name l
forall (n :: S) (l :: S). NameBinder n l -> Name l
Foil.nameOf NameBinder n l
binder))
      Just TermT n
v  -> TermT n -> TermT l
forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
Foil.sink (TermT n -> TermT l)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT l)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
v
    endpoints :: TermT l
-> TermT l
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope l]
endpoints TermT l
zero TermT l
one = do
      z <- TypeCheck n (TermT l)
point
      pure [plainTope (topeOrT (topeEQT z zero) (topeEQT z one))]
discreteAxiomOf TModality
_ TermT n
_ Maybe (TermT n)
_ NameBinder n l
_ = [ModalTope l]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope l]
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []

-- | What a binder adds to the context.
binderInfo
  :: Binder -> TModality -> TermT n -> Maybe (TermT n) -> Maybe LocationInfo
  -> VarInfo n
binderInfo :: forall (n :: S).
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> Maybe LocationInfo
-> VarInfo n
binderInfo Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval Maybe LocationInfo
loc = VarInfo
  { varType :: TermT n
varType = TermT n
ty
  , varValue :: Maybe (TermT n)
varValue = Maybe (TermT n)
mval
  , varModality :: TModality
varModality = TModality
md
  , varModAccum :: TModality
varModAccum = TModality
Id
  , varOrig :: Binder
varOrig = Binder
orig
  , varIsAssumption :: Bool
varIsAssumption = Bool
False
  , varIsTopLevel :: Bool
varIsTopLevel = Bool
False
  , varDeclaredAssumptions :: [Name n]
varDeclaredAssumptions = []
  , varLocation :: Maybe LocationInfo
varLocation = Maybe LocationInfo
loc
  , varDataRole :: Maybe (DataRole n)
varDataRole = Maybe (DataRole n)
forall a. Maybe a
Nothing
  , varMetaPrefix :: Id
varMetaPrefix = Id
0
  }

-- | 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 :: forall (n :: S) (l :: S) a.
(Distinct n, DExt n l) =>
NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> TypeCheck n a
underBinder NameBinder n l
binder Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval TypeCheck l a
action = do
  ctx <- ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Context n)
forall r (m :: * -> *). MonadReader r m => m r
ask
  discrete <- discreteAxiomOf md ty mval binder
  let info = Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> Maybe LocationInfo
-> VarInfo n
forall (n :: S).
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> Maybe LocationInfo
-> VarInfo n
binderInfo Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval (Context n -> Maybe LocationInfo
forall (n :: S). Context n -> Maybe LocationInfo
ctxLocation Context n
ctx)
      ctx' = NameBinder n l
-> VarInfo n -> [ModalTope l] -> Context n -> Context l
forall (n :: S) (l :: S).
DExt n l =>
NameBinder n l
-> VarInfo n -> [ModalTope l] -> Context n -> Context l
enterBinder NameBinder n l
binder VarInfo n
info [ModalTope l]
discrete Context n
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 :: forall (n :: S) a.
Distinct n =>
Binder
-> TModality
-> TermT n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    NameBinder n l -> TypeCheck l a)
-> TypeCheck n a
withBinder Binder
orig TModality
md TermT n
ty forall (l :: S).
(DExt n l, Distinct l) =>
NameBinder n l -> TypeCheck l a
k = do
  scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
ctxScope
  withFreshIn scope $ \NameBinder n l
binder ->
    NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (n :: S) (l :: S) a.
(Distinct n, DExt n l) =>
NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> TypeCheck n a
underBinder NameBinder n l
binder Binder
orig TModality
md TermT n
ty Maybe (TermT n)
forall a. Maybe a
Nothing (NameBinder n l -> TypeCheck l a
forall (l :: S).
(DExt n l, Distinct l) =>
NameBinder n l -> TypeCheck l a
k NameBinder n l
binder)

withFreshIn
  :: Distinct n
  => Foil.Scope n
  -> (forall l. (DExt n l, Distinct l) => NameBinder n l -> r)
  -> r
withFreshIn :: forall (n :: S) r.
Distinct n =>
Scope n
-> (forall (l :: S). (DExt n l, Distinct l) => NameBinder n l -> r)
-> r
withFreshIn Scope n
scope forall (l :: S). (DExt n l, Distinct l) => NameBinder n l -> r
k = Scope n -> (forall (l :: S). DExt n l => NameBinder n l -> r) -> r
forall (n :: S) r.
Distinct n =>
Scope n -> (forall (l :: S). DExt n l => NameBinder n l -> r) -> r
Foil.withFresh Scope n
scope NameBinder n l -> r
forall (l :: S). (DExt n l, Distinct l) => NameBinder n l -> r
forall (l :: S). DExt n l => NameBinder n l -> r
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 :: forall (n :: S).
Distinct n =>
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedTermT n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TypeCheck l (TermT l))
-> TypeCheck n (ScopedTermT n)
underScope Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval ScopedTermT n
scoped forall (l :: S).
(DExt n l, Distinct l) =>
TermT l -> TypeCheck l (TermT l)
k = do
  scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
ctxScope
  withScopedT scope scoped $ \NameBinder n l
binder AST NameBinder (AnnSig TypeInfo TermSig) l
body ->
    NameBinder n l
-> AST NameBinder (AnnSig TypeInfo TermSig) l -> ScopedTermT n
forall (binder :: S -> S -> *) (n :: S) (l :: S)
       (sig :: * -> * -> *).
binder n l -> AST binder sig l -> ScopedAST binder sig n
ScopedAST NameBinder n l
binder (AST NameBinder (AnnSig TypeInfo TermSig) l -> ScopedTermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (AST NameBinder (AnnSig TypeInfo TermSig) l)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (ScopedTermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l (AST NameBinder (AnnSig TypeInfo TermSig) l)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (AST NameBinder (AnnSig TypeInfo TermSig) l)
forall (n :: S) (l :: S) a.
(Distinct n, DExt n l) =>
NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> TypeCheck n a
underBinder NameBinder n l
binder Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval (AST NameBinder (AnnSig TypeInfo TermSig) l
-> TypeCheck l (AST NameBinder (AnnSig TypeInfo TermSig) l)
forall (l :: S).
(DExt n l, Distinct l) =>
TermT l -> TypeCheck l (TermT l)
k AST NameBinder (AnnSig TypeInfo TermSig) l
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 :: forall (n :: S).
Distinct n =>
Binder
-> TModality
-> TermT n
-> ScopedTermT n
-> ScopedTermT n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TermT l -> TypeCheck l (TermT l, TermT l))
-> TypeCheck n (ScopedTermT n, ScopedTermT n)
underScope2 Binder
orig TModality
md TermT n
ty ScopedTermT n
scoped1 ScopedTermT n
scoped2 forall (l :: S).
(DExt n l, Distinct l) =>
TermT l -> TermT l -> TypeCheck l (TermT l, TermT l)
k = do
  scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
ctxScope
  withScopedT2 scope scoped1 scoped2 $ \NameBinder n l
binder TermT l
body1 TermT l
body2 -> do
    (r1, r2) <- NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l (TermT l, TermT l)
-> TypeCheck n (TermT l, TermT l)
forall (n :: S) (l :: S) a.
(Distinct n, DExt n l) =>
NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> TypeCheck n a
underBinder NameBinder n l
binder Binder
orig TModality
md TermT n
ty Maybe (TermT n)
forall a. Maybe a
Nothing (TermT l -> TermT l -> TypeCheck l (TermT l, TermT l)
forall (l :: S).
(DExt n l, Distinct l) =>
TermT l -> TermT l -> TypeCheck l (TermT l, TermT l)
k TermT l
body1 TermT l
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 :: forall (sig :: * -> * -> *) (n :: S) a.
(Bifunctor sig, Distinct n) =>
Binder
-> TModality
-> TermT n
-> ScopedAST NameBinder sig n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    AST NameBinder sig l -> TypeCheck l a)
-> TypeCheck n a
inScope Binder
orig TModality
md TermT n
ty = Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedAST NameBinder sig n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    AST NameBinder sig l -> TypeCheck l a)
-> TypeCheck n a
forall (sig :: * -> * -> *) (n :: S) a.
(Bifunctor sig, Distinct n) =>
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedAST NameBinder sig n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    AST NameBinder sig l -> TypeCheck l a)
-> TypeCheck n a
inScopeWith Binder
orig TModality
md TermT n
ty Maybe (TermT n)
forall a. Maybe a
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 :: forall (sig :: * -> * -> *) (n :: S) a.
(Bifunctor sig, Distinct n) =>
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedAST NameBinder sig n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    AST NameBinder sig l -> TypeCheck l a)
-> TypeCheck n a
inScopeWith Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval ScopedAST NameBinder sig n
scoped forall (l :: S).
(DExt n l, Distinct l) =>
AST NameBinder sig l -> TypeCheck l a
k = do
  scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
ctxScope
  withScopedT scope scoped $ \NameBinder n l
binder AST NameBinder sig l
body ->
    NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (n :: S) (l :: S) a.
(Distinct n, DExt n l) =>
NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> TypeCheck n a
underBinder NameBinder n l
binder Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval (AST NameBinder sig l -> TypeCheck l a
forall (l :: S).
(DExt n l, Distinct l) =>
AST NameBinder sig l -> TypeCheck l a
k AST NameBinder sig l
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 :: forall (sig :: * -> * -> *) (n :: S) (l :: S).
(Bifunctor sig, DExt n l) =>
NameBinder n l
-> ScopedAST NameBinder sig n -> TypeCheck l (AST NameBinder sig l)
openScoped NameBinder n l
binder ScopedAST NameBinder sig n
scoped = do
  scope <- (Context l -> Scope l)
-> ReaderT
     (Context l)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope l)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context l -> Scope l
forall (n :: S). Context n -> Scope n
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 :: forall (n :: S).
Distinct n =>
TermT n -> TypeCheck n (ScopedTermT n)
constScope TermT n
t = do
  scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
ctxScope
  pure (Foil.withFresh scope $ \NameBinder n l
binder -> NameBinder n l
-> AST NameBinder (AnnSig TypeInfo TermSig) l -> ScopedTermT n
forall (binder :: S -> S -> *) (n :: S) (l :: S)
       (sig :: * -> * -> *).
binder n l -> AST binder sig l -> ScopedAST binder sig n
ScopedAST NameBinder n l
binder (TermT n -> AST NameBinder (AnnSig TypeInfo TermSig) l
forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
Foil.sink TermT n
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 :: forall (n :: S).
Distinct n =>
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedTerm n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    NameBinder n l -> Term l -> TypeCheck l (TermT l))
-> TypeCheck n (ScopedTermT n)
elaborateUnder Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval ScopedTerm n
scoped forall (l :: S).
(DExt n l, Distinct l) =>
NameBinder n l -> Term l -> TypeCheck l (TermT l)
k = do
  scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
ctxScope
  withScopedT scope scoped $ \NameBinder n l
binder AST NameBinder (AnnSig SrcPos TermSig) l
body ->
    NameBinder n l
-> AST NameBinder (AnnSig TypeInfo TermSig) l -> ScopedTermT n
forall (binder :: S -> S -> *) (n :: S) (l :: S)
       (sig :: * -> * -> *).
binder n l -> AST binder sig l -> ScopedAST binder sig n
ScopedAST NameBinder n l
binder (AST NameBinder (AnnSig TypeInfo TermSig) l -> ScopedTermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (AST NameBinder (AnnSig TypeInfo TermSig) l)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (ScopedTermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l (AST NameBinder (AnnSig TypeInfo TermSig) l)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (AST NameBinder (AnnSig TypeInfo TermSig) l)
forall (n :: S) (l :: S) a.
(Distinct n, DExt n l) =>
NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> TypeCheck n a
underBinder NameBinder n l
binder Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval (NameBinder n l
-> AST NameBinder (AnnSig SrcPos TermSig) l
-> TypeCheck l (AST NameBinder (AnnSig TypeInfo TermSig) l)
forall (l :: S).
(DExt n l, Distinct l) =>
NameBinder n l -> Term l -> TypeCheck l (TermT l)
k NameBinder n l
binder AST NameBinder (AnnSig SrcPos TermSig) l
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 :: forall (n :: S) a.
Distinct n =>
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedTerm n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    NameBinder n l -> Term l -> TypeCheck l a)
-> TypeCheck n a
checkUnderWith Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval ScopedTerm n
scoped forall (l :: S).
(DExt n l, Distinct l) =>
NameBinder n l -> Term l -> TypeCheck l a
k = do
  scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
ctxScope
  withScopedT scope scoped $ \NameBinder n l
binder AST NameBinder (AnnSig SrcPos TermSig) l
body ->
    NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (n :: S) (l :: S) a.
(Distinct n, DExt n l) =>
NameBinder n l
-> Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> TypeCheck l a
-> TypeCheck n a
underBinder NameBinder n l
binder Binder
orig TModality
md TermT n
ty Maybe (TermT n)
mval (NameBinder n l
-> AST NameBinder (AnnSig SrcPos TermSig) l -> TypeCheck l a
forall (l :: S).
(DExt n l, Distinct l) =>
NameBinder n l -> Term l -> TypeCheck l a
k NameBinder n l
binder AST NameBinder (AnnSig SrcPos TermSig) l
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 :: forall (n :: S) a.
Distinct n =>
Binder
-> TModality
-> TermT n
-> ScopedTerm n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    NameBinder n l -> Term l -> TypeCheck l a)
-> TypeCheck n a
checkUnder Binder
orig TModality
md TermT n
ty = Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedTerm n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    NameBinder n l -> Term l -> TypeCheck l a)
-> TypeCheck n a
forall (n :: S) a.
Distinct n =>
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedTerm n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    NameBinder n l -> Term l -> TypeCheck l a)
-> TypeCheck n a
checkUnderWith Binder
orig TModality
md TermT n
ty Maybe (TermT n)
forall a. Maybe a
Nothing

-- * Modalities

enterModality :: Distinct n => TModality -> TypeCheck n b -> TypeCheck n b
enterModality :: forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
Id TypeCheck n b
action = TypeCheck n b
action
enterModality TModality
md TypeCheck n b
action = do
  ctx <- (Context n -> Context n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Context n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (TModality -> Context n -> Context n
forall (n :: S). TModality -> Context n -> Context n
applyModality TModality
md)
  let ctx' = Context n
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 :: forall (n :: S) a.
Distinct n =>
TermT n -> TypeCheck n a -> TypeCheck n a
localTope TermT n
tope TypeCheck n a
tc = do
  ctx <- ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Context n)
ask'
  tope' <- nfTope tope
  let modalTope' = TermT n -> ModalTope n
forall (n :: S). TermT n -> ModalTope n
plainTope TermT n
tope'
  -- A small optimisation to help unify terms faster.
  let noNewInformation = case TermT n
tope' of
        TopeEQT TypeInfo (TermT n)
_ TermT n
x TermT n
y | TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
x TermT n
y -> Bool
True
        TermT n
_ -> (ModalTope n -> Bool) -> [ModalTope n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModalTope n -> ModalTope n -> Bool
forall (n :: S). Distinct n => ModalTope n -> ModalTope n -> Bool
eqModalTope ModalTope n
modalTope') (Context n -> [ModalTope n]
forall (n :: S). Context n -> [ModalTope n]
ctxTopesNF Context n
ctx)
  if noNewInformation
    then tc
    else do
      entailsBottom <- (modalTope' : ctxTopesNF ctx) `entailM` topeBottomT
      withRefreshedTopes (extend modalTope' entailsBottom) tc
  where
    ask' :: ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Context n)
ask' = (Context n -> Context n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Context n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Context n
forall a. a -> a
id
    extend :: ModalTope n -> Bool -> Context n -> Context n
extend ModalTope n
tope' Bool
entailsBottom Context n
ctx = Context n
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 :: forall (n :: S) a.
Distinct n =>
(Context n -> Context n) -> TypeCheck n a -> TypeCheck n a
withRefreshedTopes Context n -> Context n
f TypeCheck n a
action = do
  ctx' <- (Context n -> Context n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Context n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Context n
f
  let sat = case Context n
-> TypeCheck n [[ModalTope n]]
-> Either TypeErrorInScopedContext [[ModalTope n]]
forall (n :: S) a.
Context n -> TypeCheck n a -> Either TypeErrorInScopedContext a
runTypeCheckIn Context n
ctx' ([ModalTope n] -> TypeCheck n [[ModalTope n]]
forall (n :: S).
Distinct n =>
[ModalTope n] -> TypeCheck n [[ModalTope n]]
saturateForEntailment (Context n -> [ModalTope n]
forall (n :: S). Context n -> [ModalTope n]
ctxTopesNF Context n
ctx')) of
        Left TypeErrorInScopedContext
_  -> Maybe [[ModalTope n]]
forall a. Maybe a
Nothing
        Right [[ModalTope n]]
s -> [[ModalTope n]] -> Maybe [[ModalTope n]]
forall a. a -> Maybe a
Just [[ModalTope n]]
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 :: forall (n :: S).
Distinct n =>
TypeCheck n () -> TypeCheck n () -> TypeCheck n ()
inAllSubContexts TypeCheck n ()
handleSingle TypeCheck n ()
tc = do
  topeSubContexts <- (Context n -> [[ModalTope n]])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [[ModalTope n]]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> [[ModalTope n]]
forall (n :: S). Context n -> [[ModalTope n]]
ctxTopesNFUnion
  case topeSubContexts of
    []  -> String -> TypeCheck n ()
forall a. String -> a
panicImpossible String
"empty set of alternative contexts"
    [[ModalTope n]
_] -> TypeCheck n ()
handleSingle
    [ModalTope n]
_:[ModalTope n]
_:[[ModalTope n]]
_ ->
      [[ModalTope n]]
-> ([ModalTope n] -> TypeCheck n ()) -> TypeCheck n ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [[ModalTope n]]
topeSubContexts (([ModalTope n] -> TypeCheck n ()) -> TypeCheck n ())
-> ([ModalTope n] -> TypeCheck n ()) -> TypeCheck n ()
forall a b. (a -> b) -> a -> b
$ \[ModalTope n]
topes' ->
        (Context n -> Context n) -> TypeCheck n () -> TypeCheck n ()
forall (n :: S) a.
Distinct n =>
(Context n -> Context n) -> TypeCheck n a -> TypeCheck n a
withRefreshedTopes (\Context n
ctx -> Context n
ctx
            { ctxTopes = topes'
            , ctxTopesNF = topes'
            , ctxTopesNFUnion = [topes']
            }) TypeCheck n ()
tc

-- * Equality of topes

eqModalTope :: Distinct n => ModalTope n -> ModalTope n -> Bool
eqModalTope :: forall (n :: S). Distinct n => ModalTope n -> ModalTope n -> Bool
eqModalTope ModalTope n
l ModalTope n
r = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
  [ ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModAccum ModalTope n
l TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModAccum ModalTope n
r
  , ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModVar ModalTope n
l TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModVar ModalTope n
r
  , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT (ModalTope n -> TermT n
forall (n :: S). ModalTope n -> TermT n
tTope ModalTope n
l) (ModalTope n -> TermT n
forall (n :: S). ModalTope n -> TermT n
tTope ModalTope n
r)
  ]

nubModalTopes :: Distinct n => [ModalTope n] -> [ModalTope n]
nubModalTopes :: forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
nubModalTopes []       = []
nubModalTopes (ModalTope n
t : [ModalTope n]
ts) = ModalTope n
t ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
: [ModalTope n] -> [ModalTope n]
forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
nubModalTopes ((ModalTope n -> Bool) -> [ModalTope n] -> [ModalTope n]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ModalTope n -> Bool) -> ModalTope n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModalTope n -> ModalTope n -> Bool
forall (n :: S). Distinct n => ModalTope n -> ModalTope n -> Bool
eqModalTope ModalTope n
t) [ModalTope n]
ts)

elemModalTope :: Distinct n => ModalTope n -> [ModalTope n] -> Bool
elemModalTope :: forall (n :: S). Distinct n => ModalTope n -> [ModalTope n] -> Bool
elemModalTope ModalTope n
t = (ModalTope n -> Bool) -> [ModalTope n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (ModalTope n -> ModalTope n -> Bool
forall (n :: S). Distinct n => ModalTope n -> ModalTope n -> Bool
eqModalTope ModalTope n
t)

-- * Entailment

-- | Monadic 'all' that stops at the first failing element.
allM :: Monad m => (a -> m Bool) -> [a] -> m Bool
allM :: forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM a -> m Bool
p = [a] -> m Bool
go
  where
    go :: [a] -> m Bool
go []     = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    go (a
x:[a]
xs) = a -> m Bool
p a
x m Bool -> (Bool -> m Bool) -> m Bool
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Bool
True  -> [a] -> m Bool
go [a]
xs

entailM :: Distinct n => [ModalTope n] -> TermT n -> TypeCheck n Bool
entailM :: forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
entailM [ModalTope n]
modalTopes TermT n
goal = do
  saturated <- [ModalTope n] -> TypeCheck n [[ModalTope n]]
forall (n :: S).
Distinct n =>
[ModalTope n] -> TypeCheck n [[ModalTope n]]
saturateForEntailment [ModalTope n]
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 :: forall (n :: S).
Distinct n =>
[ModalTope n] -> TypeCheck n [[ModalTope n]]
saturateForEntailment [ModalTope n]
modalTopes = do
  discreteAxioms <- (Context n -> [ModalTope n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope n]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> [ModalTope n]
forall (n :: S). Context n -> [ModalTope n]
ctxDiscreteTopes
  let topes'  = [ModalTope n] -> [ModalTope n]
forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
nubModalTopes ([ModalTope n]
modalTopes [ModalTope n] -> [ModalTope n] -> [ModalTope n]
forall a. Semigroup a => a -> a -> a
<> [ModalTope n]
discreteAxioms)
      topes'' = [ModalTope n] -> [[ModalTope n]]
forall (n :: S). Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions [ModalTope n]
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 :: forall (n :: S).
Distinct n =>
[[ModalTope n]] -> TermT n -> TypeCheck n Bool
entailSaturatedM [[ModalTope n]]
saturated TermT n
goal = (Context n -> Verbosity)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Verbosity
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Verbosity
forall (n :: S). Context n -> Verbosity
ctxVerbosity ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  Verbosity
-> (Verbosity
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         Bool)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Verbosity
Debug -> do
    naming <- (Context n -> Naming n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Naming n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Naming n
forall (n :: S). Context n -> Naming n
namingOfContext
    let prettyTopes = (ModalTope n -> String) -> [ModalTope n] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map (Naming n -> Term n -> String
forall (n :: S). Naming n -> Term n -> String
ppTerm Naming n
naming (Term n -> String)
-> (ModalTope n -> Term n) -> ModalTope n -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT n -> Term n
forall (n :: S). TermT n -> Term n
untyped (TermT n -> Term n)
-> (ModalTope n -> TermT n) -> ModalTope n -> Term n
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModalTope n -> TermT n
forall (n :: S). ModalTope n -> TermT n
tTope) ([[ModalTope n]] -> [ModalTope n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[ModalTope n]]
saturated)
        prettyTope = Naming n -> Term n -> String
forall (n :: S). Naming n -> Term n -> String
ppTerm Naming n
naming (TermT n -> Term n
forall (n :: S). TermT n -> Term n
untyped TermT n
goal)
    traceTypeCheck Debug
      ("entail " <> intercalate ", " prettyTopes <> " |- " <> prettyTope) $
        allM (`solveRHSM` goal) saturated
  Verbosity
_ -> ([ModalTope n]
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      Bool)
-> [[ModalTope n]]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall (m :: * -> *) a. Monad m => (a -> m Bool) -> [a] -> m Bool
allM ([ModalTope n]
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
`solveRHSM` TermT n
goal) [[ModalTope n]]
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 :: forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
entailContextM TermT n
goal = (Context n -> CachedSaturation n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (CachedSaturation n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> CachedSaturation n
forall (n :: S). Context n -> CachedSaturation n
ctxTopesSaturated ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (CachedSaturation n)
-> (CachedSaturation n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         Bool)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  SaturationCached (Just [[ModalTope n]]
saturated) -> [[ModalTope n]]
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall (n :: S).
Distinct n =>
[[ModalTope n]] -> TermT n -> TypeCheck n Bool
entailSaturatedM [[ModalTope n]]
saturated TermT n
goal
  SaturationCached Maybe [[ModalTope n]]
Nothing          -> ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  Bool
fallback
  CachedSaturation n
SaturationUncached                -> ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  Bool
fallback
  where
    fallback :: ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  Bool
fallback = (Context n -> [ModalTope n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope n]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> [ModalTope n]
forall (n :: S). Context n -> [ModalTope n]
ctxTopesNF ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  [ModalTope n]
-> ([ModalTope n]
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         Bool)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([ModalTope n]
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
`entailM` TermT n
goal)

-- * Saturation

saturateTopes :: Distinct n => [ModalTope n] -> [ModalTope n]
saturateTopes :: forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
saturateTopes [ModalTope n]
topes = [ModalTope n]
saturated [ModalTope n] -> [ModalTope n] -> [ModalTope n]
forall a. Semigroup a => a -> a -> a
<> [ModalTope n]
inaccessible
  where
    ([ModalTope n]
accessible, [ModalTope n]
inaccessible) = [ModalTope n] -> ([ModalTope n], [ModalTope n])
forall (n :: S). [ModalTope n] -> ([ModalTope n], [ModalTope n])
partitionAccessible [ModalTope n]
topes
    saturated :: [ModalTope n]
saturated = (ModalTope n -> [ModalTope n] -> Bool)
-> ([ModalTope n] -> [ModalTope n] -> [ModalTope n])
-> [ModalTope n]
-> [ModalTope n]
forall a. (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a]
saturateWith
      ModalTope n -> [ModalTope n] -> Bool
forall (n :: S). Distinct n => ModalTope n -> [ModalTope n] -> Bool
elemModalTope
      (\[ModalTope n]
new [ModalTope n]
old -> (TermT n -> ModalTope n) -> [TermT n] -> [ModalTope n]
forall a b. (a -> b) -> [a] -> [b]
map TermT n -> ModalTope n
forall (n :: S). TermT n -> ModalTope n
plainTope ([TermT n] -> [TermT n] -> [TermT n]
forall (n :: S). Distinct n => [TermT n] -> [TermT n] -> [TermT n]
generateTopes ((ModalTope n -> TermT n) -> [ModalTope n] -> [TermT n]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope n -> TermT n
forall (n :: S). ModalTope n -> TermT n
tTope [ModalTope n]
new) ((ModalTope n -> TermT n) -> [ModalTope n] -> [TermT n]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope n -> TermT n
forall (n :: S). ModalTope n -> TermT n
tTope [ModalTope n]
old)))
      [ModalTope n]
accessible

saturateInv :: Distinct n => [ModalTope n] -> TypeCheck n [ModalTope n]
saturateInv :: forall (n :: S).
Distinct n =>
[ModalTope n] -> TypeCheck n [ModalTope n]
saturateInv [ModalTope n]
modalTopes
  -- When every tope sits at the identity modality, saturateInv adds nothing
  -- consultable: the op-inversions it would produce are tagged at 'Op' with an
  -- 'Id' lock, so 'coe Op Id = False' makes them inaccessible, and the
  -- un-inversion set 'accessibleUnderOp' is empty ('coe Id Op = False'). The
  -- op-inverted topes only become live once a modality shift puts 'Op' (or
  -- 'Sharp') into the lock, and a modal goal re-runs saturateInv on the shifted
  -- context (see the 'TypeModalT' case of 'solveRHSM'), which is where op
  -- reasoning needs them. Skipping here keeps the whole modality-free fragment
  -- (all of ordinary sHoTT) off the op-inversion machinery, which otherwise
  -- 'nfTope'-inverts every context tope on every entailment.
  | (ModalTope n -> Bool) -> [ModalTope n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ModalTope n -> Bool
forall {n :: S}. ModalTope n -> Bool
isIdentityTope [ModalTope n]
modalTopes = [ModalTope n]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope n]
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return [ModalTope n]
modalTopes
  | Bool
otherwise = 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 :: [ModalTope n]
accessible = [ModalTope n] -> [ModalTope n]
forall (n :: S). [ModalTope n] -> [ModalTope n]
filterAccessible [ModalTope n]
modalTopes
        accessibleById :: [ModalTope n]
accessibleById = (ModalTope n -> Bool) -> [ModalTope n] -> [ModalTope n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModalTope n
mt -> TModality -> TModality -> Bool
forall m. ModeTheory m => m -> m -> Bool
coe (ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModVar ModalTope n
mt) TModality
Id) [ModalTope n]
modalTopes
    invResults <- [ModalTope n]
-> (ModalTope n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (ModalTope n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope n]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([ModalTope n] -> [ModalTope n]
forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
nubModalTopes ([ModalTope n]
accessible [ModalTope n] -> [ModalTope n] -> [ModalTope n]
forall a. Semigroup a => a -> a -> a
<> [ModalTope n]
accessibleById)) ((ModalTope n
  -> ReaderT
       (Context n)
       (ExceptT TypeErrorInScopedContext (State CheckLog))
       (ModalTope n))
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      [ModalTope n])
-> (ModalTope n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (ModalTope n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope n]
forall a b. (a -> b) -> a -> b
$ \ModalTope n
mt -> do
      nf <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope (TermT n -> TypeCheck n (TermT n))
-> TermT n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TModality -> TModality -> TermT n -> TermT n
forall (n :: S).
TermT n -> TModality -> TModality -> TermT n -> TermT n
modExtractT TermT n
forall (n :: S). TermT n
topeT TModality
Id TModality
Op (TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeInvT (ModalTope n -> TermT n
forall (n :: S). ModalTope n -> TermT n
tTope ModalTope n
mt))
      return $ ModalTope (tModAccum mt) Op nf
    let accessibleUnderOp =
          (ModalTope n -> Bool) -> [ModalTope n] -> [ModalTope n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModalTope n
mt -> TModality -> TModality -> Bool
forall m. ModeTheory m => m -> m -> Bool
coe (ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModVar ModalTope n
mt) (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp (ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModAccum ModalTope n
mt) TModality
Op)) [ModalTope n]
modalTopes
    uninvResults <- forM accessibleUnderOp $ \(ModalTope TModality
acc TModality
var' TermT n
phi) -> do
      nf <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope (TermT n -> TypeCheck n (TermT n))
-> TermT n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeUninvT (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT TermT n
forall (n :: S). TermT n
topeT TModality
Op TermT n
phi)
      return $ ModalTope (comp acc Op) var' nf
    let newTopes = [ModalTope n] -> [ModalTope n]
forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
nubModalTopes ([ModalTope n]
invResults [ModalTope n] -> [ModalTope n] -> [ModalTope n]
forall a. Semigroup a => a -> a -> a
<> [ModalTope n]
uninvResults)
        fresh = (ModalTope n -> Bool) -> [ModalTope n] -> [ModalTope n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModalTope n
t -> Bool -> Bool
not (ModalTope n -> [ModalTope n] -> Bool
forall (n :: S). Distinct n => ModalTope n -> [ModalTope n] -> Bool
elemModalTope ModalTope n
t [ModalTope n]
modalTopes)) [ModalTope n]
newTopes
    return (modalTopes <> fresh)
  where
    isIdentityTope :: ModalTope n -> Bool
isIdentityTope ModalTope n
mt = ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModVar ModalTope n
mt TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
Id Bool -> Bool -> Bool
&& ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModAccum ModalTope n
mt TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
Id

-- | 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 :: forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
saturateBottom [ModalTope n]
modalTopes
  | [TModality] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [TModality]
droppedAccums = [ModalTope n]
modalTopes  -- nothing hidden by a lock
  | Bool
botDerivable       = [ModalTope n]
modalTopes [ModalTope n] -> [ModalTope n] -> [ModalTope n]
forall a. Semigroup a => a -> a -> a
<> [ModalTope n]
fresh
  | Bool
otherwise          = [ModalTope n]
modalTopes
  where
    idAccessible :: [ModalTope n]
idAccessible  = (ModalTope n -> Bool) -> [ModalTope n] -> [ModalTope n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\ModalTope n
mt -> TModality -> TModality -> Bool
forall m. ModeTheory m => m -> m -> Bool
coe (ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModVar ModalTope n
mt) TModality
Id) [ModalTope n]
modalTopes
    droppedAccums :: [TModality]
droppedAccums = [TModality] -> [TModality]
forall a. Eq a => [a] -> [a]
nub [ ModalTope n -> TModality
forall (n :: S). ModalTope n -> TModality
tModAccum ModalTope n
mt | ModalTope n
mt <- [ModalTope n]
idAccessible, Bool -> Bool
not (ModalTope n -> Bool
forall {n :: S}. ModalTope n -> Bool
isAccessible ModalTope n
mt) ]
    saturatedId :: [TermT n]
saturatedId   = (TermT n -> [TermT n] -> Bool)
-> ([TermT n] -> [TermT n] -> [TermT n]) -> [TermT n] -> [TermT n]
forall a. (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a]
saturateWith TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
elemT [TermT n] -> [TermT n] -> [TermT n]
forall (n :: S). Distinct n => [TermT n] -> [TermT n] -> [TermT n]
generateTopes ((ModalTope n -> TermT n) -> [ModalTope n] -> [TermT n]
forall a b. (a -> b) -> [a] -> [b]
map ModalTope n -> TermT n
forall (n :: S). ModalTope n -> TermT n
tTope [ModalTope n]
idAccessible)
    botDerivable :: Bool
botDerivable  = TermT n
forall (n :: S). TermT n
topeBottomT TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
saturatedId
    fresh :: [ModalTope n]
fresh = [ ModalTope n
mt
            | TModality
acc <- [TModality]
droppedAccums
            , let mt :: ModalTope n
mt = TModality -> TModality -> TermT n -> ModalTope n
forall (n :: S). TModality -> TModality -> TermT n -> ModalTope n
ModalTope TModality
acc TModality
acc TermT n
forall (n :: S). TermT n
topeBottomT
            , Bool -> Bool
not (ModalTope n -> [ModalTope n] -> Bool
forall (n :: S). Distinct n => ModalTope n -> [ModalTope n] -> Bool
elemModalTope ModalTope n
mt [ModalTope n]
modalTopes) ]

-- FIXME: cleanup
saturateWith :: (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a]
saturateWith :: forall a. (a -> [a] -> Bool) -> ([a] -> [a] -> [a]) -> [a] -> [a]
saturateWith a -> [a] -> Bool
elem' [a] -> [a] -> [a]
step [a]
zs = [a] -> [a] -> [a]
go ([a] -> [a]
nub' [a]
zs) []
  where
    go :: [a] -> [a] -> [a]
go [a]
lastNew [a]
xs
      | [a] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [a]
new = [a]
lastNew
      | Bool
otherwise = [a]
lastNew [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a] -> [a] -> [a]
go [a]
new [a]
xs'
      where
        xs' :: [a]
xs' = [a]
lastNew [a] -> [a] -> [a]
forall a. Semigroup a => a -> a -> a
<> [a]
xs
        new :: [a]
new = (a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> Bool
`elem'` [a]
xs')) ([a] -> [a]
nub' ([a] -> [a]) -> [a] -> [a]
forall a b. (a -> b) -> a -> b
$ [a] -> [a] -> [a]
step [a]
lastNew [a]
xs)
    nub' :: [a] -> [a]
nub' []     = []
    nub' (a
x:[a]
xs) = a
x a -> [a] -> [a]
forall a. a -> [a] -> [a]
: [a] -> [a]
nub' ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (a -> Bool) -> a -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a -> [a] -> Bool
`elem'` [a
x])) [a]
xs)

generateTopes :: Distinct n => [TermT n] -> [TermT n] -> [TermT n]
generateTopes :: forall (n :: S). Distinct n => [TermT n] -> [TermT n] -> [TermT n]
generateTopes [TermT n]
newTopes [TermT n]
oldTopes
  | TermT n
forall (n :: S). TermT n
topeBottomT TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
newTopes = []
  | TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
forall (n :: S). TermT n
cube2_0T TermT n
forall (n :: S). TermT n
cube2_1T TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
newTopes = [TermT n
forall (n :: S). TermT n
topeBottomT]
  | TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
forall (n :: S). TermT n
cubeI_0T TermT n
forall (n :: S). TermT n
cubeI_1T TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
newTopes = [TermT n
forall (n :: S). TermT n
topeBottomT]
  | [TermT n] -> Id
forall a. [a] -> Id
forall (t :: * -> *) a. Foldable t => t a -> Id
length [TermT n]
oldTopes Id -> Id -> Bool
forall a. Ord a => a -> a -> Bool
> Id
100 = []    -- FIXME
  | Bool
otherwise = [[TermT n]] -> [TermT n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
      [  -- symmetry EQ
        [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
y TermT n
x | TopeEQT TypeInfo (TermT n)
_ty TermT n
x TermT n
y <- [TermT n]
newTopes ]
        -- transitivity EQ (1)
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
z
        | TopeEQT TypeInfo (TermT n)
_ty TermT n
x TermT n
y : [TermT n]
newTopes' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails [TermT n]
newTopes
        , TopeEQT TypeInfo (TermT n)
_ty TermT n
y' TermT n
z <- [TermT n]
newTopes' [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> [TermT n]
oldTopes
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y' ]
        -- transitivity EQ (2)
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
z
        | TopeEQT TypeInfo (TermT n)
_ty TermT n
y TermT n
z : [TermT n]
newTopes' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails [TermT n]
newTopes
        , TopeEQT TypeInfo (TermT n)
_ty TermT n
x TermT n
y' <- [TermT n]
newTopes' [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> [TermT n]
oldTopes
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y' ]

        -- transitivity LEQ (1)
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
z
        | TopeLEQT TypeInfo (TermT n)
_ty TermT n
x TermT n
y : [TermT n]
newTopes' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails [TermT n]
newTopes
        , TopeLEQT TypeInfo (TermT n)
_ty TermT n
y' TermT n
z <- [TermT n]
newTopes' [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> [TermT n]
oldTopes
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y' ]
        -- transitivity LEQ (2)
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
z
        | TopeLEQT TypeInfo (TermT n)
_ty TermT n
y TermT n
z : [TermT n]
newTopes' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails [TermT n]
newTopes
        , TopeLEQT TypeInfo (TermT n)
_ty TermT n
x TermT n
y' <- [TermT n]
newTopes' [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> [TermT n]
oldTopes
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y' ]

        -- antisymmetry LEQ
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
y
        | TopeLEQT TypeInfo (TermT n)
_ty TermT n
x TermT n
y : [TermT n]
newTopes' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails [TermT n]
newTopes
        , TopeLEQT TypeInfo (TermT n)
_ty TermT n
y' TermT n
x' <- [TermT n]
newTopes' [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> [TermT n]
oldTopes
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y'
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
x TermT n
x' ]

        -- FIXME: special case of substitution of EQ
        -- transitivity EQ-LEQ (1)
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
z
        | TopeEQT  TypeInfo (TermT n)
_ty TermT n
y TermT n
z : [TermT n]
newTopes' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails [TermT n]
newTopes
        , TopeLEQT TypeInfo (TermT n)
_ty TermT n
x TermT n
y' <- [TermT n]
newTopes' [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> [TermT n]
oldTopes
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y' ]

        -- transitivity EQ-LEQ (2)
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
z
        | TopeEQT  TypeInfo (TermT n)
_ty TermT n
x TermT n
y : [TermT n]
newTopes' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails [TermT n]
newTopes
        , TopeLEQT TypeInfo (TermT n)
_ty TermT n
y' TermT n
z <- [TermT n]
newTopes' [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> [TermT n]
oldTopes
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y' ]

        -- transitivity EQ-LEQ (3)
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
z
        | TopeLEQT  TypeInfo (TermT n)
_ty TermT n
y TermT n
z : [TermT n]
newTopes' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails [TermT n]
newTopes
        , TopeEQT TypeInfo (TermT n)
_ty TermT n
x TermT n
y' <- [TermT n]
newTopes' [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> [TermT n]
oldTopes
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y' ]

        -- transitivity EQ-LEQ (4)
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
z
        | TopeLEQT  TypeInfo (TermT n)
_ty TermT n
x TermT n
y : [TermT n]
newTopes' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails [TermT n]
newTopes
        , TopeEQT TypeInfo (TermT n)
_ty TermT n
y' TermT n
z <- [TermT n]
newTopes' [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> [TermT n]
oldTopes
        , TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y' ]

        -- FIXME: consequence of LEM for LEQ and antisymmetry for LEQ
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
y | TopeLEQT TypeInfo (TermT n)
_ty TermT n
x y :: TermT n
y@Cube2_0T{} <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
y | TopeLEQT TypeInfo (TermT n)
_ty x :: TermT n
x@Cube2_1T{} TermT n
y <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
y | TopeLEQT TypeInfo (TermT n)
_ty TermT n
x y :: TermT n
y@CubeI_0T{} <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
y | TopeLEQT TypeInfo (TermT n)
_ty x :: TermT n
x@CubeI_1T{} TermT n
y <- [TermT n]
newTopes ]

        -- subtyping 2 <: II: endpoints and order of 2 lift to II
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
forall (n :: S). TermT n
cubeI_0T | TopeEQT TypeInfo (TermT n)
_ty TermT n
x Cube2_0T{} <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
forall (n :: S). TermT n
cubeI_0T TermT n
x | TopeEQT TypeInfo (TermT n)
_ty Cube2_0T{} TermT n
x <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
forall (n :: S). TermT n
cubeI_1T | TopeEQT TypeInfo (TermT n)
_ty TermT n
x Cube2_1T{} <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
forall (n :: S). TermT n
cubeI_1T TermT n
x | TopeEQT TypeInfo (TermT n)
_ty Cube2_1T{} TermT n
x <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
forall (n :: S). TermT n
cubeI_0T | TopeLEQT TypeInfo (TermT n)
_ty TermT n
x Cube2_0T{} <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
forall (n :: S). TermT n
cubeI_0T TermT n
x | TopeLEQT TypeInfo (TermT n)
_ty Cube2_0T{} TermT n
x <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
forall (n :: S). TermT n
cubeI_1T | TopeLEQT TypeInfo (TermT n)
_ty TermT n
x Cube2_1T{} <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
forall (n :: S). TermT n
cubeI_1T TermT n
x | TopeLEQT TypeInfo (TermT n)
_ty Cube2_1T{} TermT n
x <- [TermT n]
newTopes ]

      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
a TermT n
c | TopeLEQT TypeInfo (TermT n)
_ty (CubeSupT TypeInfo (TermT n)
_ TermT n
a TermT n
_) TermT n
c <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
b TermT n
c | TopeLEQT TypeInfo (TermT n)
_ty (CubeSupT TypeInfo (TermT n)
_ TermT n
_ TermT n
b) TermT n
c <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
c TermT n
a | TopeLEQT TypeInfo (TermT n)
_ty TermT n
c (CubeInfT TypeInfo (TermT n)
_ TermT n
a TermT n
_) <- [TermT n]
newTopes ]
      , [ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
c TermT n
b | TopeLEQT TypeInfo (TermT n)
_ty TermT n
c (CubeInfT TypeInfo (TermT n)
_ TermT n
_ TermT n
b) <- [TermT n]
newTopes ]

      -- Turn an equality into the two inequalities, but only when a side is a
      -- lattice term, so it can feed the sup/inf extraction rules above (e.g.
      -- @sup s u ≡ t@ ⊢ @sup s u ≤ t@ ⊢ @s ≤ t@). Gating on a lattice operand
      -- keeps this off the equality-heavy non-lattice fragment (extension-type
      -- faces), where the direct @solveRHS (topeEQT l r)@ guard already proves
      -- @l ≤ r@ from @l ≡ r@ and the extra topes would only bloat saturation.
      , [ TermT n
leq
        | TopeEQT TypeInfo (TermT n)
_ty TermT n
x TermT n
y <- [TermT n]
newTopes
        , TermT n -> Bool
forall (n :: S). TermT n -> Bool
isLatticePoint TermT n
x Bool -> Bool -> Bool
|| TermT n -> Bool
forall (n :: S). TermT n -> Bool
isLatticePoint TermT n
y
        , TermT n
leq <- [TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
y, TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
y TermT n
x] ]
      ]

-- | Is this cube point a lattice term (a @sup@ or @inf@)? Used to keep the
-- lattice-specific solver work (equality-to-order generation, the
-- antisymmetry fallback for equality goals) off the equality-heavy
-- non-lattice fragment, where it would only cost time without proving
-- anything new.
isLatticePoint :: TermT n -> Bool
isLatticePoint :: forall (n :: S). TermT n -> Bool
isLatticePoint CubeSupT{} = Bool
True
isLatticePoint CubeInfT{} = Bool
True
isLatticePoint AST NameBinder (AnnSig TypeInfo TermSig) n
_          = Bool
False

generateTopesForPointsM :: Distinct n => [TermT n] -> TypeCheck n [TermT n]
generateTopesForPointsM :: forall (n :: S). Distinct n => [TermT n] -> TypeCheck n [TermT n]
generateTopesForPointsM [TermT n]
points = do
  let endpoints :: [TermT n]
endpoints = [TermT n
forall (n :: S). TermT n
cube2_0T, TermT n
forall (n :: S). TermT n
cube2_1T, TermT n
forall (n :: S). TermT n
cubeI_0T, TermT n
forall (n :: S). TermT n
cubeI_1T]
      pairs :: [(TermT n, TermT n)]
pairs = [(TermT n, TermT n)] -> [(TermT n, TermT n)]
forall {n :: S} {n :: S}.
(Distinct n, Distinct n) =>
[(TermT n, TermT n)] -> [(TermT n, TermT n)]
nubPairs ([(TermT n, TermT n)] -> [(TermT n, TermT n)])
-> [(TermT n, TermT n)] -> [(TermT n, TermT n)]
forall a b. (a -> b) -> a -> b
$ [[(TermT n, TermT n)]] -> [(TermT n, TermT n)]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat
        [ [ (TermT n
x, TermT n
y)
          | TermT n
x : [TermT n]
points' <- [TermT n] -> [[TermT n]]
forall a. [a] -> [[a]]
tails ((TermT n -> Bool) -> [TermT n] -> [TermT n]
forall a. (a -> Bool) -> [a] -> [a]
filter (\TermT n
p -> Bool -> Bool
not (TermT n
p TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
forall {n :: S}. [TermT n]
endpoints)) [TermT n]
points)
          , TermT n
y <- [TermT n]
points'
          , Bool -> Bool
not (TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
x TermT n
y) ]
        ]
  stars <- [TermT n]
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [[TermT n]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [TermT n]
points ((TermT n
  -> ReaderT
       (Context n)
       (ExceptT TypeErrorInScopedContext (State CheckLog))
       [TermT n])
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      [[TermT n]])
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [[TermT n]]
forall a b. (a -> b) -> a -> b
$ \TermT n
x -> do
    xType <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
x
    return $ case xType of
      CubeUnitT{} -> [TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
forall (n :: S). TermT n
cubeUnitStarT]
      TermT n
_           -> []
  topes <- forM pairs $ \(TermT n
x, TermT n
y) -> do
    xType <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
x
    yType <- typeOf y
    return $ case (xType, yType) of
      (Cube2T{}, Cube2T{}) -> [TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeOrT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
y) (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
y TermT n
x)]
      (TermT n, TermT n)
_                    -> []
  return (concat (topes ++ stars))
  where
    nubPairs :: [(TermT n, TermT n)] -> [(TermT n, TermT n)]
nubPairs [] = []
    nubPairs (p :: (TermT n, TermT n)
p@(TermT n
x, TermT n
y) : [(TermT n, TermT n)]
ps) =
      (TermT n, TermT n)
p (TermT n, TermT n) -> [(TermT n, TermT n)] -> [(TermT n, TermT n)]
forall a. a -> [a] -> [a]
: [(TermT n, TermT n)] -> [(TermT n, TermT n)]
nubPairs (((TermT n, TermT n) -> Bool)
-> [(TermT n, TermT n)] -> [(TermT n, TermT n)]
forall a. (a -> Bool) -> [a] -> [a]
filter (\(TermT n
x', TermT n
y') -> Bool -> Bool
not (TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
x TermT n
x' Bool -> Bool -> Bool
&& TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
y TermT n
y')) [(TermT n, TermT n)]
ps)

allTopePoints :: Distinct n => TermT n -> [TermT n]
allTopePoints :: forall (n :: S). Distinct n => TermT n -> [TermT n]
allTopePoints = [TermT n] -> [TermT n]
forall (n :: S). Distinct n => [TermT n] -> [TermT n]
nubT ([TermT n] -> [TermT n])
-> (TermT n -> [TermT n]) -> TermT n -> [TermT n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TermT n -> [TermT n]) -> [TermT n] -> [TermT n]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TermT n -> [TermT n]
forall (n :: S). TermT n -> [TermT n]
subPoints ([TermT n] -> [TermT n])
-> (TermT n -> [TermT n]) -> TermT n -> [TermT n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TermT n] -> [TermT n]
forall (n :: S). Distinct n => [TermT n] -> [TermT n]
nubT ([TermT n] -> [TermT n])
-> (TermT n -> [TermT n]) -> TermT n -> [TermT n]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT n -> [TermT n]
forall (n :: S). TermT n -> [TermT n]
topePoints

topePoints :: TermT n -> [TermT n]
topePoints :: forall (n :: S). TermT n -> [TermT n]
topePoints = \case
  TopeTopT{}     -> []
  TopeBottomT{}  -> []
  TopeAndT TypeInfo (TermT n)
_ TermT n
l TermT n
r -> TermT n -> [TermT n]
forall (n :: S). TermT n -> [TermT n]
topePoints TermT n
l [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> TermT n -> [TermT n]
forall (n :: S). TermT n -> [TermT n]
topePoints TermT n
r
  TopeOrT  TypeInfo (TermT n)
_ TermT n
l TermT n
r -> TermT n -> [TermT n]
forall (n :: S). TermT n -> [TermT n]
topePoints TermT n
l [TermT n] -> [TermT n] -> [TermT n]
forall a. Semigroup a => a -> a -> a
<> TermT n -> [TermT n]
forall (n :: S). TermT n -> [TermT n]
topePoints TermT n
r
  TopeEQT  TypeInfo (TermT n)
_ TermT n
x TermT n
y -> [TermT n
x, TermT n
y]
  TopeLEQT TypeInfo (TermT n)
_ TermT n
x TermT n
y -> [TermT n
x, TermT n
y]
  TermT n
_              -> []

subPoints :: TermT n -> [TermT n]
subPoints :: forall (n :: S). TermT n -> [TermT n]
subPoints = \case
  p :: TermT n
p@(PairT TypeInfo (TermT n)
_ TermT n
x TermT n
y) -> TermT n
p TermT n -> [TermT n] -> [TermT n]
forall a. a -> [a] -> [a]
: (TermT n -> [TermT n]) -> [TermT n] -> [TermT n]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap TermT n -> [TermT n]
forall (n :: S). TermT n -> [TermT n]
subPoints [TermT n
x, TermT n
y]
  p :: TermT n
p@(Var Name n
_)       -> [TermT n
p]
  TermT n
p -> case TermT n -> Maybe (TypeInfo (TermT n))
forall (n :: S). TermT n -> Maybe (TypeInfo (TermT n))
typeInfoOf TermT n
p of
    Just TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = CubeUnitT{} } -> [TermT n
p]
    Just TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = Cube2T{} }    -> [TermT n
p]
    Maybe (TypeInfo (TermT n))
_                                       -> []

-- * Simplifying the left-hand side

-- | Simplify the context, including disjunctions.
simplifyLHSwithDisjunctions :: Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions :: forall (n :: S). Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions [ModalTope n]
topes = ([ModalTope n] -> [ModalTope n])
-> [[ModalTope n]] -> [[ModalTope n]]
forall a b. (a -> b) -> [a] -> [b]
map [ModalTope n] -> [ModalTope n]
forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
nubModalTopes ([[ModalTope n]] -> [[ModalTope n]])
-> [[ModalTope n]] -> [[ModalTope n]]
forall a b. (a -> b) -> a -> b
$
  case [ModalTope n]
topes of
    [] -> [[]]
    ModalTope TModality
_ TModality
_ TopeTopT{} : [ModalTope n]
topes' -> [ModalTope n] -> [[ModalTope n]]
forall (n :: S). Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions [ModalTope n]
topes'
    ModalTope TModality
mAcc TModality
mVar TopeBottomT{} : [ModalTope n]
_ -> [[TModality
-> TModality
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> ModalTope n
forall (n :: S). TModality -> TModality -> TermT n -> ModalTope n
ModalTope TModality
mAcc TModality
mVar AST NameBinder (AnnSig TypeInfo TermSig) n
forall (n :: S). TermT n
topeBottomT]]
    ModalTope TModality
mAcc TModality
mVar (TopeAndT TypeInfo (AST NameBinder (AnnSig TypeInfo TermSig) n)
_ AST NameBinder (AnnSig TypeInfo TermSig) n
l AST NameBinder (AnnSig TypeInfo TermSig) n
r) : [ModalTope n]
topes' ->
      [ModalTope n] -> [[ModalTope n]]
forall (n :: S). Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions (TModality
-> TModality
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> ModalTope n
forall (n :: S). TModality -> TModality -> TermT n -> ModalTope n
ModalTope TModality
mAcc TModality
mVar AST NameBinder (AnnSig TypeInfo TermSig) n
l ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
: TModality
-> TModality
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> ModalTope n
forall (n :: S). TModality -> TModality -> TermT n -> ModalTope n
ModalTope TModality
mAcc TModality
mVar AST NameBinder (AnnSig TypeInfo TermSig) n
r ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
: [ModalTope n]
topes')

    -- NOTE: it is inefficient to expand disjunctions immediately
    ModalTope TModality
mAcc TModality
mVar (TopeOrT TypeInfo (AST NameBinder (AnnSig TypeInfo TermSig) n)
_ AST NameBinder (AnnSig TypeInfo TermSig) n
l AST NameBinder (AnnSig TypeInfo TermSig) n
r) : [ModalTope n]
topes' ->
      [ModalTope n] -> [[ModalTope n]]
forall (n :: S). Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions (TModality
-> TModality
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> ModalTope n
forall (n :: S). TModality -> TModality -> TermT n -> ModalTope n
ModalTope TModality
mAcc TModality
mVar AST NameBinder (AnnSig TypeInfo TermSig) n
l ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
: [ModalTope n]
topes')
        [[ModalTope n]] -> [[ModalTope n]] -> [[ModalTope n]]
forall a. Semigroup a => a -> a -> a
<> [ModalTope n] -> [[ModalTope n]]
forall (n :: S). Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions (TModality
-> TModality
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> ModalTope n
forall (n :: S). TModality -> TModality -> TermT n -> ModalTope n
ModalTope TModality
mAcc TModality
mVar AST NameBinder (AnnSig TypeInfo TermSig) n
r ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
: [ModalTope n]
topes')

    ModalTope TModality
mAcc TModality
mVar (TopeEQT TypeInfo (AST NameBinder (AnnSig TypeInfo TermSig) n)
_ (PairT TypeInfo (AST NameBinder (AnnSig TypeInfo TermSig) n)
_ AST NameBinder (AnnSig TypeInfo TermSig) n
x AST NameBinder (AnnSig TypeInfo TermSig) n
y) (PairT TypeInfo (AST NameBinder (AnnSig TypeInfo TermSig) n)
_ AST NameBinder (AnnSig TypeInfo TermSig) n
x' AST NameBinder (AnnSig TypeInfo TermSig) n
y')) : [ModalTope n]
topes' ->
      [ModalTope n] -> [[ModalTope n]]
forall (n :: S). Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions
        (TModality
-> TModality
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> ModalTope n
forall (n :: S). TModality -> TModality -> TermT n -> ModalTope n
ModalTope TModality
mAcc TModality
mVar (AST NameBinder (AnnSig TypeInfo TermSig) n
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> AST NameBinder (AnnSig TypeInfo TermSig) n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT AST NameBinder (AnnSig TypeInfo TermSig) n
x AST NameBinder (AnnSig TypeInfo TermSig) n
x') ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
: TModality
-> TModality
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> ModalTope n
forall (n :: S). TModality -> TModality -> TermT n -> ModalTope n
ModalTope TModality
mAcc TModality
mVar (AST NameBinder (AnnSig TypeInfo TermSig) n
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> AST NameBinder (AnnSig TypeInfo TermSig) n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT AST NameBinder (AnnSig TypeInfo TermSig) n
y AST NameBinder (AnnSig TypeInfo TermSig) n
y') ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
: [ModalTope n]
topes')
    ModalTope TModality
mAcc TModality
mVar (TypeModalT TypeInfo (AST NameBinder (AnnSig TypeInfo TermSig) n)
_ TModality
md AST NameBinder (AnnSig TypeInfo TermSig) n
inTope) : [ModalTope n]
topes' ->
      [ModalTope n] -> [[ModalTope n]]
forall (n :: S). Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions (TModality
-> TModality
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> ModalTope n
forall (n :: S). TModality -> TModality -> TermT n -> ModalTope n
ModalTope TModality
mAcc (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
mVar TModality
md) AST NameBinder (AnnSig TypeInfo TermSig) n
inTope ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
: [ModalTope n]
topes')
    ModalTope n
t : [ModalTope n]
topes' -> ([ModalTope n] -> [ModalTope n])
-> [[ModalTope n]] -> [[ModalTope n]]
forall a b. (a -> b) -> [a] -> [b]
map (ModalTope n
t ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
:) ([ModalTope n] -> [[ModalTope n]]
forall (n :: S). Distinct n => [ModalTope n] -> [[ModalTope n]]
simplifyLHSwithDisjunctions [ModalTope n]
topes')

-- * Solving the right-hand side

solveRHSM :: Distinct n => [ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM :: forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes TermT n
goal =
  let topes :: [TermT n]
topes = [ModalTope n] -> [TermT n]
forall (n :: S). [ModalTope n] -> [TermT n]
accessibleTopes [ModalTope n]
modalTopes
  in case TermT n
goal of
    TermT n
_ | TermT n
forall (n :: S). TermT n
topeBottomT TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
topes -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeTopT{}     -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TypeModalT TypeInfo (TermT n)
_ty TModality
md TermT n
inTope -> do
      let shifted :: [ModalTope n]
shifted = TModality -> [ModalTope n] -> [ModalTope n]
forall (n :: S). TModality -> [ModalTope n] -> [ModalTope n]
applyModalityToTopes TModality
md [ModalTope n]
modalTopes
          resaturated :: [ModalTope n]
resaturated = [ModalTope n] -> [ModalTope n]
forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
saturateTopes [ModalTope n]
shifted
      resaturatedInv <- [ModalTope n] -> TypeCheck n [ModalTope n]
forall (n :: S).
Distinct n =>
[ModalTope n] -> TypeCheck n [ModalTope n]
saturateInv [ModalTope n]
resaturated
      solveRHSM resaturatedInv inTope
    TopeEQT  TypeInfo (TermT n)
_ty (PairT TypeInfo (TermT n)
_ty1 TermT n
x TermT n
y) (PairT TypeInfo (TermT n)
_ty2 TermT n
x' TermT n
y') ->
      [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes (TermT n -> TypeCheck n Bool) -> TermT n -> TypeCheck n Bool
forall a b. (a -> b) -> a -> b
$ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeAndT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
x') (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
y TermT n
y')
    TopeEQT  TypeInfo (TermT n)
_ty (PairT TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = CubeProductT TypeInfo (TermT n)
_ TermT n
cubeI TermT n
cubeJ } TermT n
x TermT n
y) TermT n
r ->
      [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes (TermT n -> TypeCheck n Bool) -> TermT n -> TypeCheck n Bool
forall a b. (a -> b) -> a -> b
$ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeAndT
        (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
firstT TermT n
cubeI TermT n
r))
        (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
y (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
secondT TermT n
cubeJ TermT n
r))
    TopeEQT  TypeInfo (TermT n)
_ty TermT n
l (PairT TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = CubeProductT TypeInfo (TermT n)
_ TermT n
cubeI TermT n
cubeJ } TermT n
x TermT n
y) ->
      [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes (TermT n -> TypeCheck n Bool) -> TermT n -> TypeCheck n Bool
forall a b. (a -> b) -> a -> b
$ TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeAndT
        (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
firstT TermT n
cubeI TermT n
l) TermT n
x)
        (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
secondT TermT n
cubeJ TermT n
l) TermT n
y)
    TopeEQT  TypeInfo (TermT n)
_ty Cube2_0T{} CubeI_0T{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty CubeI_0T{} Cube2_0T{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty Cube2_1T{} CubeI_1T{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty CubeI_1T{} Cube2_1T{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty TermT n
l TermT n
r -> do
      let old :: Bool
old = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
            [ TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
l TermT n
r
            , TermT n
goal TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
topes
            , TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
r TermT n
l TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
topes
            ]
      if Bool
old
        then Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        else do
          lType <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
l
          rType <- typeOf r
          case (lType, rType) of
            (CubeUnitT{}, CubeUnitT{}) -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
            -- Antisymmetry: prove @l ≡ r@ from @l ≤ r ∧ r ≤ l@. Only worth
            -- trying when a side is a lattice term (the law goals like
            -- @sup a b ≡ sup b a@); on the non-lattice fragment this cannot
            -- prove anything the @old@ check above did not, so we skip it to
            -- leave ordinary sHoTT solving unchanged from before the lattice.
            (TermT n, TermT n)
_ | TermT n -> Bool
forall (n :: S). TermT n -> Bool
isLatticePoint TermT n
l Bool -> Bool -> Bool
|| TermT n -> Bool
forall (n :: S). TermT n -> Bool
isLatticePoint TermT n
r ->
                  [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeAndT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
l TermT n
r) (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
r TermT n
l))
            (TermT n, TermT n)
_ -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    TopeLEQT TypeInfo (TermT n)
_ty TermT n
l TermT n
r
      | TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
l TermT n
r -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | TermT n
goal TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
topes -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
l TermT n
r) -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
l TermT n
forall (n :: S). TermT n
cube2_0T) -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      | [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
r TermT n
forall (n :: S). TermT n
cube2_1T) -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeLEQT TypeInfo (TermT n)
_ty (CubeSupT TypeInfo (TermT n)
_ TermT n
a TermT n
b) TermT n
r ->
      [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeAndT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
a TermT n
r) (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
b TermT n
r))
    TopeLEQT TypeInfo (TermT n)
_ty TermT n
l (CubeInfT TypeInfo (TermT n)
_ TermT n
a TermT n
b) ->
      [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeAndT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
l TermT n
a) (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
l TermT n
b))
    TopeLEQT TypeInfo (TermT n)
_ty TermT n
l (CubeSupT TypeInfo (TermT n)
_ TermT n
a TermT n
b) ->
      [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeOrT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
l TermT n
a) (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
l TermT n
b))
    TopeLEQT TypeInfo (TermT n)
_ty (CubeInfT TypeInfo (TermT n)
_ TermT n
a TermT n
b) TermT n
r ->
      [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeOrT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
a TermT n
r) (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
b TermT n
r))
    TopeAndT TypeInfo (TermT n)
_ TermT n
l TermT n
r -> [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes TermT n
l TypeCheck n Bool -> (Bool -> TypeCheck n Bool) -> TypeCheck n Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
False -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Bool
True  -> [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes TermT n
r
    TermT n
_ | TermT n
goal TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
topes -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
    TopeInvT{} -> do
      goal' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
goal
      case goal' of
        TopeInvT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        TermT n
_          -> [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes TermT n
goal'
    TopeUninvT{} -> do
      goal' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
goal
      case goal' of
        TopeUninvT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        TermT n
_            -> [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes TermT n
goal'
    TopeOrT  TypeInfo (TermT n)
_ TermT n
l TermT n
r -> do
      found <- [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes TermT n
l TypeCheck n Bool -> (Bool -> TypeCheck n Bool) -> TypeCheck n Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Bool
True  -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        Bool
False -> [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM [ModalTope n]
modalTopes TermT n
r
      if found
        then return True
        else do
          lems <- generateTopesForPointsM (allTopePoints goal)
          let lems' = [ TermT n
lem | lem :: TermT n
lem@(TopeOrT TypeInfo (TermT n)
_ TermT n
t1 TermT n
t2) <- [TermT n]
lems, (TermT n -> Bool) -> [TermT n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`notElemT` [TermT n]
topes) [TermT n
t1, TermT n
t2] ]
              (accessible, hidden) = partitionAccessible modalTopes
              withTope TermT n
t = [ModalTope n]
hidden [ModalTope n] -> [ModalTope n] -> [ModalTope n]
forall a. [a] -> [a] -> [a]
++ [ModalTope n] -> [ModalTope n]
forall (n :: S). Distinct n => [ModalTope n] -> [ModalTope n]
saturateTopes (TermT n -> ModalTope n
forall (n :: S). TermT n -> ModalTope n
plainTope TermT n
t ModalTope n -> [ModalTope n] -> [ModalTope n]
forall a. a -> [a] -> [a]
: [ModalTope n]
accessible)

          case lems' of
            TopeOrT TypeInfo (TermT n)
_ TermT n
t1 TermT n
t2 : [TermT n]
_ ->
              [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM (TermT n -> [ModalTope n]
withTope TermT n
t1) TermT n
goal TypeCheck n Bool -> (Bool -> TypeCheck n Bool) -> TypeCheck n Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Bool
False -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                Bool
True  -> [ModalTope n] -> TermT n -> TypeCheck n Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
solveRHSM (TermT n -> [ModalTope n]
withTope TermT n
t2) TermT n
goal
            [TermT n]
_ -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
    TermT n
_ -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

solveRHS :: Distinct n => [TermT n] -> TermT n -> Bool
solveRHS :: forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes TermT n
tope =
  case TermT n
tope of
    TermT n
_ | TermT n
forall (n :: S). TermT n
topeBottomT TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
topes -> Bool
True
    TopeTopT{}     -> Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty (PairT TypeInfo (TermT n)
_ty1 TermT n
x TermT n
y) (PairT TypeInfo (TermT n)
_ty2 TermT n
x' TermT n
y')
      | [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
x') Bool -> Bool -> Bool
&& [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
y TermT n
y') -> Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty (PairT TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = CubeProductT TypeInfo (TermT n)
_ TermT n
cubeI TermT n
cubeJ } TermT n
x TermT n
y) TermT n
r
      | [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
firstT TermT n
cubeI TermT n
r))
      , [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
y (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
secondT TermT n
cubeJ TermT n
r)) -> Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty TermT n
l (PairT TypeInfo{ infoType :: forall term. TypeInfo term -> term
infoType = CubeProductT TypeInfo (TermT n)
_ TermT n
cubeI TermT n
cubeJ } TermT n
x TermT n
y)
      | [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
firstT TermT n
cubeI TermT n
l) TermT n
x)
      , [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
secondT TermT n
cubeJ TermT n
l) TermT n
y) -> Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty Cube2_0T{} CubeI_0T{} -> Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty CubeI_0T{} Cube2_0T{} -> Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty Cube2_1T{} CubeI_1T{} -> Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty CubeI_1T{} Cube2_1T{} -> Bool
True
    TopeEQT  TypeInfo (TermT n)
_ty TermT n
l TermT n
r -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
      [ TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
l TermT n
r
      , TermT n
tope TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
topes
      , TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
r TermT n
l TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
topes
      ]
    TopeLEQT TypeInfo (TermT n)
_ty TermT n
l TermT n
r
      | TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
l TermT n
r -> Bool
True
      | [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
l TermT n
r) -> Bool
True
      | [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
l TermT n
forall (n :: S). TermT n
cube2_0T) -> Bool
True
      | [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
r TermT n
forall (n :: S). TermT n
cube2_1T) -> Bool
True
    TopeAndT TypeInfo (TermT n)
_ TermT n
l TermT n
r -> [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes TermT n
l Bool -> Bool -> Bool
&& [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes TermT n
r
    TopeOrT  TypeInfo (TermT n)
_ TermT n
l TermT n
r -> [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes TermT n
l Bool -> Bool -> Bool
|| [TermT n] -> TermT n -> Bool
forall (n :: S). Distinct n => [TermT n] -> TermT n -> Bool
solveRHS [TermT n]
topes TermT n
r
    TermT n
_ -> TermT n
tope TermT n -> [TermT n] -> Bool
forall (n :: S). Distinct n => TermT n -> [TermT n] -> Bool
`elemT` [TermT n]
topes

-- | Accumulate a modality over a list of topes.
applyModalityToTopes :: TModality -> [ModalTope n] -> [ModalTope n]
applyModalityToTopes :: forall (n :: S). TModality -> [ModalTope n] -> [ModalTope n]
applyModalityToTopes TModality
md = (ModalTope n -> ModalTope n) -> [ModalTope n] -> [ModalTope n]
forall a b. (a -> b) -> [a] -> [b]
map (\ModalTope n
mt -> ModalTope n
mt { tModAccum = comp (tModAccum mt) md })

partitionAccessible :: [ModalTope n] -> ([ModalTope n], [ModalTope n])
partitionAccessible :: forall (n :: S). [ModalTope n] -> ([ModalTope n], [ModalTope n])
partitionAccessible [ModalTope n]
topes = ((ModalTope n -> Bool) -> [ModalTope n] -> [ModalTope n]
forall a. (a -> Bool) -> [a] -> [a]
filter ModalTope n -> Bool
forall {n :: S}. ModalTope n -> Bool
isAccessible [ModalTope n]
topes, (ModalTope n -> Bool) -> [ModalTope n] -> [ModalTope n]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (ModalTope n -> Bool) -> ModalTope n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModalTope n -> Bool
forall {n :: S}. ModalTope n -> Bool
isAccessible) [ModalTope n]
topes)

-- * The checks the rest of the checker calls

checkTope :: Distinct n => TermT n -> TypeCheck n Bool
checkTope :: forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
checkTope TermT n
tope = do
  topes <- (Context n -> [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> [TermT n]
forall (n :: S). Context n -> [TermT n]
availableTopes
  performing (ActionContextEntails topes tope) $ do
    tope' <- nfTope tope
    entailContextM tope'

checkTopeEntails :: Distinct n => TermT n -> TypeCheck n Bool
checkTopeEntails :: forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
checkTopeEntails TermT n
tope = do
  topes <- (Context n -> [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> [TermT n]
forall (n :: S). Context n -> [TermT n]
availableTopes
  performing (ActionContextEntailedBy topes tope) $ do
    contextTopes <- asks availableTopesNF
    restrictionTope <- nfTope tope
    let contextTopesRHS = (TermT n -> TermT n -> TermT n) -> TermT n -> [TermT n] -> TermT n
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeAndT TermT n
forall (n :: S). TermT n
topeTopT [TermT n]
contextTopes
    [plainTope restrictionTope] `entailM` contextTopesRHS

checkEntails :: Distinct n => TermT n -> TermT n -> TypeCheck n Bool
checkEntails :: forall (n :: S).
Distinct n =>
TermT n -> TermT n -> TypeCheck n Bool
checkEntails TermT n
l TermT n
r = do  -- FIXME: add action
  l' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
l
  r' <- nfTope r
  [plainTope l'] `entailM` r'

contextEntails :: Distinct n => TermT n -> TypeCheck n ()
contextEntails :: forall (n :: S). Distinct n => TermT n -> TypeCheck n ()
contextEntails TermT n
tope = do
  topes <- (Context n -> [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> [TermT n]
forall (n :: S). Context n -> [TermT n]
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 :: forall (n :: S). Distinct n => TypeCheck n Bool
contextEntailsBottom = (Context n -> Maybe Bool)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe Bool)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Maybe Bool
forall (n :: S). Context n -> Maybe Bool
ctxTopesEntailBottom ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Maybe Bool)
-> (Maybe Bool
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         Bool)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just Bool
entails -> Bool
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
entails
  Maybe Bool
Nothing      -> (Context n -> [ModalTope n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [ModalTope n]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> [ModalTope n]
forall (n :: S). Context n -> [ModalTope n]
ctxTopesNF ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  [ModalTope n]
-> ([ModalTope n]
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         Bool)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= ([ModalTope n]
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     Bool
forall (n :: S).
Distinct n =>
[ModalTope n] -> TermT n -> TypeCheck n Bool
`entailM` TermT n
forall (n :: S). TermT n
topeBottomT)

topesEquiv :: Distinct n => TermT n -> TermT n -> TypeCheck n Bool
topesEquiv :: forall (n :: S).
Distinct n =>
TermT n -> TermT n -> TypeCheck n Bool
topesEquiv TermT n
expected TermT n
actual = Action n -> TypeCheck n Bool -> TypeCheck n Bool
forall (n :: S) a.
Distinct n =>
Action n -> TypeCheck n a -> TypeCheck n a
performing (TermT n -> TermT n -> Action n
forall (n :: S). TermT n -> TermT n -> Action n
ActionUnifyTerms TermT n
expected TermT n
actual) (TypeCheck n Bool -> TypeCheck n Bool)
-> TypeCheck n Bool -> TypeCheck n Bool
forall a b. (a -> b) -> a -> b
$ do
  expected' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
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 :: forall (n :: S). Distinct n => [TermT n] -> TypeCheck n ()
contextEntailsUnion [TermT n]
topes = do
  ctxTopes' <- (Context n -> [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> [TermT n]
forall (n :: S). Context n -> [TermT n]
availableTopes
  performing (ActionContextEntailsUnion ctxTopes' topes) $ do
    contextTopes <- asks ctxTopesNF
    topesNF <- mapM nfTope topes
    let unionRHS = (TermT n -> TermT n -> TermT n) -> TermT n -> [TermT n] -> TermT n
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeOrT TermT n
forall (n :: S). TermT n
topeBottomT [TermT n]
topesNF
    entailContextM unionRHS >>= \case
      -- a guard mentioning an (unfilled) hole can't be decided; defer coverage
      Bool
False | Bool -> Bool
not ((TermT n -> Bool) -> [TermT n] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any TermT n -> Bool
forall (n :: S). TermT n -> Bool
containsHole [TermT n]
topesNF) ->
        TypeError n -> TypeCheck n ()
forall (n :: S) a. Distinct n => TypeError n -> TypeCheck n a
issueTypeError (TypeError n -> TypeCheck n ()) -> TypeError n -> TypeCheck n ()
forall a b. (a -> b) -> a -> b
$ [TermT n] -> TermT n -> TypeError n
forall (n :: S). [TermT n] -> TermT n -> TypeError n
TypeErrorTopeNotSatisfied ([ModalTope n] -> [TermT n]
forall (n :: S). [ModalTope n] -> [TermT n]
accessibleTopes [ModalTope n]
contextTopes) TermT n
unionRHS
      Bool
_ -> () -> TypeCheck n ()
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
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 :: forall (n :: S). Distinct n => String -> TermT n -> TypeCheck n ()
checkTopeAgainstContext String
what TermT n
tope = do
  -- a contradictory context is handled elsewhere (recBOT)
  ctxEntailsBottom <- TypeCheck n Bool
forall (n :: S). Distinct n => TypeCheck n Bool
contextEntailsBottom
  unless ctxEntailsBottom $ do
    contextTopes <- asks ctxTopesNF
    let topes = (TermT n -> Bool) -> [TermT n] -> [TermT n]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool) -> (TermT n -> Bool) -> TermT n -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TermT n -> TermT n -> Bool
forall (n :: S). Distinct n => TermT n -> TermT n -> Bool
eqT TermT n
forall (n :: S). TermT n
topeTopT) ([ModalTope n] -> [TermT n]
forall (n :: S). [ModalTope n] -> [TermT n]
accessibleTopes [ModalTope n]
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 :: forall (n :: S). TermT n -> TermT n
stripTypeRestrictions (TypeRestrictedT TypeInfo (AST NameBinder (AnnSig TypeInfo TermSig) n)
_ty AST NameBinder (AnnSig TypeInfo TermSig) n
ty [(AST NameBinder (AnnSig TypeInfo TermSig) n,
  AST NameBinder (AnnSig TypeInfo TermSig) n)]
_restriction) = AST NameBinder (AnnSig TypeInfo TermSig) n
-> AST NameBinder (AnnSig TypeInfo TermSig) n
forall (n :: S). TermT n -> TermT n
stripTypeRestrictions AST NameBinder (AnnSig TypeInfo TermSig) n
ty
stripTypeRestrictions AST NameBinder (AnnSig TypeInfo TermSig) n
t = AST NameBinder (AnnSig TypeInfo TermSig) n
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 :: forall (n :: S).
Distinct n =>
TermT n -> TypeCheck n (Maybe (TermT n))
tryRestriction = \case
  TypeRestrictedT TypeInfo (TermT n)
_ TermT n
_ [(TermT n, TermT n)]
rs -> [(TermT n, TermT n)] -> TypeCheck n (Maybe (TermT n))
forall {n :: S} {a}.
Distinct n =>
[(TermT n, a)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe a)
go [(TermT n, TermT n)]
rs
  TermT n
_ -> Maybe (TermT n) -> TypeCheck n (Maybe (TermT n))
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT n)
forall a. Maybe a
Nothing
  where
    go :: [(TermT n, a)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe a)
go [] = Maybe a
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe a)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe a
forall a. Maybe a
Nothing
    go ((TermT n
tope, a
term') : [(TermT n, a)]
rs') = TermT n -> TypeCheck n Bool
forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
checkTope TermT n
tope TypeCheck n Bool
-> (Bool
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (Maybe a))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe a)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Bool
True  -> Maybe a
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe a)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (a -> Maybe a
forall a. a -> Maybe a
Just a
term')
      Bool
False -> [(TermT n, a)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe a)
go [(TermT n, a)]
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 :: forall (n :: S).
Distinct n =>
Maybe (TermT n)
-> TermT n -> TermT n -> TypeCheck n (TermT n, TermT n)
etaMatch Maybe (TermT n)
_mterm expected :: TermT n
expected@TypeRestrictedT{} actual :: TermT n
actual@TypeRestrictedT{} = (TermT n, TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n, TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n
expected, TermT n
actual)
etaMatch  Maybe (TermT n)
mterm TermT n
expected (TypeRestrictedT TypeInfo (TermT n)
_ty TermT n
ty [(TermT n, TermT n)]
_rs) = Maybe (TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n, TermT n)
forall (n :: S).
Distinct n =>
Maybe (TermT n)
-> TermT n -> TermT n -> TypeCheck n (TermT n, TermT n)
etaMatch Maybe (TermT n)
mterm TermT n
expected TermT n
ty
etaMatch (Just TermT n
term) expected :: TermT n
expected@TypeRestrictedT{} TermT n
actual =
  Maybe (TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n, TermT n)
forall (n :: S).
Distinct n =>
Maybe (TermT n)
-> TermT n -> TermT n -> TypeCheck n (TermT n, TermT n)
etaMatch (TermT n -> Maybe (TermT n)
forall a. a -> Maybe a
Just TermT n
term) TermT n
expected (TermT n -> [(TermT n, TermT n)] -> TermT n
forall (n :: S). TermT n -> [(TermT n, TermT n)] -> TermT n
typeRestrictedT TermT n
actual [(TermT n
forall (n :: S). TermT n
topeTopT, TermT n
term)])
-- Subtyping on the interval.
etaMatch Maybe (TermT n)
_mterm CubeIT{} Cube2T{} = (TermT n, TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n, TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n
forall (n :: S). TermT n
cubeIT, TermT n
forall (n :: S). TermT n
cubeIT)
etaMatch Maybe (TermT n)
_mterm expected :: TermT n
expected@LambdaT{} actual :: TermT n
actual@LambdaT{} = (TermT n, TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n, TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n
expected, TermT n
actual)
etaMatch Maybe (TermT n)
_mterm expected :: TermT n
expected@PairT{}   actual :: TermT n
actual@PairT{}   = (TermT n, TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n, TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n
expected, TermT n
actual)
etaMatch Maybe (TermT n)
_mterm expected :: TermT n
expected@LambdaT{} TermT n
actual = do
  actual' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
etaExpand TermT n
actual
  pure (expected, actual')
etaMatch Maybe (TermT n)
_mterm TermT n
expected actual :: TermT n
actual@LambdaT{} = do
  expected' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
etaExpand TermT n
expected
  pure (expected', actual)
etaMatch Maybe (TermT n)
_mterm expected :: TermT n
expected@PairT{} TermT n
actual = do
  actual' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
etaExpand TermT n
actual
  pure (expected, actual')
etaMatch Maybe (TermT n)
_mterm TermT n
expected actual :: TermT n
actual@PairT{} = do
  expected' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
etaExpand TermT n
expected
  pure (expected', actual)
etaMatch Maybe (TermT n)
_mterm expected :: TermT n
expected@ModAppT{} actual :: TermT n
actual@ModAppT{} = (TermT n, TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n, TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n
expected, TermT n
actual)
etaMatch Maybe (TermT n)
_mterm expected :: TermT n
expected@ModAppT{} TermT n
actual = do
  actual' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
etaExpand TermT n
actual
  pure (expected, actual')
etaMatch Maybe (TermT n)
_mterm TermT n
expected actual :: TermT n
actual@ModAppT{} = do
  expected' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
etaExpand TermT n
expected
  pure (expected', actual)
etaMatch Maybe (TermT n)
_mterm TermT n
expected TermT n
actual = (TermT n, TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n, TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n
expected, TermT n
actual)

etaExpand :: Distinct n => TermT n -> TypeCheck n (TermT n)
etaExpand :: forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
etaExpand term :: TermT n
term@LambdaT{} = TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
term
etaExpand term :: TermT n
term@PairT{} = TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
term
etaExpand TermT n
term = do
  ty <- TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
term
  case stripTypeRestrictions ty of
    TypeFunT TypeInfo (TermT n)
_ty Binder
orig TModality
md TermT n
param Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
mtope ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret -> do
      scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
ctxScope
      pure $ withFreshIn scope $ \NameBinder n l
binder ->
        let z :: AST NameBinder (AnnSig TypeInfo TermSig) l
z = Name l -> AST NameBinder (AnnSig TypeInfo TermSig) l
forall (n :: S) (binder :: S -> S -> *) (sig :: * -> * -> *).
Name n -> AST binder sig n
Var (NameBinder n l -> Name l
forall (n :: S) (l :: S). NameBinder n l -> Name l
Foil.nameOf NameBinder n l
binder)
            body :: AST NameBinder (AnnSig TypeInfo TermSig) l
body = AST NameBinder (AnnSig TypeInfo TermSig) l
-> AST NameBinder (AnnSig TypeInfo TermSig) l
-> AST NameBinder (AnnSig TypeInfo TermSig) l
-> AST NameBinder (AnnSig TypeInfo TermSig) l
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
appT (Scope l
-> Name l
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> AST NameBinder (AnnSig TypeInfo TermSig) l
forall (sig :: * -> * -> *) (n :: S) (l :: S).
(Bifunctor sig, DExt n l) =>
Scope l
-> Name l -> ScopedAST NameBinder sig n -> AST NameBinder sig l
openWith (NameBinder n l -> Scope n -> Scope l
forall (n :: S) (l :: S). NameBinder n l -> Scope n -> Scope l
Foil.extendScope NameBinder n l
binder Scope n
scope) (NameBinder n l -> Name l
forall (n :: S) (l :: S). NameBinder n l -> Name l
Foil.nameOf NameBinder n l
binder) ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret)
                        (TermT n -> AST NameBinder (AnnSig TypeInfo TermSig) l
forall (e :: S -> *) (n :: S) (l :: S).
(Sinkable e, DExt n l) =>
e n -> e l
Foil.sink TermT n
term) AST NameBinder (AnnSig TypeInfo TermSig) l
z
            mtope' :: Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
mtope' = (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
 -> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
-> Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
-> Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
t -> NameBinder n l
-> AST NameBinder (AnnSig TypeInfo TermSig) l
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
forall (binder :: S -> S -> *) (n :: S) (l :: S)
       (sig :: * -> * -> *).
binder n l -> AST binder sig l -> ScopedAST binder sig n
ScopedAST NameBinder n l
binder (Scope l
-> Name l
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> AST NameBinder (AnnSig TypeInfo TermSig) l
forall (sig :: * -> * -> *) (n :: S) (l :: S).
(Bifunctor sig, DExt n l) =>
Scope l
-> Name l -> ScopedAST NameBinder sig n -> AST NameBinder sig l
openWith (NameBinder n l -> Scope n -> Scope l
forall (n :: S) (l :: S). NameBinder n l -> Scope n -> Scope l
Foil.extendScope NameBinder n l
binder Scope n
scope) (NameBinder n l -> Name l
forall (n :: S) (l :: S). NameBinder n l -> Name l
Foil.nameOf NameBinder n l
binder) ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
t)) Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
mtope
         in TermT n
-> Binder
-> Maybe
     (LambdaParam
        (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n))
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n
forall (n :: S).
TermT n
-> Binder
-> Maybe (LambdaParam (ScopedTermT n) (TermT n))
-> ScopedTermT n
-> TermT n
lambdaT TermT n
ty Binder
orig
              (LambdaParam
  (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n)
-> Maybe
     (LambdaParam
        (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n))
forall a. a -> Maybe a
Just (TModality
-> TermT n
-> Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
-> LambdaParam
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n)
forall scope term.
TModality -> term -> Maybe scope -> LambdaParam scope term
LambdaParam TModality
md TermT n
param Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
mtope'))
              (NameBinder n l
-> AST NameBinder (AnnSig TypeInfo TermSig) l
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
forall (binder :: S -> S -> *) (n :: S) (l :: S)
       (sig :: * -> * -> *).
binder n l -> AST binder sig l -> ScopedAST binder sig n
ScopedAST NameBinder n l
binder AST NameBinder (AnnSig TypeInfo TermSig) l
body)

    TypeSigmaT TypeInfo (TermT n)
_ty Binder
_orig TModality
_md TermT n
a ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
b -> do
      let firstTerm :: TermT n
firstTerm = TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
firstT TermT n
a TermT n
term
      bInstantiated <- ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S).
Distinct n =>
ScopedTermT n -> TermT n -> TypeCheck n (TermT n)
instantiate ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
b TermT n
firstTerm
      pure $ pairT ty firstTerm (secondT bInstantiated term)

    CubeProductT TypeInfo (TermT n)
_ty TermT n
a TermT n
b -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$
      TermT n -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
pairT TermT n
ty (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
firstT TermT n
a TermT n
term) (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
secondT TermT n
b TermT n
term)

    TypeModalT TypeInfo (TermT n)
_ty TModality
md TermT n
inner | TModality -> Bool
forall m. ModeTheory m => m -> Bool
isRA TModality
md -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$
      TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT TermT n
ty TModality
md (TermT n -> TModality -> TModality -> TermT n -> TermT n
forall (n :: S).
TermT n -> TModality -> TModality -> TermT n -> TermT n
modExtractT TermT n
inner TModality
Id TModality
md TermT n
term)

    TermT n
_ -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
term

-- * Layers

inCubeLayer :: Distinct n => TermT n -> TypeCheck n Bool
inCubeLayer :: forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
inCubeLayer = \case
  RecBottomT{}    -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  UniverseT{}     -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  UniverseCubeT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeProductT{}  -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitT{}     -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitStarT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2T{}        -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_0T{}      -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_1T{}      -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  TermT n
t               -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n Bool) -> TypeCheck n Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n -> TypeCheck n Bool
forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
inCubeLayer

inTopeLayer :: Distinct n => TermT n -> TypeCheck n Bool
inTopeLayer :: forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
inTopeLayer = \case
  RecBottomT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False
  UniverseT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

  UniverseCubeT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  UniverseTopeT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  CubeProductT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  CubeUnitStarT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2T{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_0T{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  Cube2_1T{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  TopeTopT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeBottomT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeAndT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeOrT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeEQT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True
  TopeLEQT{} -> Bool -> TypeCheck n Bool
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
True

  TypeFunT TypeInfo (TermT n)
_ty Binder
orig TModality
md TermT n
param Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
_mtope ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret ->
    Binder
-> TModality
-> TermT n
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    AST NameBinder (AnnSig TypeInfo TermSig) l -> TypeCheck l Bool)
-> TypeCheck n Bool
forall (sig :: * -> * -> *) (n :: S) a.
(Bifunctor sig, Distinct n) =>
Binder
-> TModality
-> TermT n
-> ScopedAST NameBinder sig n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    AST NameBinder sig l -> TypeCheck l a)
-> TypeCheck n a
inScope Binder
orig TModality
md TermT n
param ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret TermT l -> TypeCheck l Bool
forall (l :: S).
(DExt n l, Distinct l) =>
AST NameBinder (AnnSig TypeInfo TermSig) l -> TypeCheck l Bool
forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
inTopeLayer

  TermT n
t -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). TermT n -> TypeCheck n (TermT n)
typeOfUncomputed TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n Bool) -> TypeCheck n Bool
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n -> TypeCheck n Bool
forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
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 :: forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
memoizeWHNF t :: TermT n
t@(Var Name n
_) = TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
memoizeWHNF t :: TermT n
t@(Node (AnnSig TypeInfo (TermT n)
info TermSig
  (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n)
sig)) = do
  w <- TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
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 :: forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
t | Just TypeInfo (TermT n)
info <- TermT n -> Maybe (TypeInfo (TermT n))
forall (n :: S). TermT n -> Maybe (TypeInfo (TermT n))
typeInfoOf TermT n
t, Just TermT n
t' <- TypeInfo (TermT n) -> Maybe (TermT n)
forall term. TypeInfo term -> Maybe term
infoWHNF TypeInfo (TermT n)
info = TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t'
whnfT TermT n
tt = Action n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S) a.
Distinct n =>
Action n -> TypeCheck n a -> TypeCheck n a
performing (TermT n -> Action n
forall (n :: S). TermT n -> Action n
ActionWHNF TermT n
tt) (ReaderT
   (Context n)
   (ExceptT TypeErrorInScopedContext (State CheckLog))
   (TermT n)
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$ case TermT n
tt of
  -- universe constants
  UniverseT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  UniverseCubeT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  UniverseTopeT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- cube layer (except vars, pairs, and applications)
  CubeProductT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  CubeUnitT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeUnitStarT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Cube2T{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Cube2_0T{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Cube2_1T{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeIT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeI_0T{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeI_1T{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeFlipT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  CubeUnflipT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  CubeSupT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  CubeInfT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt

  -- tope layer (except vars, pairs of points, and applications)
  TopeTopT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TopeBottomT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TopeAndT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeOrT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeEQT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeLEQT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeInvT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeUninvT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt

  -- type layer terms that should not be evaluated further
  LambdaT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  PairT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  ReflT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TypeFunT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TypeSigmaT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TypeIdT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TypeModalT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  RecBottomT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TypeUnitT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  UnitT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- type ascriptions are ignored, since we already have a typechecked term
  TypeAscT TypeInfo (TermT n)
_ty TermT n
term TermT n
_ty' -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
term

  -- check if we have a cube or a tope term (if so, compute NF)
  TermT n
_ -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
tt ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    UniverseCubeT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
    UniverseTopeT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt

    TypeUnitT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
unitT -- compute an expression of Unit type to unit
    -- FIXME: next line is ad hoc, should be improved!
    TypeRestrictedT TypeInfo (TermT n)
_info TypeUnitT{} [(TermT n, TermT n)]
_rs -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
unitT

    -- check if we have a cube point term (if so, compute NF)
    TermT n
typeOf_tt -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
typeOf_tt ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      UniverseCubeT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt

      -- now we are in the type layer
      TermT n
_ -> (TermT n -> TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
(a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
termIsWHNF (ReaderT
   (Context n)
   (ExceptT TypeErrorInScopedContext (State CheckLog))
   (TermT n)
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$ do
        TermT n -> TypeCheck n (Maybe (TermT n))
forall (n :: S).
Distinct n =>
TermT n -> TypeCheck n (Maybe (TermT n))
tryRestriction TermT n
typeOf_tt TypeCheck n (Maybe (TermT n))
-> (Maybe (TermT n)
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Just TermT n
tt' -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
tt'
          Maybe (TermT n)
Nothing -> case TermT n
tt of
            -- a hole is opaque: it never reduces, it is already a normal form
            HoleT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
            t :: TermT n
t@(Var Name n
x) ->
              Name n -> TypeCheck n (Maybe (TermT n))
forall (n :: S). Name n -> TypeCheck n (Maybe (TermT n))
valueOfVar Name n
x TypeCheck n (Maybe (TermT n))
-> (Maybe (TermT n)
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Maybe (TermT n)
Nothing   -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
                Just TermT n
term -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
term

            AppT{} -> do
              scope <- (Context n -> Scope n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Scope n)
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks Context n -> Scope n
forall (n :: S). Context n -> Scope n
ctxScope
              uncurry (applySpine scope) (collectAppSpine tt)

            LetT TypeInfo (TermT n)
_ty Binder
_orig Maybe (TermT n)
_mparam TermT n
val ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body ->
              ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S).
Distinct n =>
ScopedTermT n -> TermT n -> TypeCheck n (TermT n)
instantiate ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body TermT n
val ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT
            LetModT TypeInfo (TermT n)
ty Binder
orig TModality
app TModality
inn Maybe (TermT n)
mparam Maybe (TermT n)
mmotive TermT n
val ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body ->
              (TModality
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
app (ReaderT
   (Context n)
   (ExceptT TypeErrorInScopedContext (State CheckLog))
   (TermT n)
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
val) ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                ModAppT TypeInfo (TermT n)
_ TModality
md TermT n
t | TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
inn -> do
                  val' <- TModality
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (ReaderT
   (Context n)
   (ExceptT TypeErrorInScopedContext (State CheckLog))
   (TermT n)
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
t
                  instantiate body val' >>= whnfT
                TermT n
b' | TModality -> Bool
forall m. ModeTheory m => m -> Bool
isRA TModality
inn -> do
                  bty <- TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
b' ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                    TypeModalT TypeInfo (TermT n)
_ TModality
_ TermT n
t -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
                    TermT n
_ -> String
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a. String -> a
panicImpossible String
"not modal in letmod"
                  instantiate body (modExtractT bty app inn b') >>= whnfT
                TermT n
_ -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n)
-> Binder
-> TModality
-> TModality
-> Maybe (TermT n)
-> Maybe (TermT n)
-> TermT n
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> Binder
-> TModality
-> TModality
-> Maybe (AST binder (AnnSig ann TermSig) n)
-> Maybe (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> ScopedAST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
LetModT TypeInfo (TermT n)
ty Binder
orig TModality
app TModality
inn Maybe (TermT n)
mparam Maybe (TermT n)
mmotive TermT n
val ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body)
            FirstT TypeInfo (TermT n)
ty TermT n
t ->
              TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
t ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                PairT TypeInfo (TermT n)
_ TermT n
l TermT n
_r -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
l
                TermT n
t'           -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
FirstT TypeInfo (TermT n)
ty TermT n
t')

            SecondT TypeInfo (TermT n)
ty TermT n
t ->
              TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
t ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                PairT TypeInfo (TermT n)
_ TermT n
_l TermT n
r -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
r
                TermT n
t'           -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
SecondT TypeInfo (TermT n)
ty TermT n
t')
            ModAppT TypeInfo (TermT n)
ty TModality
md TermT n
b ->
              (TModality
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (ReaderT
   (Context n)
   (ExceptT TypeErrorInScopedContext (State CheckLog))
   (TermT n)
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
b) ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                ModExtractT TypeInfo (TermT n)
_ TModality
app TModality
inn TermT n
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TModality
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
md TModality
app) (ReaderT
   (Context n)
   (ExceptT TypeErrorInScopedContext (State CheckLog))
   (TermT n)
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
t
                TermT n
b' -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$ TypeInfo (TermT n) -> TModality -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> TModality
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
ModAppT TypeInfo (TermT n)
ty TModality
md TermT n
b'
            ModExtractT TypeInfo (TermT n)
ty TModality
app TModality
inn TermT n
b ->
              (TModality
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
app (ReaderT
   (Context n)
   (ExceptT TypeErrorInScopedContext (State CheckLog))
   (TermT n)
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
b) ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                ModAppT TypeInfo (TermT n)
_ TModality
md TermT n
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TModality
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
inn (ReaderT
   (Context n)
   (ExceptT TypeErrorInScopedContext (State CheckLog))
   (TermT n)
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
t
                TermT n
b' -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TModality -> TModality -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> TModality
-> TModality
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
ModExtractT TypeInfo (TermT n)
ty TModality
app TModality
inn TermT n
b')
            IdJT TypeInfo (TermT n)
ty TermT n
tA TermT n
a TermT n
tC TermT n
d TermT n
x TermT n
p ->
              TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
p ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                ReflT{} -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
d
                TermT n
p'      -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n)
-> TermT n
-> TermT n
-> TermT n
-> TermT n
-> TermT n
-> TermT n
-> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
IdJT TypeInfo (TermT n)
ty TermT n
tA TermT n
a TermT n
tC TermT n
d TermT n
x TermT n
p')

            RecOrT TypeInfo (TermT n)
_ty [(TermT n, TermT n)]
rs -> do
              [(TermT n, TermT n)] -> TypeCheck n (Maybe (TermT n))
forall (n :: S).
Distinct n =>
[(TermT n, TermT n)] -> TypeCheck n (Maybe (TermT n))
firstMatching [(TermT n, TermT n)]
rs TypeCheck n (Maybe (TermT n))
-> (Maybe (TermT n)
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                Just TermT n
tt' -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
tt'
                Maybe (TermT n)
Nothing
                  | [TermT n
tt'] <- [TermT n] -> [TermT n]
forall (n :: S). Distinct n => [TermT n] -> [TermT n]
nubT (((TermT n, TermT n) -> TermT n)
-> [(TermT n, TermT n)] -> [TermT n]
forall a b. (a -> b) -> [a] -> [b]
map (TermT n, TermT n) -> TermT n
forall a b. (a, b) -> b
snd [(TermT n, TermT n)]
rs) -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
tt'
                  | Bool
otherwise -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

            TypeRestrictedT TypeInfo (TermT n)
ty TermT n
type_ [(TermT n, TermT n)]
rs -> do
              rs' <- ((TermT n, TermT n)
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (TermT n, TermT n))
-> [(TermT n, TermT n)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [(TermT n, TermT n)]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (\(TermT n
tope, TermT n
term) -> (,) (TermT n -> TermT n -> (TermT n, TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> (TermT n, TermT n))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
tope ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> (TermT n, TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n, TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
term) [(TermT n, TermT n)]
rs
              case filter (not . eqT topeBottomT . fst) rs' of
                []   -> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
type_  -- get rid of restrictions at BOT
                [(TermT n, TermT n)]
rs'' -> TypeInfo (TermT n) -> TermT n -> [(TermT n, TermT n)] -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> [(AST binder (AnnSig ann TermSig) n,
     AST binder (AnnSig ann TermSig) n)]
-> AST binder (AnnSig ann TermSig) n
TypeRestrictedT TypeInfo (TermT n)
ty (TermT n -> [(TermT n, TermT n)] -> TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     ([(TermT n, TermT n)] -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
type_ ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  ([(TermT n, TermT n)] -> TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [(TermT n, TermT n)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(TermT n, TermT n)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [(TermT n, TermT n)]
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TermT n, TermT n)]
rs''

            -- a match is elaborated into its eliminator spine during
            -- typechecking; a typed match node never exists
            MatchT{} -> String
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a. String -> a
panicImpossible String
"a typed match survives elaboration"
            MatchArmT{} -> String
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a. String -> a
panicImpossible String
"a typed match arm survives elaboration"

-- | 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 :: forall (n :: S).
Distinct n =>
[(TermT n, TermT n)] -> TypeCheck n (Maybe (TermT n))
firstMatching [] = Maybe (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT n)
forall a. Maybe a
Nothing
firstMatching ((TermT n
tope, TermT n
t) : [(TermT n, TermT n)]
rest) = TermT n -> TypeCheck n Bool
forall (n :: S). Distinct n => TermT n -> TypeCheck n Bool
checkTope TermT n
tope TypeCheck n Bool
-> (Bool
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (Maybe (TermT n)))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Bool
True  -> Maybe (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> Maybe (TermT n)
forall a. a -> Maybe a
Just TermT n
t)
  Bool
False -> [(TermT n, TermT n)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall (n :: S).
Distinct n =>
[(TermT n, TermT n)] -> TypeCheck n (Maybe (TermT n))
firstMatching [(TermT n, TermT n)]
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 :: forall (n :: S).
TermT n -> (TermT n, [(TypeInfo (TermT n), TermT n)])
collectAppSpine = [(TypeInfo (AST NameBinder (AnnSig TypeInfo TermSig) n),
  AST NameBinder (AnnSig TypeInfo TermSig) n)]
-> AST NameBinder (AnnSig TypeInfo TermSig) n
-> (AST NameBinder (AnnSig TypeInfo TermSig) n,
    [(TypeInfo (AST NameBinder (AnnSig TypeInfo TermSig) n),
      AST NameBinder (AnnSig TypeInfo TermSig) n)])
forall {ann :: * -> *} {binder :: S -> S -> *} {n :: S}.
[(ann (AST binder (AnnSig ann TermSig) n),
  AST binder (AnnSig ann TermSig) n)]
-> AST binder (AnnSig ann TermSig) n
-> (AST binder (AnnSig ann TermSig) n,
    [(ann (AST binder (AnnSig ann TermSig) n),
      AST binder (AnnSig ann TermSig) n)])
go []
  where
    go :: [(ann (AST binder (AnnSig ann TermSig) n),
  AST binder (AnnSig ann TermSig) n)]
-> AST binder (AnnSig ann TermSig) n
-> (AST binder (AnnSig ann TermSig) n,
    [(ann (AST binder (AnnSig ann TermSig) n),
      AST binder (AnnSig ann TermSig) n)])
go [(ann (AST binder (AnnSig ann TermSig) n),
  AST binder (AnnSig ann TermSig) n)]
acc (AppT ann (AST binder (AnnSig ann TermSig) n)
ty AST binder (AnnSig ann TermSig) n
f AST binder (AnnSig ann TermSig) n
x) = [(ann (AST binder (AnnSig ann TermSig) n),
  AST binder (AnnSig ann TermSig) n)]
-> AST binder (AnnSig ann TermSig) n
-> (AST binder (AnnSig ann TermSig) n,
    [(ann (AST binder (AnnSig ann TermSig) n),
      AST binder (AnnSig ann TermSig) n)])
go ((ann (AST binder (AnnSig ann TermSig) n)
ty, AST binder (AnnSig ann TermSig) n
x) (ann (AST binder (AnnSig ann TermSig) n),
 AST binder (AnnSig ann TermSig) n)
-> [(ann (AST binder (AnnSig ann TermSig) n),
     AST binder (AnnSig ann TermSig) n)]
-> [(ann (AST binder (AnnSig ann TermSig) n),
     AST binder (AnnSig ann TermSig) n)]
forall a. a -> [a] -> [a]
: [(ann (AST binder (AnnSig ann TermSig) n),
  AST binder (AnnSig ann TermSig) n)]
acc) AST binder (AnnSig ann TermSig) n
f
    go [(ann (AST binder (AnnSig ann TermSig) n),
  AST binder (AnnSig ann TermSig) n)]
acc AST binder (AnnSig ann TermSig) n
h             = (AST binder (AnnSig ann TermSig) n
h, [(ann (AST binder (AnnSig ann TermSig) n),
  AST binder (AnnSig ann TermSig) n)]
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 :: forall (n :: S).
Distinct n =>
Scope n
-> TermT n
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
applySpine Scope n
_ TermT n
h [] = TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
h
applySpine Scope n
scope TermT n
h [(TypeInfo (TermT n), TermT n)]
pairs = TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
h TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermT n
h' -> case TermT n
h' of
  LambdaT TypeInfo (TermT n)
_ Binder
_ Maybe
  (LambdaParam
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n))
_ (ScopedAST NameBinder n l
binder AST NameBinder (AnnSig TypeInfo TermSig) l
body) | (TypeInfo (TermT n)
_, TermT n
x) : [(TypeInfo (TermT n), TermT n)]
rest <- [(TypeInfo (TermT n), TermT n)]
pairs ->
    Scope n
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) l n
-> AST NameBinder (AnnSig TypeInfo TermSig) l
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
forall (i :: S) (n :: S).
Distinct n =>
Scope n
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
-> TermT i
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
peelLambdas Scope n
scope (Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) n n
-> NameBinder n l
-> TermT n
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) l n
forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
Substitution e i o -> NameBinder i i' -> e o -> Substitution e i' o
Foil.addSubst Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) n n
forall (e :: S -> *) (i :: S). InjectName e => Substitution e i i
Foil.identitySubst NameBinder n l
binder TermT n
x) AST NameBinder (AnnSig TypeInfo TermSig) l
body [(TypeInfo (TermT n), TermT n)]
rest
  TermT n
_ -> do
    -- The head may itself be a (neutral) application: a definition whose
    -- value is an under-applied eliminator, say. The ι-rule needs the full
    -- spine, so the head's own arguments are collected back in.
    let (TermT n
h'', [(TypeInfo (TermT n), TermT n)]
headPairs) = TermT n -> (TermT n, [(TypeInfo (TermT n), TermT n)])
forall (n :: S).
TermT n -> (TermT n, [(TypeInfo (TermT n), TermT n)])
collectAppSpine TermT n
h'
    TermT n
-> [(TypeInfo (TermT n), TermT n)] -> TypeCheck n (Maybe (TermT n))
forall (n :: S).
Distinct n =>
TermT n
-> [(TypeInfo (TermT n), TermT n)] -> TypeCheck n (Maybe (TermT n))
tryDataElimStep TermT n
h'' ([(TypeInfo (TermT n), TermT n)]
headPairs [(TypeInfo (TermT n), TermT n)]
-> [(TypeInfo (TermT n), TermT n)]
-> [(TypeInfo (TermT n), TermT n)]
forall a. Semigroup a => a -> a -> a
<> [(TypeInfo (TermT n), TermT n)]
pairs) TypeCheck n (Maybe (TermT n))
-> (Maybe (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just TermT n
stepped -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
stepped
      Maybe (TermT n)
Nothing      -> Scope n
-> TermT n
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
forall (n :: S).
Distinct n =>
Scope n
-> TermT n
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
applyNeutral Scope n
scope TermT n
h' [(TypeInfo (TermT n), TermT n)]
pairs

-- | Try to fire a @#data@ ι-rule on an application spine: the head is a
-- generated eliminator, the scrutinee argument is headed by a fully applied
-- constructor of the same datatype. Returns the method applied to the
-- constructor's fields (and any leftover spine arguments), unreduced.
--
-- A non-'Var' head answers 'Nothing' immediately, so the common neutral
-- spine pays one pattern match; a 'Var' head pays one 'lookupVarInfo'.
tryDataElimStep
  :: Distinct n
  => TermT n                          -- ^ the head, in WHNF
  -> [(TypeInfo (TermT n), TermT n)]  -- ^ the collected spine arguments
  -> TypeCheck n (Maybe (TermT n))
tryDataElimStep :: forall (n :: S).
Distinct n =>
TermT n
-> [(TypeInfo (TermT n), TermT n)] -> TypeCheck n (Maybe (TermT n))
tryDataElimStep (Var Name n
v) [(TypeInfo (TermT n), TermT n)]
pairs = (Context n -> Maybe (DataRole n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (DataRole n))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (VarInfo n -> Maybe (DataRole n)
forall (n :: S). VarInfo n -> Maybe (DataRole n)
varDataRole (VarInfo n -> Maybe (DataRole n))
-> (Context n -> VarInfo n) -> Context n -> Maybe (DataRole n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name n -> Context n -> VarInfo n
forall (n :: S). Name n -> Context n -> VarInfo n
lookupVarInfo Name n
v) ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Maybe (DataRole n))
-> (Maybe (DataRole n)
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (Maybe (TermT n)))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Just (DataRole Name n
dataType Id
numParams (DataElimKind Id
numMethods Id
numIndices ElimKind
_elimKind))
    -- The spine is parameters, motive, methods, indices, scrutinee. The
    -- index arguments are dropped on a step: the scrutinee determines them.
    | ([(TypeInfo (TermT n), TermT n)]
beforeIndices, [(TypeInfo (TermT n), TermT n)]
rest) <- Id
-> [(TypeInfo (TermT n), TermT n)]
-> ([(TypeInfo (TermT n), TermT n)],
    [(TypeInfo (TermT n), TermT n)])
forall a. Id -> [a] -> ([a], [a])
splitAt (Id
numParams Id -> Id -> Id
forall a. Num a => a -> a -> a
+ Id
1 Id -> Id -> Id
forall a. Num a => a -> a -> a
+ Id
numMethods) [(TypeInfo (TermT n), TermT n)]
pairs
    , ([(TypeInfo (TermT n), TermT n)]
_indices, (TypeInfo (TermT n)
_, TermT n
scrut) : [(TypeInfo (TermT n), TermT n)]
after) <- Id
-> [(TypeInfo (TermT n), TermT n)]
-> ([(TypeInfo (TermT n), TermT n)],
    [(TypeInfo (TermT n), TermT n)])
forall a. Id -> [a] -> ([a], [a])
splitAt Id
numIndices [(TypeInfo (TermT n), TermT n)]
rest ->
        TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
scrut TypeCheck n (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (Maybe (TermT n)))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \TermT n
scrut' -> case TermT n -> (TermT n, [(TypeInfo (TermT n), TermT n)])
forall (n :: S).
TermT n -> (TermT n, [(TypeInfo (TermT n), TermT n)])
collectAppSpine TermT n
scrut' of
          (Var Name n
c, [(TypeInfo (TermT n), TermT n)]
cargs) -> (Context n -> Maybe (DataRole n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (DataRole n))
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (VarInfo n -> Maybe (DataRole n)
forall (n :: S). VarInfo n -> Maybe (DataRole n)
varDataRole (VarInfo n -> Maybe (DataRole n))
-> (Context n -> VarInfo n) -> Context n -> Maybe (DataRole n)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name n -> Context n -> VarInfo n
forall (n :: S). Name n -> Context n -> VarInfo n
lookupVarInfo Name n
c) ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Maybe (DataRole n))
-> (Maybe (DataRole n)
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (Maybe (TermT n)))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just (DataRole Name n
dataType' Id
conNumParams (DataConKind ConSort
PointCon Id
conIndex Id
conNumFields [Id]
recIdxs))
              | Name n -> Id
forall (l :: S). Name l -> Id
Foil.nameId Name n
dataType' Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Name n -> Id
forall (l :: S). Name l -> Id
Foil.nameId Name n
dataType
              , [(TypeInfo (TermT n), TermT n)] -> Id
forall a. [a] -> Id
forall (t :: * -> *) a. Foldable t => t a -> Id
length [(TypeInfo (TermT n), TermT n)]
cargs Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
conNumParams Id -> Id -> Id
forall a. Num a => a -> a -> a
+ Id
conNumFields -> do
                  let method :: TermT n
method = (TypeInfo (TermT n), TermT n) -> TermT n
forall a b. (a, b) -> b
snd ([(TypeInfo (TermT n), TermT n)]
pairs [(TypeInfo (TermT n), TermT n)]
-> Id -> (TypeInfo (TermT n), TermT n)
forall a. HasCallStack => [a] -> Id -> a
!! (Id
numParams Id -> Id -> Id
forall a. Num a => a -> a -> a
+ Id
1 Id -> Id -> Id
forall a. Num a => a -> a -> a
+ Id
conIndex))
                      fields :: [TermT n]
fields = ((TypeInfo (TermT n), TermT n) -> TermT n)
-> [(TypeInfo (TermT n), TermT n)] -> [TermT n]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInfo (TermT n), TermT n) -> TermT n
forall a b. (a, b) -> b
snd (Id
-> [(TypeInfo (TermT n), TermT n)]
-> [(TypeInfo (TermT n), TermT n)]
forall a. Id -> [a] -> [a]
drop Id
conNumParams [(TypeInfo (TermT n), TermT n)]
cargs)
                      prefixArgs :: [TermT n]
prefixArgs = ((TypeInfo (TermT n), TermT n) -> TermT n)
-> [(TypeInfo (TermT n), TermT n)] -> [TermT n]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInfo (TermT n), TermT n) -> TermT n
forall a b. (a, b) -> b
snd [(TypeInfo (TermT n), TermT n)]
beforeIndices
                  -- The method takes an induction hypothesis right after each
                  -- recursive field: the eliminator itself, applied to the
                  -- field's own indices (read off the field's type) and the
                  -- field. The spine is built here; evaluation stays lazy.
                  args <- ([[TermT n]] -> [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [[TermT n]]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall a b.
(a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [[TermT n]] -> [TermT n]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (ReaderT
   (Context n)
   (ExceptT TypeErrorInScopedContext (State CheckLog))
   [[TermT n]]
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [[TermT n]]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall a b. (a -> b) -> a -> b
$ [(Id, TermT n)]
-> ((Id, TermT n)
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [[TermT n]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Id] -> [TermT n] -> [(Id, TermT n)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Id
0 ..] [TermT n]
fields) (((Id, TermT n)
  -> ReaderT
       (Context n)
       (ExceptT TypeErrorInScopedContext (State CheckLog))
       [TermT n])
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      [[TermT n]])
-> ((Id, TermT n)
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         [TermT n])
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [[TermT n]]
forall a b. (a -> b) -> a -> b
$ \(Id
j, TermT n
fieldArg) ->
                    if Id
j Id -> [Id] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Id]
recIdxs
                      then do
                        fieldIxs <-
                          if Id
numIndices Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Id
0
                            then [TermT n]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
                            else do
                              fieldTy <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
fieldArg
                              case collectAppSpine fieldTy of
                                (Var Name n
d, [(TypeInfo (TermT n), TermT n)]
targs)
                                  | Name n -> Id
forall (l :: S). Name l -> Id
Foil.nameId Name n
d Id -> Id -> Bool
forall a. Eq a => a -> a -> Bool
== Name n -> Id
forall (l :: S). Name l -> Id
Foil.nameId Name n
dataType ->
                                      [TermT n]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (((TypeInfo (TermT n), TermT n) -> TermT n)
-> [(TypeInfo (TermT n), TermT n)] -> [TermT n]
forall a b. (a -> b) -> [a] -> [b]
map (TypeInfo (TermT n), TermT n) -> TermT n
forall a b. (a, b) -> b
snd (Id
-> [(TypeInfo (TermT n), TermT n)]
-> [(TypeInfo (TermT n), TermT n)]
forall a. Id -> [a] -> [a]
drop Id
conNumParams [(TypeInfo (TermT n), TermT n)]
targs))
                                (TermT n, [(TypeInfo (TermT n), TermT n)])
_ -> String
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall a. String -> a
panicImpossible
                                  String
"a recursive field's type is not the datatype"
                        ih <- applyTyped (Var v) (prefixArgs <> fieldIxs <> [fieldArg])
                        pure [fieldArg, ih]
                      else [TermT n]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [TermT n]
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [TermT n
fieldArg]
                  Just <$> applyTyped method (args <> map snd after)
            Maybe (DataRole n)
_ -> Maybe (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT n)
forall a. Maybe a
Nothing
          (TermT n, [(TypeInfo (TermT n), TermT n)])
_ -> Maybe (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT n)
forall a. Maybe a
Nothing
  Maybe (DataRole n)
_ -> Maybe (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT n)
forall a. Maybe a
Nothing
tryDataElimStep TermT n
_ [(TypeInfo (TermT n), TermT n)]
_ = Maybe (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT n)
forall a. Maybe a
Nothing

-- | Apply a term to arguments left to right, annotating each application
-- node with its actual type. The spine machinery reuses the annotations of
-- existing nodes, which a freshly built ι-redex does not have.
applyTyped :: Distinct n => TermT n -> [TermT n] -> TypeCheck n (TermT n)
applyTyped :: forall (n :: S).
Distinct n =>
TermT n -> [TermT n] -> TypeCheck n (TermT n)
applyTyped TermT n
f [] = TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
f
applyTyped TermT n
f (TermT n
x : [TermT n]
xs) = TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
f ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  TypeFunT TypeInfo (TermT n)
_info Binder
_orig TModality
_md TermT n
_param Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
_mtope ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret -> do
    retTy <- ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S).
Distinct n =>
ScopedTermT n -> TermT n -> TypeCheck n (TermT n)
instantiate ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret TermT n
x
    applyTyped (appT retTy f x) xs
  TermT n
_ -> String
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a. String -> a
panicImpossible String
"ι-rule applies a method beyond its arity"

-- | 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 :: forall (i :: S) (n :: S).
Distinct n =>
Scope n
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
-> TermT i
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
peelLambdas Scope n
scope Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
subst TermT i
body [(TypeInfo (TermT n), TermT n)]
pairs = case [(TypeInfo (TermT n), TermT n)]
pairs of
  [] -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT (Scope n
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
-> TermT i
-> TermT n
forall (o :: S) (i :: S).
Distinct o =>
Scope o
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i o
-> TermT i
-> TermT o
substituteT Scope n
scope Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
subst TermT i
body)
  (TypeInfo (TermT n)
_, TermT n
x) : [(TypeInfo (TermT n), TermT n)]
rest -> case TermT i
body of
    LambdaT TypeInfo (TermT i)
_ Binder
_ Maybe
  (LambdaParam
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) i) (TermT i))
_ (ScopedAST NameBinder i l
binder AST NameBinder (AnnSig TypeInfo TermSig) l
body') ->
      Scope n
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) l n
-> AST NameBinder (AnnSig TypeInfo TermSig) l
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
forall (i :: S) (n :: S).
Distinct n =>
Scope n
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
-> TermT i
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
peelLambdas Scope n
scope (Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
-> NameBinder i l
-> TermT n
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) l n
forall (e :: S -> *) (i :: S) (o :: S) (i' :: S).
Substitution e i o -> NameBinder i i' -> e o -> Substitution e i' o
Foil.addSubst Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
subst NameBinder i l
binder TermT n
x) AST NameBinder (AnnSig TypeInfo TermSig) l
body' [(TypeInfo (TermT n), TermT n)]
rest
    TermT i
_ -> Scope n
-> TermT n
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
forall (n :: S).
Distinct n =>
Scope n
-> TermT n
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
applySpine Scope n
scope (Scope n
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
-> TermT i
-> TermT n
forall (o :: S) (i :: S).
Distinct o =>
Scope o
-> Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i o
-> TermT i
-> TermT o
substituteT Scope n
scope Substitution (AST NameBinder (AnnSig TypeInfo TermSig)) i n
subst TermT i
body) [(TypeInfo (TermT n), TermT n)]
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 :: forall (n :: S).
Distinct n =>
Scope n
-> TermT n
-> [(TypeInfo (TermT n), TermT n)]
-> TypeCheck n (TermT n)
applyNeutral Scope n
_ TermT n
h [] = TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
h
applyNeutral Scope n
scope TermT n
h ((TypeInfo (TermT n)
ty, TermT n
x) : [(TypeInfo (TermT n), TermT n)]
rest) = do
  r <- TypeInfo (TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S).
Distinct n =>
TypeInfo (TermT n) -> TermT n -> TermT n -> TypeCheck n (TermT n)
applyWhnfFun TypeInfo (TermT n)
ty TermT n
h TermT n
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 :: forall (n :: S).
Distinct n =>
TypeInfo (TermT n) -> TermT n -> TermT n -> TypeCheck n (TermT n)
applyWhnfFun TypeInfo (TermT n)
ty TermT n
f' TermT n
x = TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
f' TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  TypeFunT TypeInfo (TermT n)
_ty Binder
_orig TModality
md TermT n
_param (Just ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
tope) (ScopedAST NameBinder n l
_ UniverseTopeT{}) -> do
    x' <- TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
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 TypeInfo (TermT n)
info Binder
_orig TModality
md TermT n
_param Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
_mtope ret :: ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret@(ScopedAST NameBinder n l
_ TypeRestrictedT{})
    | TypeRestrictedT{} <- TypeInfo (TermT n) -> TermT n
forall term. TypeInfo term -> term
infoType TypeInfo (TermT n)
info -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
AppT TypeInfo (TermT n)
ty TermT n
f' TermT n
x)
    | Bool
otherwise -> do
        x' <- TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
x
        ret' <- instantiate ret x'
        tryRestriction ret' >>= \case -- FIXME: too many unnecessary checks?
          Maybe (TermT n)
Nothing  -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
AppT TypeInfo (TermT n)
ty { infoType = ret' } TermT n
f' TermT n
x')
          Just TermT n
tt' -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
tt'
  TermT n
_ -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
AppT TypeInfo (TermT n)
ty TermT n
f' TermT n
x)

-- * Normal form of the tope layer

nfSupT :: TermT n -> TermT n -> TermT n -> TermT n
nfSupT :: forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
nfSupT TermT n
ty TermT n
l TermT n
r = case (TermT n
l, TermT n
r) of
  (Cube2_0T{}, TermT n
_) -> TermT n
r
  (TermT n
_, Cube2_0T{}) -> TermT n
l
  (Cube2_1T{}, TermT n
_) -> TermT n
l
  (TermT n
_, Cube2_1T{}) -> TermT n
r
  (CubeI_0T{}, TermT n
_) -> TermT n
r
  (TermT n
_, CubeI_0T{}) -> TermT n
l
  (CubeI_1T{}, TermT n
_) -> TermT n
l
  (TermT n
_, CubeI_1T{}) -> TermT n
r
  (TermT n, TermT n)
_               -> TermT n -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
cubeSupT TermT n
ty TermT n
l TermT n
r

nfInfT :: TermT n -> TermT n -> TermT n -> TermT n
nfInfT :: forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
nfInfT TermT n
ty TermT n
l TermT n
r = case (TermT n
l, TermT n
r) of
  (Cube2_0T{}, TermT n
_) -> TermT n
l
  (TermT n
_, Cube2_0T{}) -> TermT n
r
  (Cube2_1T{}, TermT n
_) -> TermT n
r
  (TermT n
_, Cube2_1T{}) -> TermT n
l
  (CubeI_0T{}, TermT n
_) -> TermT n
l
  (TermT n
_, CubeI_0T{}) -> TermT n
r
  (CubeI_1T{}, TermT n
_) -> TermT n
r
  (TermT n
_, CubeI_1T{}) -> TermT n
l
  (CubeSupT TypeInfo (TermT n)
_ TermT n
a TermT n
b, TermT n
_) -> TermT n -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
nfSupT TermT n
ty (TermT n -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
nfInfT TermT n
ty TermT n
a TermT n
r) (TermT n -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
nfInfT TermT n
ty TermT n
b TermT n
r)
  (TermT n
_, CubeSupT TypeInfo (TermT n)
_ TermT n
a TermT n
b) -> TermT n -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
nfSupT TermT n
ty (TermT n -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
nfInfT TermT n
ty TermT n
l TermT n
a) (TermT n -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
nfInfT TermT n
ty TermT n
l TermT n
b)
  (TermT n, TermT n)
_                   -> TermT n -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n -> TermT n
cubeInfT TermT n
ty TermT n
l TermT n
r

nfTope :: Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope :: forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt = Action n -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) a.
Distinct n =>
Action n -> TypeCheck n a -> TypeCheck n a
performing (TermT n -> Action n
forall (n :: S). TermT n -> Action n
ActionNF TermT n
tt) (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b.
(a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
termIsNF (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ case TermT n
tt of
  HoleT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Var Name n
x ->
    Name n -> TypeCheck n (Maybe (TermT n))
forall (n :: S). Name n -> TypeCheck n (Maybe (TermT n))
valueOfVar Name n
x TypeCheck n (Maybe (TermT n))
-> (Maybe (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (TermT n)
Nothing   -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (m :: * -> *) a. Monad m => a -> m a
return TermT n
tt
      Just TermT n
term -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
term

  -- see if a normal form is already available
  TermT n
_ | Just TypeInfo (TermT n)
info <- TermT n -> Maybe (TypeInfo (TermT n))
forall (n :: S). TermT n -> Maybe (TypeInfo (TermT n))
typeInfoOf TermT n
tt, Just TermT n
tt' <- TypeInfo (TermT n) -> Maybe (TermT n)
forall term. TypeInfo term -> Maybe term
infoNF TypeInfo (TermT n)
info -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt'

  -- universe constants
  UniverseT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  UniverseCubeT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  UniverseTopeT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- cube layer constants
  CubeUnitT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeUnitStarT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Cube2T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Cube2_0T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Cube2_1T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeIT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeI_0T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeI_1T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- type layer constants
  TypeUnitT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  UnitT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- cube layer with computation
  CubeProductT TypeInfo (TermT n)
_ty TermT n
l TermT n
r -> TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
cubeProductT (TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
l ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
r

  CubeFlipT TypeInfo (TermT n)
ty TermT n
t ->
    TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      CubeUnflipT TypeInfo (TermT n)
_ TermT n
t' -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t'
      Cube2_0T{}       -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
typeModalT TermT n
forall (n :: S). TermT n
cubeT TModality
Op TermT n
forall (n :: S). TermT n
cube2T) TModality
Op TermT n
forall (n :: S). TermT n
cube2_1T)
      Cube2_1T{}       -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
typeModalT TermT n
forall (n :: S). TermT n
cubeT TModality
Op TermT n
forall (n :: S). TermT n
cube2T) TModality
Op TermT n
forall (n :: S). TermT n
cube2_0T)
      CubeI_0T{}       -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
typeModalT TermT n
forall (n :: S). TermT n
cubeT TModality
Op TermT n
forall (n :: S). TermT n
cubeIT) TModality
Op TermT n
forall (n :: S). TermT n
cubeI_1T)
      CubeI_1T{}       -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
typeModalT TermT n
forall (n :: S). TermT n
cubeT TModality
Op TermT n
forall (n :: S). TermT n
cubeIT) TModality
Op TermT n
forall (n :: S). TermT n
cubeI_0T)
      TermT n
t'               -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
CubeFlipT TypeInfo (TermT n)
ty TermT n
t')

  CubeUnflipT TypeInfo (TermT n)
ty TermT n
t ->
    TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      CubeFlipT TypeInfo (TermT n)
_ TermT n
t'          -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t'
      ModAppT TypeInfo (TermT n)
_ TModality
Op Cube2_0T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
cube2_1T
      ModAppT TypeInfo (TermT n)
_ TModality
Op Cube2_1T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
cube2_0T
      ModAppT TypeInfo (TermT n)
_ TModality
Op CubeI_0T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
cubeI_1T
      ModAppT TypeInfo (TermT n)
_ TModality
Op CubeI_1T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
cubeI_0T
      TermT n
t'                      -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
CubeUnflipT TypeInfo (TermT n)
ty TermT n
t')

  CubeSupT TypeInfo (TermT n)
ty TermT n
l TermT n
r -> do
    l' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
l
    r' <- nfTope r
    pure (nfSupT (infoType ty) l' r')

  CubeInfT TypeInfo (TermT n)
ty TermT n
l TermT n
r -> do
    l' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
l
    r' <- nfTope r
    pure (nfInfT (infoType ty) l' r')

  -- tope layer constants
  TopeTopT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TopeBottomT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- tope layer with computation
  TopeAndT TypeInfo (TermT n)
ty TermT n
l TermT n
r ->
    TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
l TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      TopeBottomT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
topeBottomT
      TermT n
l' -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
r TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TopeBottomT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
topeBottomT
        TermT n
r'            -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TopeAndT TypeInfo (TermT n)
ty TermT n
l' TermT n
r')

  TopeOrT  TypeInfo (TermT n)
ty TermT n
l TermT n
r -> do
    l' <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
l
    r' <- nfTope r
    case (l', r') of
      (TopeBottomT{}, TermT n
_) -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
r'
      (TermT n
_, TopeBottomT{}) -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
l'
      (TermT n, TermT n)
_                  -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TopeOrT TypeInfo (TermT n)
ty TermT n
l' TermT n
r')

  TopeEQT  TypeInfo (TermT n)
ty TermT n
l TermT n
r -> TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TopeEQT  TypeInfo (TermT n)
ty (TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
l ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
r
  TopeLEQT TypeInfo (TermT n)
ty TermT n
l TermT n
r -> TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TopeLEQT TypeInfo (TermT n)
ty (TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
l ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
r

  TopeInvT TypeInfo (TermT n)
ty TermT n
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 TermT n
t of
      TopeTopT TypeInfo (TermT n)
_ -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> TypeCheck n (TermT n))
-> TermT n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT TermT n
forall (n :: S). TermT n
topeT TModality
Op TermT n
forall (n :: S). TermT n
topeTopT
      TopeBottomT TypeInfo (TermT n)
_ -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> TypeCheck n (TermT n))
-> TermT n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT TermT n
forall (n :: S). TermT n
topeT TModality
Op TermT n
forall (n :: S). TermT n
topeBottomT
      TopeLEQT TypeInfo (TermT n)
_ TermT n
x TermT n
y -> (TermT n -> TermT n -> TermT n)
-> TermT n -> TermT n -> TypeCheck n (TermT n)
forall {n :: S}.
Distinct n =>
(TermT n -> TermT n -> TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
invOf TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
y
      TopeEQT TypeInfo (TermT n)
_ TermT n
x TermT n
y -> (TermT n -> TermT n -> TermT n)
-> TermT n -> TermT n -> TypeCheck n (TermT n)
forall {n :: S}.
Distinct n =>
(TermT n -> TermT n -> TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
invOf TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
y
      TopeAndT TypeInfo (TermT n)
_ TermT n
phi TermT n
psi -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope (TermT n -> TypeCheck n (TermT n))
-> TermT n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$
        TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
typeModalT TermT n
forall (n :: S). TermT n
universeT TModality
Op TermT n
forall (n :: S). TermT n
topeT) TModality
Op
          (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeAndT
            (TermT n -> TModality -> TModality -> TermT n -> TermT n
forall (n :: S).
TermT n -> TModality -> TModality -> TermT n -> TermT n
modExtractT TermT n
forall (n :: S). TermT n
topeT TModality
Id TModality
Op (TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeInvT TermT n
phi))
            (TermT n -> TModality -> TModality -> TermT n -> TermT n
forall (n :: S).
TermT n -> TModality -> TModality -> TermT n -> TermT n
modExtractT TermT n
forall (n :: S). TermT n
topeT TModality
Id TModality
Op (TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeInvT TermT n
psi)))
      TopeOrT TypeInfo (TermT n)
_ TermT n
phi TermT n
psi -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope (TermT n -> TypeCheck n (TermT n))
-> TermT n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$
        TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
typeModalT TermT n
forall (n :: S). TermT n
universeT TModality
Op TermT n
forall (n :: S). TermT n
topeT) TModality
Op
          (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeOrT
            (TermT n -> TModality -> TModality -> TermT n -> TermT n
forall (n :: S).
TermT n -> TModality -> TModality -> TermT n -> TermT n
modExtractT TermT n
forall (n :: S). TermT n
topeT TModality
Id TModality
Op (TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeInvT TermT n
phi))
            (TermT n -> TModality -> TModality -> TermT n -> TermT n
forall (n :: S).
TermT n -> TModality -> TModality -> TermT n -> TermT n
modExtractT TermT n
forall (n :: S). TermT n
topeT TModality
Id TModality
Op (TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeInvT TermT n
psi)))
      TermT n
_ ->
        TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          TopeTopT TypeInfo (TermT n)
_       -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
topeTopT
          TopeBottomT TypeInfo (TermT n)
_    -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
topeBottomT
          TopeUninvT TypeInfo (TermT n)
_ TermT n
phi -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
phi
          TopeLEQT TypeInfo (TermT n)
_ TermT n
x TermT n
y   -> (TermT n -> TermT n -> TermT n)
-> TermT n -> TermT n -> TypeCheck n (TermT n)
forall {n :: S}.
Distinct n =>
(TermT n -> TermT n -> TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
invOf TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
y
          TopeEQT TypeInfo (TermT n)
_ TermT n
x TermT n
y    -> (TermT n -> TermT n -> TermT n)
-> TermT n -> TermT n -> TypeCheck n (TermT n)
forall {n :: S}.
Distinct n =>
(TermT n -> TermT n -> TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
invOf TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
y
          TermT n
t'               -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TopeInvT TypeInfo (TermT n)
ty TermT n
t')
    where
      invOf :: (TermT n -> TermT n -> TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
invOf TermT n -> TermT n -> TermT n
mk TermT n
x TermT n
y = do
        xTy <- TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
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 TypeInfo (TermT n)
ty TermT n
t ->
    case TermT n
t of
      ModAppT TypeInfo (TermT n)
_ TModality
Op TermT n
inner -> case TermT n
inner of
        TopeTopT TypeInfo (TermT n)
_ -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
topeTopT
        TopeBottomT TypeInfo (TermT n)
_ -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
topeBottomT
        TopeAndT TypeInfo (TermT n)
_ TermT n
phi TermT n
psi ->
          TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeAndT (TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeUninvT TermT n
phi) (TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeUninvT TermT n
psi))
        TopeOrT TypeInfo (TermT n)
_ TermT n
phi TermT n
psi ->
          TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope (TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeOrT (TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeUninvT TermT n
phi) (TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
topeUninvT TermT n
psi))
        TermT n
_ ->
          TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            TopeTopT TypeInfo (TermT n)
_ -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
topeTopT
            TopeBottomT TypeInfo (TermT n)
_ -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
forall (n :: S). TermT n
topeBottomT
            TopeInvT TypeInfo (TermT n)
_ TermT n
phi -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
phi
            ModAppT TypeInfo (TermT n)
_ TModality
Op TermT n
inner'' -> case TermT n
inner'' of
              TopeLEQT TypeInfo (TermT n)
_ TermT n
x TermT n
y -> (TermT n -> TermT n -> TermT n)
-> TermT n -> TermT n -> TypeCheck n (TermT n)
forall {n :: S}.
Distinct n =>
(TermT n -> TermT n -> TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
uninvOf TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeLEQT TermT n
x TermT n
y
              TopeEQT TypeInfo (TermT n)
_ TermT n
x TermT n
y -> (TermT n -> TermT n -> TermT n)
-> TermT n -> TermT n -> TypeCheck n (TermT n)
forall {n :: S}.
Distinct n =>
(TermT n -> TermT n -> TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
uninvOf TermT n -> TermT n -> TermT n
forall (n :: S). TermT n -> TermT n -> TermT n
topeEQT TermT n
x TermT n
y
              TermT n
inner' ->
                TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> TypeCheck n (TermT n))
-> TermT n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TopeUninvT TypeInfo (TermT n)
ty
                  (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
modAppT (TermT n -> TModality -> TermT n -> TermT n
forall (n :: S). TermT n -> TModality -> TermT n -> TermT n
typeModalT TermT n
forall (n :: S). TermT n
universeT TModality
Op TermT n
forall (n :: S). TermT n
topeT) TModality
Op TermT n
inner')
            TermT n
t' -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TopeUninvT TypeInfo (TermT n)
ty TermT n
t')
      TermT n
_ ->
        TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          TopeInvT TypeInfo (TermT n)
_ TermT n
phi -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
phi
          t' :: TermT n
t'@(ModAppT TypeInfo (TermT n)
_ TModality
Op TermT n
_) -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TopeUninvT TypeInfo (TermT n)
ty TermT n
t')
          TermT n
t' -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TopeUninvT TypeInfo (TermT n)
ty TermT n
t')
    where
      uninvOf :: (TermT n -> TermT n -> TermT n)
-> TermT n
-> TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
uninvOf TermT n -> TermT n -> TermT n
mk TermT n
x TermT n
y = do
        xTy <- TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
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 TypeInfo (TermT n)
_ty TermT n
term TermT n
_ty' -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
term

  PairT TypeInfo (TermT n)
ty TermT n
l TermT n
r -> TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
PairT TypeInfo (TermT n)
ty (TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
l ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
r

  AppT TypeInfo (TermT n)
ty TermT n
f TermT n
x ->
    TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
f TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      LambdaT TypeInfo (TermT n)
_ty Binder
_orig Maybe
  (LambdaParam
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n))
_arg ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body ->
        ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n -> TypeCheck n (TermT n)
forall (n :: S).
Distinct n =>
ScopedTermT n -> TermT n -> TypeCheck n (TermT n)
instantiate ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body TermT n
x TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope
      TermT n
f' -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). TermT n -> TypeCheck n (TermT n)
typeOfUncomputed TermT n
f' TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        TypeFunT TypeInfo (TermT n)
_ty Binder
_orig TModality
md TermT n
_param (Just ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
tope) (ScopedAST NameBinder n l
_ UniverseTopeT{}) -> do
          x' <- TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
x
          sideCondition <- instantiate tope x' >>= nfTope
          pure (topeAndT (AppT ty f' x') sideCondition)
        TermT n
_ -> TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
AppT TypeInfo (TermT n)
ty TermT n
f' (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
x

  FirstT TypeInfo (TermT n)
ty TermT n
t ->
    TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      PairT TypeInfo (TermT n)
_ty TermT n
x TermT n
_y -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
x
      TermT n
t'             -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
FirstT TypeInfo (TermT n)
ty TermT n
t')

  SecondT TypeInfo (TermT n)
ty TermT n
t ->
    TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      PairT TypeInfo (TermT n)
_ty TermT n
_x TermT n
y -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
y
      TermT n
t'             -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
SecondT TypeInfo (TermT n)
ty TermT n
t')

  LambdaT TypeInfo (TermT n)
ty Binder
orig Maybe
  (LambdaParam
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n))
_mparam ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body
    | TypeFunT TypeInfo (TermT n)
_ty Binder
_origF TModality
md TermT n
param Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
mtope ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
_ret <- TypeInfo (TermT n) -> TermT n
forall term. TypeInfo term -> term
infoType TypeInfo (TermT n)
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' <- Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TypeCheck l (TermT l))
-> TypeCheck n (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
forall (n :: S).
Distinct n =>
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedTermT n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TypeCheck l (TermT l))
-> TypeCheck n (ScopedTermT n)
underScope Binder
orig TModality
md TermT n
param Maybe (TermT n)
forall a. Maybe a
Nothing ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body TermT l -> TypeCheck l (TermT l)
forall (l :: S).
(DExt n l, Distinct l) =>
TermT l -> TypeCheck l (TermT l)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope
        pure (LambdaT ty orig (Just (LambdaParam md param mtope)) body')
  LambdaT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"lambda with a non-function type in the tope layer"

  ModAppT TypeInfo (TermT n)
ty TModality
md TermT n
b ->
    (TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
b) TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ModExtractT TypeInfo (TermT n)
_ TModality
_ TModality
inn TermT n
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
      TermT n
b' -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> TypeCheck n (TermT n))
-> TermT n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TypeInfo (TermT n) -> TModality -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> TModality
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
ModAppT TypeInfo (TermT n)
ty TModality
md TermT n
b'
  ModExtractT TypeInfo (TermT n)
ty TModality
app TModality
inn TermT n
b ->
    (TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
app (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
b) TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ModAppT TypeInfo (TermT n)
_ TModality
md TermT n
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
      TermT n
b' -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TermT n -> TypeCheck n (TermT n))
-> TermT n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TypeInfo (TermT n) -> TModality -> TModality -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> TModality
-> TModality
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
ModExtractT TypeInfo (TermT n)
ty TModality
app TModality
inn TermT n
b'
  LetModT TypeInfo (TermT n)
ty Binder
orig TModality
app TModality
inn Maybe (TermT n)
mparam Maybe (TermT n)
mmotive TermT n
val ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body ->
    (TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
app (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
val) TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      ModAppT TypeInfo (TermT n)
_ TModality
md TermT n
t | TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
inn ->
        ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n -> TypeCheck n (TermT n)
forall (n :: S).
Distinct n =>
ScopedTermT n -> TermT n -> TypeCheck n (TermT n)
instantiate ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope
      TermT n
b' | TModality -> Bool
forall m. ModeTheory m => m -> Bool
isRA TModality
inn -> do
        bty <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
b' TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          TypeModalT TypeInfo (TermT n)
_ TModality
_ TermT n
t -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
          TermT n
_ -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"not modal in letmod"
        instantiate body (modExtractT bty app inn b') >>= nfTope
      TermT n
b' -> do
        bty <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
b' TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          TypeModalT TypeInfo (TermT n)
_ TModality
_ TermT n
t -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
          TermT n
_ -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"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 mmotive val' body')

  TypeModalT TypeInfo (TermT n)
ty TModality
md TermT n
inner -> TypeInfo (TermT n) -> TModality -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> TModality
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TypeModalT TypeInfo (TermT n)
ty TModality
md (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
inner)
  LetT TypeInfo (TermT n)
_ty Binder
_orig Maybe (TermT n)
_mparam TermT n
val ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body -> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n -> TypeCheck n (TermT n)
forall (n :: S).
Distinct n =>
ScopedTermT n -> TermT n -> TypeCheck n (TermT n)
instantiate ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body TermT n
val TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope
  TypeFunT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"exposed function type in the tope layer"
  TypeSigmaT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"dependent sum type in the tope layer"
  TypeIdT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"identity type in the tope layer"
  ReflT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"refl in the tope layer"
  IdJT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"idJ eliminator in the tope layer"
  TypeRestrictedT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"extension types in the tope layer"
  MatchT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"a typed match survives elaboration"
  MatchArmT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"a typed match arm survives elaboration"

  -- 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{} -> TypeError n -> TypeCheck n (TermT n)
forall (n :: S) a. Distinct n => TypeError n -> TypeCheck n a
issueTypeError (TypeError n -> TypeCheck n (TermT n))
-> TypeError n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ String -> TypeError n
forall (n :: S). String -> TypeError n
TypeErrorOther String
"a recOR cannot appear in the tope layer"
  RecBottomT{} -> TypeError n -> TypeCheck n (TermT n)
forall (n :: S) a. Distinct n => TypeError n -> TypeCheck n a
issueTypeError (TypeError n -> TypeCheck n (TermT n))
-> TypeError n -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ String -> TypeError n
forall (n :: S). String -> TypeError n
TypeErrorOther String
"a recBOT cannot appear in the tope layer"

-- * Normal form

nfT :: Distinct n => TermT n -> TypeCheck n (TermT n)
nfT :: forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
tt = Action n -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) a.
Distinct n =>
Action n -> TypeCheck n a -> TypeCheck n a
performing (TermT n -> Action n
forall (n :: S). TermT n -> Action n
ActionNF TermT n
tt) (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ case TermT n
tt of
  -- universe constants
  UniverseT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  UniverseCubeT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  UniverseTopeT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- cube layer constants
  CubeUnitT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeUnitStarT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Cube2T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Cube2_0T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  Cube2_1T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeIT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeI_0T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  CubeI_1T{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- cube layer with computation
  CubeProductT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  CubeFlipT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  CubeUnflipT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  CubeSupT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  CubeInfT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt

  -- tope layer constants
  TopeTopT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TopeBottomT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- tope layer with computation
  TopeAndT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeOrT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeEQT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeLEQT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeInvT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt
  TopeUninvT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tt

  -- type layer constants
  ReflT TypeInfo (TermT n)
ty Maybe (TermT n, Maybe (TermT n))
_x -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeInfo (TermT n) -> Maybe (TermT n, Maybe (TermT n)) -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> Maybe
     (AST binder (AnnSig ann TermSig) n,
      Maybe (AST binder (AnnSig ann TermSig) n))
-> AST binder (AnnSig ann TermSig) n
ReflT TypeInfo (TermT n)
ty Maybe (TermT n, Maybe (TermT n))
forall a. Maybe a
Nothing)
  RecBottomT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  TypeUnitT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
  UnitT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt

  -- type ascriptions are ignored, since we already have a typechecked term
  TypeAscT TypeInfo (TermT n)
_ty TermT n
term TermT n
_ty' -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
term

  -- now we are in the type layer
  TermT n
_ ->
    TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
tt TypeCheck n (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (Maybe (TermT n)))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall (n :: S).
Distinct n =>
TermT n -> TypeCheck n (Maybe (TermT n))
tryRestriction ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Maybe (TermT n))
-> (Maybe (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Just TermT n
tt' -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
tt'
      Maybe (TermT n)
Nothing -> case TermT n
tt of
        -- a hole is opaque: it never reduces, it is already a normal form
        HoleT{} -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
        t :: TermT n
t@(Var Name n
x) ->
          Name n
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall (n :: S). Name n -> TypeCheck n (Maybe (TermT n))
valueOfVar Name n
x ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Maybe (TermT n))
-> (Maybe (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Maybe (TermT n)
Nothing   -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
            Just TermT n
term -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
term

        TypeFunT TypeInfo (TermT n)
ty Binder
orig TModality
md TermT n
param Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
mtope ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret -> do
          param' <- TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
param
          case mtope of
            Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
Nothing -> do
              ret' <- Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TypeCheck l (TermT l))
-> TypeCheck n (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
forall (n :: S).
Distinct n =>
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedTermT n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TypeCheck l (TermT l))
-> TypeCheck n (ScopedTermT n)
underScope Binder
orig TModality
md TermT n
param' Maybe (TermT n)
forall a. Maybe a
Nothing ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret TermT l -> TypeCheck l (TermT l)
forall (l :: S).
(DExt n l, Distinct l) =>
TermT l -> TypeCheck l (TermT l)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT
              pure (TypeFunT ty orig md param' Nothing ret')
            Just ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
tope -> do
              (tope', ret') <- Binder
-> TModality
-> TermT n
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TermT l -> TypeCheck l (TermT l, TermT l))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n,
      ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
forall (n :: S).
Distinct n =>
Binder
-> TModality
-> TermT n
-> ScopedTermT n
-> ScopedTermT n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TermT l -> TypeCheck l (TermT l, TermT l))
-> TypeCheck n (ScopedTermT n, ScopedTermT n)
underScope2 Binder
orig TModality
md TermT n
param' ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
tope ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
ret ((forall (l :: S).
  (DExt n l, Distinct l) =>
  TermT l -> TermT l -> TypeCheck l (TermT l, TermT l))
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n,
       ScopedAST NameBinder (AnnSig TypeInfo TermSig) n))
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TermT l -> TypeCheck l (TermT l, TermT l))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n,
      ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
forall a b. (a -> b) -> a -> b
$ \TermT l
topeBody TermT l
retBody -> do
                topeNF <- TermT l -> TypeCheck l (TermT l)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT l
topeBody
                retNF <- localTope topeNF (nfT retBody)
                pure (topeNF, retNF)
              pure (TypeFunT ty orig md param' (Just tope') ret')

        AppT TypeInfo (TermT n)
ty TermT n
f TermT n
x ->
          TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
f TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            LambdaT TypeInfo (TermT n)
_ty Binder
_orig Maybe
  (LambdaParam
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n))
_arg ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body ->
              ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n -> TypeCheck n (TermT n)
forall (n :: S).
Distinct n =>
ScopedTermT n -> TermT n -> TypeCheck n (TermT n)
instantiate ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body TermT n
x TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT
            TermT n
f' -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
f' TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              TypeFunT TypeInfo (TermT n)
_ty Binder
_orig TModality
md TermT n
_param (Just ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
tope) (ScopedAST NameBinder n l
_ UniverseTopeT{}) -> do
                x' <- TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
x
                sideCondition <- instantiate tope x' >>= nfT
                pure (topeAndT (AppT ty f' x') sideCondition)
              TermT n
_ -> do
                -- The ι-redex of a generated eliminator only exists at the
                -- node holding the full spine, which the recursion above
                -- never hands to 'whnfT' as a whole.
                let (TermT n
h, [(TypeInfo (TermT n), TermT n)]
pairs) = TermT n -> (TermT n, [(TypeInfo (TermT n), TermT n)])
forall (n :: S).
TermT n -> (TermT n, [(TypeInfo (TermT n), TermT n)])
collectAppSpine (TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
AppT TypeInfo (TermT n)
ty TermT n
f' TermT n
x)
                TermT n
-> [(TypeInfo (TermT n), TermT n)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall (n :: S).
Distinct n =>
TermT n
-> [(TypeInfo (TermT n), TermT n)] -> TypeCheck n (Maybe (TermT n))
tryDataElimStep TermT n
h [(TypeInfo (TermT n), TermT n)]
pairs ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Maybe (TermT n))
-> (Maybe (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                  Just TermT n
stepped -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
stepped
                  Maybe (TermT n)
Nothing      -> TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
AppT TypeInfo (TermT n)
ty (TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
f' ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
x
        LetT TypeInfo (TermT n)
_ty Binder
_orig Maybe (TermT n)
_mparam TermT n
val ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body ->
          ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> TermT n -> TypeCheck n (TermT n)
forall (n :: S).
Distinct n =>
ScopedTermT n -> TermT n -> TypeCheck n (TermT n)
instantiate ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body TermT n
val TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT
        LetModT TypeInfo (TermT n)
ty Binder
orig TModality
app TModality
inn Maybe (TermT n)
mparam Maybe (TermT n)
mmotive TermT n
val ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body ->
          (TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
app (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
val) TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ModAppT TypeInfo (TermT n)
_ TModality
md TermT n
t | TModality
md TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
inn -> do
              val' <- TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
t
              instantiate body val' >>= nfT
            TermT n
b' | TModality -> Bool
forall m. ModeTheory m => m -> Bool
isRA TModality
inn -> do
              bty <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
b' TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                TypeModalT TypeInfo (TermT n)
_ TModality
_ TermT n
t -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
                TermT n
_ -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"not modal in letmod"
              instantiate body (modExtractT bty app inn b') >>= nfT
            TermT n
b' -> do
              bty <- TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
typeOf TermT n
b' TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                TypeModalT TypeInfo (TermT n)
_ TModality
_ TermT n
t -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
t
                TermT n
_ -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"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 mmotive val' body')
        LambdaT TypeInfo (TermT n)
ty Binder
orig Maybe
  (LambdaParam
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n) (TermT n))
_mparam ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body ->
          case TermT n -> TermT n
forall (n :: S). TermT n -> TermT n
stripTypeRestrictions (TypeInfo (TermT n) -> TermT n
forall term. TypeInfo term -> term
infoType TypeInfo (TermT n)
ty) of
            TypeFunT TypeInfo (TermT n)
_ty Binder
_orig TModality
md TermT n
param Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
mtope ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
_ret -> do
              param' <- TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
param
              case mtope of
                Maybe (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
Nothing -> do
                  body' <- Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TypeCheck l (TermT l))
-> TypeCheck n (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
forall (n :: S).
Distinct n =>
Binder
-> TModality
-> TermT n
-> Maybe (TermT n)
-> ScopedTermT n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TypeCheck l (TermT l))
-> TypeCheck n (ScopedTermT n)
underScope Binder
orig TModality
md TermT n
param' Maybe (TermT n)
forall a. Maybe a
Nothing ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body TermT l -> TypeCheck l (TermT l)
forall (l :: S).
(DExt n l, Distinct l) =>
TermT l -> TypeCheck l (TermT l)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT
                  pure (LambdaT ty orig (Just (LambdaParam md param' Nothing)) body')
                Just ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
tope -> do
                  (tope', body') <- Binder
-> TModality
-> TermT n
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TermT l -> TypeCheck l (TermT l, TermT l))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n,
      ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
forall (n :: S).
Distinct n =>
Binder
-> TModality
-> TermT n
-> ScopedTermT n
-> ScopedTermT n
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TermT l -> TypeCheck l (TermT l, TermT l))
-> TypeCheck n (ScopedTermT n, ScopedTermT n)
underScope2 Binder
orig TModality
md TermT n
param' ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
tope ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
body ((forall (l :: S).
  (DExt n l, Distinct l) =>
  TermT l -> TermT l -> TypeCheck l (TermT l, TermT l))
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n,
       ScopedAST NameBinder (AnnSig TypeInfo TermSig) n))
-> (forall (l :: S).
    (DExt n l, Distinct l) =>
    TermT l -> TermT l -> TypeCheck l (TermT l, TermT l))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (ScopedAST NameBinder (AnnSig TypeInfo TermSig) n,
      ScopedAST NameBinder (AnnSig TypeInfo TermSig) n)
forall a b. (a -> b) -> a -> b
$ \TermT l
topeBody TermT l
bodyBody -> do
                    topeNF <- TermT l -> TypeCheck l (TermT l)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT l
topeBody
                    bodyNF <- localTope topeNF (nfT bodyBody)
                    pure (topeNF, bodyNF)
                  pure (LambdaT ty orig (Just (LambdaParam md param' (Just tope'))) body')
            TermT n
_ -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"lambda with a non-function type"

        TypeSigmaT TypeInfo (TermT n)
ty Binder
orig TModality
md TermT n
a ScopedAST NameBinder (AnnSig TypeInfo TermSig) n
b -> do
          a' <- TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
a
          b' <- underScope orig md a' Nothing b nfT
          pure (TypeSigmaT ty orig md a' b')
        PairT TypeInfo (TermT n)
ty TermT n
l TermT n
r -> TypeInfo (TermT n) -> TermT n -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
PairT TypeInfo (TermT n)
ty (TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
l ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
r
        FirstT TypeInfo (TermT n)
ty TermT n
t ->
          TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            PairT TypeInfo (TermT n)
_ TermT n
l TermT n
_r -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
l
            TermT n
t'           -> TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
FirstT TypeInfo (TermT n)
ty (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
t'
        SecondT TypeInfo (TermT n)
ty TermT n
t ->
          TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
t TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            PairT TypeInfo (TermT n)
_ TermT n
_l TermT n
r -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
r
            TermT n
t'           -> TypeInfo (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
SecondT TypeInfo (TermT n)
ty (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
t'

        TypeIdT TypeInfo (TermT n)
ty TermT n
x Maybe (TermT n)
_tA TermT n
y -> TypeInfo (TermT n)
-> TermT n -> Maybe (TermT n) -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> Maybe (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
TypeIdT TypeInfo (TermT n)
ty (TermT n -> Maybe (TermT n) -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n) -> TermT n -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
x ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Maybe (TermT n) -> TermT n -> TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT n)
forall a. Maybe a
Nothing ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
y
        IdJT TypeInfo (TermT n)
ty TermT n
tA TermT n
a TermT n
tC TermT n
d TermT n
x TermT n
p ->
          TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
p TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ReflT{} -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
d
            TermT n
p' -> TypeInfo (TermT n)
-> TermT n
-> TermT n
-> TermT n
-> TermT n
-> TermT n
-> TermT n
-> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
IdJT TypeInfo (TermT n)
ty (TermT n
 -> TermT n -> TermT n -> TermT n -> TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n -> TermT n -> TermT n -> TermT n -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
tA ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n -> TermT n -> TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n -> TermT n -> TermT n -> TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
a ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n -> TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n -> TermT n -> TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
tC ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n -> TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
d ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (TermT n -> TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
x ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
p'

        RecOrT TypeInfo (TermT n)
_ty [(TermT n, TermT n)]
rs ->
          [(TermT n, TermT n)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n))
forall (n :: S).
Distinct n =>
[(TermT n, TermT n)] -> TypeCheck n (Maybe (TermT n))
firstMatching [(TermT n, TermT n)]
rs ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (Maybe (TermT n))
-> (Maybe (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Just TermT n
tt' -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
tt'
            Maybe (TermT n)
Nothing
              | [TermT n
tt'] <- [TermT n] -> [TermT n]
forall (n :: S). Distinct n => [TermT n] -> [TermT n]
nubT (((TermT n, TermT n) -> TermT n)
-> [(TermT n, TermT n)] -> [TermT n]
forall a b. (a -> b) -> [a] -> [b]
map (TermT n, TermT n) -> TermT n
forall a b. (a, b) -> b
snd [(TermT n, TermT n)]
rs) -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
tt'
              | Bool
otherwise -> TermT n -> TypeCheck n (TermT n)
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TermT n
tt
        TypeModalT TypeInfo (TermT n)
ty TModality
md TermT n
b -> do
          b' <- TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
b
          pure (TypeModalT ty md b')
        ModAppT TypeInfo (TermT n)
ty TModality
md TermT n
b ->
          (TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
b) TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ModExtractT TypeInfo (TermT n)
_ TModality
app TModality
inn TermT n
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
app TModality
inn) (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
t
            TermT n
b' -> TypeInfo (TermT n) -> TModality -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> TModality
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
ModAppT TypeInfo (TermT n)
ty TModality
md (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
md (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
b')
        ModExtractT TypeInfo (TermT n)
ty TModality
app TModality
inn TermT n
b ->
          (TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
app (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
whnfT TermT n
b) TypeCheck n (TermT n)
-> (TermT n -> TypeCheck n (TermT n)) -> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            ModAppT TypeInfo (TermT n)
_ TModality
md TermT n
t | TModality
inn TModality -> TModality -> Bool
forall a. Eq a => a -> a -> Bool
== TModality
md -> TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality (TModality -> TModality -> TModality
forall m. ModeTheory m => m -> m -> m
comp TModality
app TModality
inn) (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
t
            TermT n
b' -> TypeInfo (TermT n) -> TModality -> TModality -> TermT n -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> TModality
-> TModality
-> AST binder (AnnSig ann TermSig) n
-> AST binder (AnnSig ann TermSig) n
ModExtractT TypeInfo (TermT n)
ty TModality
app TModality
inn (TermT n -> TermT n)
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TModality -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) b.
Distinct n =>
TModality -> TypeCheck n b -> TypeCheck n b
enterModality TModality
app (TypeCheck n (TermT n) -> TypeCheck n (TermT n))
-> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall a b. (a -> b) -> a -> b
$ TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
b')
        TypeRestrictedT TypeInfo (TermT n)
ty TermT n
type_ [(TermT n, TermT n)]
rs -> do
          rs' <- [(TermT n, TermT n)]
-> ((TermT n, TermT n)
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (Maybe (TermT n, TermT n)))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [Maybe (TermT n, TermT n)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(TermT n, TermT n)]
rs (((TermT n, TermT n)
  -> ReaderT
       (Context n)
       (ExceptT TypeErrorInScopedContext (State CheckLog))
       (Maybe (TermT n, TermT n)))
 -> ReaderT
      (Context n)
      (ExceptT TypeErrorInScopedContext (State CheckLog))
      [Maybe (TermT n, TermT n)])
-> ((TermT n, TermT n)
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (Maybe (TermT n, TermT n)))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [Maybe (TermT n, TermT n)]
forall a b. (a -> b) -> a -> b
$ \(TermT n
tope, TermT n
term) ->
            TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfTope TermT n
tope TypeCheck n (TermT n)
-> (TermT n
    -> ReaderT
         (Context n)
         (ExceptT TypeErrorInScopedContext (State CheckLog))
         (Maybe (TermT n, TermT n)))
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n, TermT n))
forall a b.
ReaderT
  (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> (a
    -> ReaderT
         (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              TopeBottomT{} -> Maybe (TermT n, TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     (Maybe (TermT n, TermT n))
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (TermT n, TermT n)
forall a. Maybe a
Nothing
              TermT n
tope' -> do
                term' <- TermT n -> TypeCheck n (TermT n) -> TypeCheck n (TermT n)
forall (n :: S) a.
Distinct n =>
TermT n -> TypeCheck n a -> TypeCheck n a
localTope TermT n
tope' (TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
term)
                return (Just (tope', term'))
          case catMaybes rs' of
            []   -> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
type_
            [(TermT n, TermT n)]
rs'' -> TypeInfo (TermT n) -> TermT n -> [(TermT n, TermT n)] -> TermT n
forall {binder :: S -> S -> *} {ann :: * -> *} {n :: S}.
ann (AST binder (AnnSig ann TermSig) n)
-> AST binder (AnnSig ann TermSig) n
-> [(AST binder (AnnSig ann TermSig) n,
     AST binder (AnnSig ann TermSig) n)]
-> AST binder (AnnSig ann TermSig) n
TypeRestrictedT TypeInfo (TermT n)
ty (TermT n -> [(TermT n, TermT n)] -> TermT n)
-> TypeCheck n (TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     ([(TermT n, TermT n)] -> TermT n)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TermT n -> TypeCheck n (TermT n)
forall (n :: S). Distinct n => TermT n -> TypeCheck n (TermT n)
nfT TermT n
type_ ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  ([(TermT n, TermT n)] -> TermT n)
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [(TermT n, TermT n)]
-> TypeCheck n (TermT n)
forall a b.
ReaderT
  (Context n)
  (ExceptT TypeErrorInScopedContext (State CheckLog))
  (a -> b)
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [(TermT n, TermT n)]
-> ReaderT
     (Context n)
     (ExceptT TypeErrorInScopedContext (State CheckLog))
     [(TermT n, TermT n)]
forall a.
a
-> ReaderT
     (Context n) (ExceptT TypeErrorInScopedContext (State CheckLog)) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [(TermT n, TermT n)]
rs''

        -- a match is elaborated into its eliminator spine during typechecking;
        -- a typed match node never exists
        MatchT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"a typed match survives elaboration"
        MatchArmT{} -> String -> TypeCheck n (TermT n)
forall a. String -> a
panicImpossible String
"a typed match arm survives elaboration"