{-# OPTIONS_GHC -Wunused-imports #-}
{-# LANGUAGE NondecreasingIndentation  #-}

{- | The occurs check for unification.  Does pruning on the fly.

  When hitting a meta variable:

  - Compute flex/rigid for its arguments.
  - Compare to allowed variables.
  - Mark arguments with rigid occurrences of disallowed variables for deletion.
  - Attempt to delete marked arguments.
  - We don't need to check for success, we can just continue occurs checking.
-}

module Mikan.TypeChecking.MetaVars.Occurs
  ( PruneResult(..)
  , killArgs
  , occursCheck
  , prune
  , rigidVarsNotContainedIn
  ) where

import Prelude hiding (null, zip, zipWith)

import Control.Monad.Except ( ExceptT, runExceptT, catchError, throwError )

import Data.Foldable (traverse_)
import Data.Functor
import Data.Set (Set)
import Data.Set qualified as Set

import Mikan.Benchmarking qualified as Bench

import Mikan.Syntax.Common
import Mikan.Syntax.Internal
import Mikan.Syntax.Internal.MetaVars

import Mikan.TypeChecking.Constraints
import Mikan.TypeChecking.Monad
import Mikan.TypeChecking.Monad.Benchmark qualified as Bench
import Mikan.TypeChecking.Reduce
import Mikan.TypeChecking.Pretty
import Mikan.TypeChecking.Free
import Mikan.TypeChecking.Free.Reduce
import Mikan.TypeChecking.Telescope
import Mikan.TypeChecking.ProjectionLike
import Mikan.TypeChecking.Substitute
import Mikan.TypeChecking.Datatypes
import Mikan.TypeChecking.Records
import {-# SOURCE #-} Mikan.TypeChecking.MetaVars

import Mikan.Utils.StrictReader
import Mikan.Utils.Either
import Mikan.Utils.List
import Mikan.Utils.ListInf qualified as ListInf
import Mikan.Utils.Maybe
import Mikan.Utils.Monad
import Mikan.Utils.Null
import Mikan.Utils.Permutation
import Mikan.Syntax.Common.Pretty (prettyShow)
import Mikan.Utils.Size
import Mikan.Utils.VarSet (VarSet)
import Mikan.Utils.VarSet qualified as VarSet
import Mikan.Utils.Zip

import Mikan.Utils.Impossible
import Mikan.Utils.ExpandCase

---------------------------------------------------------------------------
-- * MetaOccursCheck: going into definitions to exclude cyclic solutions

{- To address issue 585 (meta var occurrences in mutual defs)

data B : Type where
  inn : A -> B

out : B -> A
out (inn a) = a

postulate
  P : (y : A) (z : Unit -> B) → Type
  p : (x : Unit -> B) → P (out (x unit)) x

mutual
  d : Unit -> B
  d unit = inn _           -- Y

  g : P (out (d unit)) d
  g = p _             -- X

-- Agda solves  d unit = inn (out (d unit))
--
-- out (X unit) = out (d unit) = out (inn Y) = Y
-- X = d

When doing the occurs check on d, we need to look at the definition of
d to discover that it mentions X.

To this end, we extend the state by names of definitions that have to
be checked when they occur.  At the beginning, this is initialized
with the names in the current mutual block.  Each time we encounter a
name in the list during occurs check, we delete it (if check is
successful).  This way, we do not duplicate work.

-}

modifyOccursCheckDefs :: (Set QName -> Set QName) -> TCM ()
modifyOccursCheckDefs :: (Set QName -> Set QName) -> TCM ()
modifyOccursCheckDefs Set QName -> Set QName
f = (Set QName -> Identity (Set QName)) -> TCState -> Identity TCState
Lens' TCState (Set QName)
stOccursCheckDefs ((Set QName -> Identity (Set QName))
 -> TCState -> Identity TCState)
-> (Set QName -> Set QName) -> TCM ()
forall (m :: * -> *) a.
MonadTCState m =>
ASetter' TCState a -> (a -> a) -> m ()
`modifyingTC` Set QName -> Set QName
f

-- | Set the names of definitions to be looked at
--   to the defs in the current mutual block.
initOccursCheck :: MetaId -> MetaVariable -> TCM ()
initOccursCheck :: MetaId -> MetaVariable -> TCM ()
initOccursCheck MetaId
m MetaVariable
mv = (Set QName -> Set QName) -> TCM ()
modifyOccursCheckDefs ((Set QName -> Set QName) -> TCM ())
-> (Set QName -> Set QName -> Set QName) -> Set QName -> TCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set QName -> Set QName -> Set QName
forall a b. a -> b -> a
const (Set QName -> TCM ()) -> TCMT IO (Set QName) -> TCM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
  if (MetaInfo -> RunMetaOccursCheck
miMetaOccursCheck (MetaVariable -> MetaInfo
mvInfo MetaVariable
mv) RunMetaOccursCheck -> RunMetaOccursCheck -> Bool
forall a. Eq a => a -> a -> Bool
== RunMetaOccursCheck
DontRunMetaOccursCheck)
   then do
     String -> Int -> String -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> String -> m ()
reportSLn String
"tc.meta.occurs" Int
20 (String -> TCM ()) -> String -> TCM ()
forall a b. (a -> b) -> a -> b
$
       String
"initOccursCheck: we do not look into definitions"
     Set QName -> TCMT IO (Set QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Set QName
forall a. Set a
Set.empty
   else do
    mb <- Lens' TCEnv (Maybe MutualId) -> TCMT IO (Maybe MutualId)
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (Maybe MutualId -> f (Maybe MutualId)) -> TCEnv -> f TCEnv
Lens' TCEnv (Maybe MutualId)
eMutualBlock TCMT IO (Maybe MutualId)
-> (Maybe MutualId -> TCMT IO (Set QName)) -> TCMT IO (Set QName)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe MutualId
Nothing -> Set QName -> TCMT IO (Set QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Set QName
forall a. Set a
Set.empty
      Just MutualId
b  -> do
        ds <- MutualBlock -> Set QName
mutualNames (MutualBlock -> Set QName)
-> TCMT IO MutualBlock -> TCMT IO (Set QName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MutualId -> TCMT IO MutualBlock
forall (tcm :: * -> *).
ReadTCState tcm =>
MutualId -> tcm MutualBlock
lookupMutualBlock MutualId
b
        return ds
    reportSDoc "tc.meta.occurs" 20 $ vcat
      [ "initOccursCheck for metavariable" <+> pretty m
      , nest 2 $ "definitions:" <+> prettyTCM mb
      ]
    pure mb


-- | Is a def in the list of stuff to be checked?
defNeedsChecking :: QName -> TCM Bool
defNeedsChecking :: QName -> TCM Bool
defNeedsChecking QName
d = QName -> Set QName -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member QName
d (Set QName -> Bool) -> TCMT IO (Set QName) -> TCM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Getter TCState (Set QName) -> TCMT IO (Set QName)
forall (m :: * -> *) a. ReadTCState m => Getter TCState a -> m a
useTC (Set QName -> f (Set QName)) -> TCState -> f TCState
Lens' TCState (Set QName)
Getter TCState (Set QName)
stOccursCheckDefs

-- | Remove a def from the list of defs to be looked at.
tallyDef :: QName -> TCM ()
tallyDef :: QName -> TCM ()
tallyDef QName
d = (Set QName -> Set QName) -> TCM ()
modifyOccursCheckDefs ((Set QName -> Set QName) -> TCM ())
-> (Set QName -> Set QName) -> TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> Set QName -> Set QName
forall a. Ord a => a -> Set a -> Set a
Set.delete QName
d

---------------------------------------------------------------------------
-- * OccursM monad and its services

-- | Environment for occurs checking.
data OccursEnv = OccursEnv
  { OccursEnv -> UnfoldStrategy
occUnfold    :: !UnfoldStrategy
  , OccursEnv -> MetaId
occMeta      :: !MetaId
    -- ^ The meta @m@ we want to solve.
  , OccursEnv -> VarSet
occVars      :: !VarSet
    -- ^ The allowed variables @xs@.
  , OccursEnv -> Term
occRHS       :: !Term
    -- ^ The proposed solution @v@ for the meta (@m xs := v@).
  , OccursEnv -> Int
occLocals    :: !Nat
    -- ^ Number of binders we have gone under while occurs-checking.
  , OccursEnv -> FlexRig' ()
occFlexRig   :: !(FlexRig' ())
    -- ^ Rigidity of the current position.
    --   NOTE: The strongly/weakly rigid distinction is not used here, so
    --   this is effectively a boolean. The distinction was introduced by
    --   9683fc2f3 and made irrelevant by 19b3e3084.
    --   This information is now only used to decide whether to raise an
    --   error when encountering an out-of-scope variable, which should
    --   always fail hard in rigid positions.
  , OccursEnv -> Bool
occUnderProp :: !Bool
    -- ^ Have we gone under a defnitionally irrelevant term?
    -- (If 'True': illegal variable occurrences should not be hard type
    -- errors.)
  }

instance LensFlexRig OccursEnv () where
  lensFlexRig :: Lens' OccursEnv (FlexRig' ())
lensFlexRig FlexRig' () -> f (FlexRig' ())
f OccursEnv
s = FlexRig' () -> f (FlexRig' ())
f (OccursEnv -> FlexRig' ()
occFlexRig OccursEnv
s) f (FlexRig' ()) -> (FlexRig' () -> OccursEnv) -> f OccursEnv
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \FlexRig' ()
e -> OccursEnv
s { occFlexRig = e }
  {-# INLINE lensFlexRig #-}

type OccursM = ReaderT OccursEnv TCM

metaCheck :: MetaId -> OccursM MetaId
metaCheck :: MetaId -> OccursM MetaId
metaCheck MetaId
m = do
  cxt <- ReaderT OccursEnv (TCMT IO) OccursEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  let m0  = OccursEnv -> MetaId
occMeta OccursEnv
cxt

  -- Check for loop
  --   don't fail hard on this, since we might still be on the top-level
  --   after some killing (Issue 442)
  --
  -- Andreas, 2013-02-18  Issue 795 demonstrates that a recursive
  -- occurrence of a meta could be solved by the identity.
  --   ? (Q A) = Q (? A)
  -- So, do not throw an error.
  -- I guess the error was there from times when occurrence check
  -- was done after the "lhs=linear variables" check, but now
  -- occurrence check comes first.
  -- WAS:
  -- when (m == m') $ if ctx == Top then patternViolation else
  --   abort ctx $ MetaOccursInItself m'
  -- Andreas, 2024-09-28: removed error MetaOccursInItself from code base.
  when (m == m0) $ patternViolation' neverUnblock 50 $ "occursCheck failed: Found " ++! prettyShow m

  return m

-- | Construct a test whether a de Bruijn index is allowed
--   or needs to be pruned.
allowedVars :: OccursM (Nat -> Bool)
allowedVars :: OccursM (Int -> Bool)
allowedVars = do
  -- @n@ is the number of binders we have stepped under.
  n  <- (OccursEnv -> Int) -> ReaderT OccursEnv (TCMT IO) Int
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks OccursEnv -> Int
occLocals
  xs <- asks occVars
  -- Bound variables are allowed, and those mentioned in occVars.
  return $! \ Int
i -> Int
i Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n Bool -> Bool -> Bool
|| (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
n) Int -> VarSet -> Bool
`VarSet.member` VarSet
xs

-- ** Unfolding during occurs check.

-- | Unfold definitions during occurs check?
--   This effectively runs the occurs check on the normal form.
data UnfoldStrategy = YesUnfold | NoUnfold
  deriving (UnfoldStrategy -> UnfoldStrategy -> Bool
(UnfoldStrategy -> UnfoldStrategy -> Bool)
-> (UnfoldStrategy -> UnfoldStrategy -> Bool) -> Eq UnfoldStrategy
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: UnfoldStrategy -> UnfoldStrategy -> Bool
== :: UnfoldStrategy -> UnfoldStrategy -> Bool
$c/= :: UnfoldStrategy -> UnfoldStrategy -> Bool
/= :: UnfoldStrategy -> UnfoldStrategy -> Bool
Eq, Int -> UnfoldStrategy -> String -> String
[UnfoldStrategy] -> String -> String
UnfoldStrategy -> String
(Int -> UnfoldStrategy -> String -> String)
-> (UnfoldStrategy -> String)
-> ([UnfoldStrategy] -> String -> String)
-> Show UnfoldStrategy
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> UnfoldStrategy -> String -> String
showsPrec :: Int -> UnfoldStrategy -> String -> String
$cshow :: UnfoldStrategy -> String
show :: UnfoldStrategy -> String
$cshowList :: [UnfoldStrategy] -> String -> String
showList :: [UnfoldStrategy] -> String -> String
Show)

-- | In the arguments of a variable or a constructor, run flexibly if one of the
--   arguments is an interval application and we are not unfolding: in that case we still have hope that
--   variable occurrences will vanish after normalisation (e.g. c es i0 → a).
--   This is a heuristic, but when in doubt we should be flexible: the
--   worst that can happen is that we run the occurs check again with normalisation
--   (whereas defaulting to rigid might reject solvable constraints).
flexiblyIApply :: Elims -> OccursM a -> OccursM a
flexiblyIApply :: forall a. Elims -> OccursM a -> OccursM a
flexiblyIApply Elims
es OccursM a
m = (OccursEnv -> UnfoldStrategy)
-> ReaderT OccursEnv (TCMT IO) UnfoldStrategy
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks OccursEnv -> UnfoldStrategy
occUnfold ReaderT OccursEnv (TCMT IO) UnfoldStrategy
-> (UnfoldStrategy -> OccursM a) -> OccursM a
forall a b.
ReaderT OccursEnv (TCMT IO) a
-> (a -> ReaderT OccursEnv (TCMT IO) b)
-> ReaderT OccursEnv (TCMT IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  UnfoldStrategy
YesUnfold -> OccursM a
m
  UnfoldStrategy
NoUnfold
    | (Elim' Term -> Bool) -> Elims -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\case { IApply{} -> Bool
True ; Elim' Term
_ -> Bool
False }) Elims
es -> OccursM a -> OccursM a
forall a. OccursM a -> OccursM a
flexibly OccursM a
m
    | Bool
otherwise                                        -> OccursM a
m
{-# INLINE flexiblyIApply #-}

-- | In the arguments of a definition, always run flexibly if we are not unfolding,
--   since unfolding the definition could result in occurrences vanishing.
defArgs :: QName -> Elims -> OccursM Elims
defArgs :: QName -> Elims -> OccursM Elims
defArgs QName
d Elims
vs = do
  m <- (OccursEnv -> MetaId) -> OccursM MetaId
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks OccursEnv -> MetaId
occMeta
  u <- asks occUnfold
  lift $ metaOccurs m d
  ifM (liftTCM $ isJust <$> isDataOrRecordType d) (occurs vs) case u of
    UnfoldStrategy
NoUnfold  -> OccursM Elims -> OccursM Elims
forall a. OccursM a -> OccursM a
flexibly (OccursM Elims -> OccursM Elims) -> OccursM Elims -> OccursM Elims
forall a b. (a -> b) -> a -> b
$ Elims -> OccursM Elims
forall t. Occurs t => t -> OccursM t
occurs Elims
vs
    UnfoldStrategy
YesUnfold -> Elims -> OccursM Elims
forall t. Occurs t => t -> OccursM t
occurs Elims
vs
{-# INLINE defArgs #-}

unfoldB :: (Instantiate t, Reduce t) => t -> OccursM (Blocked t)
unfoldB :: forall t. (Instantiate t, Reduce t) => t -> OccursM (Blocked t)
unfoldB t
v = (OccursEnv -> UnfoldStrategy)
-> ReaderT OccursEnv (TCMT IO) UnfoldStrategy
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks OccursEnv -> UnfoldStrategy
occUnfold ReaderT OccursEnv (TCMT IO) UnfoldStrategy
-> (UnfoldStrategy -> ReaderT OccursEnv (TCMT IO) (Blocked t))
-> ReaderT OccursEnv (TCMT IO) (Blocked t)
forall a b.
ReaderT OccursEnv (TCMT IO) a
-> (a -> ReaderT OccursEnv (TCMT IO) b)
-> ReaderT OccursEnv (TCMT IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  UnfoldStrategy
YesUnfold -> t -> ReaderT OccursEnv (TCMT IO) (Blocked t)
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB t
v
  UnfoldStrategy
_         -> t -> Blocked t
forall a t. a -> Blocked' t a
notBlocked (t -> Blocked t)
-> ReaderT OccursEnv (TCMT IO) t
-> ReaderT OccursEnv (TCMT IO) (Blocked t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> ReaderT OccursEnv (TCMT IO) t
forall a (m :: * -> *). (Instantiate a, MonadReduce m) => a -> m a
instantiate t
v
{-# INLINE unfoldB #-}

unfold :: (Instantiate t, Reduce t) => t -> OccursM t
unfold :: forall t. (Instantiate t, Reduce t) => t -> OccursM t
unfold t
v = (OccursEnv -> UnfoldStrategy)
-> ReaderT OccursEnv (TCMT IO) UnfoldStrategy
forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks OccursEnv -> UnfoldStrategy
occUnfold ReaderT OccursEnv (TCMT IO) UnfoldStrategy
-> (UnfoldStrategy -> ReaderT OccursEnv (TCMT IO) t)
-> ReaderT OccursEnv (TCMT IO) t
forall a b.
ReaderT OccursEnv (TCMT IO) a
-> (a -> ReaderT OccursEnv (TCMT IO) b)
-> ReaderT OccursEnv (TCMT IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  UnfoldStrategy
NoUnfold  -> t -> ReaderT OccursEnv (TCMT IO) t
forall a (m :: * -> *). (Instantiate a, MonadReduce m) => a -> m a
instantiate t
v
  UnfoldStrategy
YesUnfold -> t -> ReaderT OccursEnv (TCMT IO) t
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce t
v
{-# INLINE unfold #-}

-- ** Managing rigidity during occurs check.

-- | Go under a flexible position.
flexibly :: OccursM a -> OccursM a
flexibly :: forall a. OccursM a -> OccursM a
flexibly = (OccursEnv -> OccursEnv)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a
forall a.
(OccursEnv -> OccursEnv)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local ((OccursEnv -> OccursEnv)
 -> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a)
-> (OccursEnv -> OccursEnv)
-> ReaderT OccursEnv (TCMT IO) a
-> ReaderT OccursEnv (TCMT IO) a
forall a b. (a -> b) -> a -> b
$ ASetter OccursEnv OccursEnv (FlexRig' ()) (FlexRig' ())
-> FlexRig' () -> OccursEnv -> OccursEnv
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter OccursEnv OccursEnv (FlexRig' ()) (FlexRig' ())
forall o a. LensFlexRig o a => Lens' o (FlexRig' a)
Lens' OccursEnv (FlexRig' ())
lensFlexRig (FlexRig' () -> OccursEnv -> OccursEnv)
-> FlexRig' () -> OccursEnv -> OccursEnv
forall a b. (a -> b) -> a -> b
$ () -> FlexRig' ()
forall a. a -> FlexRig' a
Flexible ()

-- ** Error throwing during occurs check.

patternViolation' :: MonadTCM m => Blocker -> Int -> String -> m a
patternViolation' :: forall (m :: * -> *) a.
MonadTCM m =>
Blocker -> Int -> String -> m a
patternViolation' Blocker
unblock Int
n String
err = TCM a -> m a
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM a -> m a) -> TCM a -> m a
forall a b. (a -> b) -> a -> b
$ do
  String -> Int -> String -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> String -> m ()
reportSLn String
"tc.meta.occurs" Int
n String
err
  Blocker -> TCM a
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
unblock

abort :: Blocker -> TypeError -> OccursM a
abort :: forall a. Blocker -> TypeError -> OccursM a
abort Blocker
unblock TypeError
err = do
  ctx <- ReaderT OccursEnv (TCMT IO) OccursEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
  lift $ do
    if | isFlexible ctx || occUnderProp ctx -> soft
       | otherwise                          -> hard
  where
  hard :: TCM a
hard = TypeError -> TCM a
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError TypeError
err -- here, throw an uncatchable error (unsolvable constraint)
  soft :: TCM a
soft = Blocker -> Int -> String -> TCM a
forall (m :: * -> *) a.
MonadTCM m =>
Blocker -> Int -> String -> m a
patternViolation' Blocker
unblock Int
70 (TypeError -> String
forall a. Show a => a -> String
show TypeError
err) -- throws a PatternErr, which leads to delayed constraint

---------------------------------------------------------------------------
-- * Implementation of the occurs check.

-- | Extended occurs check.
class Occurs t where
  occurs :: t -> OccursM t
  metaOccurs :: MetaId -> t -> TCM ()  -- raise exception if meta occurs in t

  default metaOccurs :: (Foldable f, Occurs a, f a ~ t) => MetaId -> t -> TCM ()
  metaOccurs = (a -> TCM ()) -> t -> TCM ()
(a -> TCM ()) -> f a -> TCM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ ((a -> TCM ()) -> t -> TCM ())
-> (MetaId -> a -> TCM ()) -> MetaId -> t -> TCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MetaId -> a -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs

type Variable = Int

metaOccurs2 :: (Occurs a, Occurs b) => MetaId -> a -> b -> TCM ()
metaOccurs2 :: forall a b. (Occurs a, Occurs b) => MetaId -> a -> b -> TCM ()
metaOccurs2 MetaId
m a
x b
y = MetaId -> a -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m a
x TCM () -> TCM () -> TCM ()
forall a b. TCMT IO a -> TCMT IO b -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MetaId -> b -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m b
y

metaOccurs3 :: (Occurs a, Occurs b, Occurs c) => MetaId -> a -> b -> c -> TCM ()
metaOccurs3 :: forall a b c.
(Occurs a, Occurs b, Occurs c) =>
MetaId -> a -> b -> c -> TCM ()
metaOccurs3 MetaId
m a
x b
y c
z = MetaId -> a -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m a
x TCM () -> TCM () -> TCM ()
forall a b. TCMT IO a -> TCMT IO b -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MetaId -> b -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m b
y TCM () -> TCM () -> TCM ()
forall a b. TCMT IO a -> TCMT IO b -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> MetaId -> c -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m c
z

-- | Keep track that we're going under an irrelevant term, to postpone
-- instead of erroring on illegal variable occurrences.
underProp :: OccursM a -> OccursM a
underProp :: forall a. OccursM a -> OccursM a
underProp = (OccursEnv -> OccursEnv)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a
forall a.
(OccursEnv -> OccursEnv)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local (\OccursEnv
e -> OccursEnv
e { occUnderProp = True }) (ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a)
-> (ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a)
-> ReaderT OccursEnv (TCMT IO) a
-> ReaderT OccursEnv (TCMT IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a
forall (m :: * -> *) a. MonadTCEnv m => m a -> m a
onlyReduceTypes

-- | Bump the number of locals introduced during occurs checking.
underAbs :: OccursM a -> OccursM a
underAbs :: forall a. OccursM a -> OccursM a
underAbs = (OccursEnv -> OccursEnv)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a
forall a.
(OccursEnv -> OccursEnv)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a
forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local \OccursEnv
e -> OccursEnv
e { occLocals = 1 + occLocals e }

-- | When assigning @m xs := v@, check that @m@ does not occur in @v@
--   and that the free variables of @v@ are contained in @xs@.
occursCheck
  :: MetaId -> VarSet -> Term -> TCM Term
occursCheck :: MetaId -> VarSet -> Term -> TCM Term
occursCheck MetaId
m VarSet
xs Term
v = Account (BenchPhase (TCMT IO)) -> TCM Term -> TCM Term
forall (m :: * -> *) c.
MonadBench m =>
Account (BenchPhase m) -> m c -> m c
Bench.billTo [ BenchPhase (TCMT IO)
Phase
Bench.Typing, BenchPhase (TCMT IO)
Phase
Bench.OccursCheck ] (TCM Term -> TCM Term) -> TCM Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ do
  mv <- MetaId -> TCMT IO MetaVariable
forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m MetaVariable
lookupLocalMeta MetaId
m
  reportSDoc "tc.meta.occurs" 65 $ "occursCheck" <+> pretty m <+> prettyTCM xs
  let initEnv UnfoldStrategy
unf = OccursEnv
        { occUnfold :: UnfoldStrategy
occUnfold    = UnfoldStrategy
unf
        , occMeta :: MetaId
occMeta      = MetaId
m
        , occVars :: VarSet
occVars      = VarSet
xs
        , occRHS :: Term
occRHS       = Term
v
        , occLocals :: Int
occLocals    = Int
0
        , occUnderProp :: Bool
occUnderProp = Bool
False
        , occFlexRig :: FlexRig' ()
occFlexRig   = FlexRig' ()
forall a. FlexRig' a
StronglyRigid -- ? Unguarded
        }
  initOccursCheck m mv
  -- First try without normalising the term
  occurs v `runReaderT` initEnv NoUnfold `catchError` \case
    -- If first run is inconclusive, try again with normalization
    PatternErr{} -> do
      MetaId -> MetaVariable -> TCM ()
initOccursCheck MetaId
m MetaVariable
mv
      Term -> OccursM Term
forall t. Occurs t => t -> OccursM t
occurs Term
v OccursM Term -> OccursEnv -> TCM Term
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` UnfoldStrategy -> OccursEnv
initEnv UnfoldStrategy
YesUnfold
    TCErr
err -> TCErr -> TCM Term
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err

instance Occurs Term where
  occurs :: Term -> OccursM Term
occurs !Term
v = do
    vb <- Term -> OccursM (Blocked Term)
forall t. (Instantiate t, Reduce t) => t -> OccursM (Blocked t)
unfoldB Term
v
    m  <- occMeta <$> ask
    let
      block = Blocked Term -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked Term
vb

      -- On a failure, we should retry when any meta that is blocking
      -- the term is solved.
      flexIfBlocked OccursM Term
cont = ((OccursM Term -> Result LiftedRep (OccursM Term))
 -> Result LiftedRep (OccursM Term))
-> OccursM Term
forall a.
ExpandCase LiftedRep a =>
((a -> Result LiftedRep a) -> Result LiftedRep a) -> a
expand \OccursM Term -> Result LiftedRep (OccursM Term)
ret -> if
        -- In the metavariable case we should not yet become flexible
        -- because otherwise pruning won't fire.
        | MetaV{} <- Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
vb -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ Blocker -> OccursM Term -> OccursM Term
forall (m :: * -> *) a.
(PureTCM m, MonadBlock m) =>
Blocker -> m a -> m a
addOrUnblocker Blocker
block OccursM Term
cont
        | Blocker
block Blocker -> Blocker -> Bool
forall a. Eq a => a -> a -> Bool
/= Blocker
neverUnblock -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ OccursM Term -> OccursM Term
forall a. OccursM a -> OccursM a
flexibly (OccursM Term -> OccursM Term) -> OccursM Term -> OccursM Term
forall a b. (a -> b) -> a -> b
$ Blocker -> OccursM Term -> OccursM Term
forall (m :: * -> *) a.
(PureTCM m, MonadBlock m) =>
Blocker -> m a -> m a
addOrUnblocker Blocker
block OccursM Term
cont
        -- Re #3594, do not fail hard when Underapplied:
        -- the occurrence could be computed away after eta expansion.
        | NotBlocked{blockingStatus :: forall t a. Blocked' t a -> NotBlocked' t
blockingStatus = NotBlocked' Term
Underapplied} <- Blocked Term
vb -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ OccursM Term -> OccursM Term
forall a. OccursM a -> OccursM a
flexibly OccursM Term
cont
        | Bool
otherwise -> OccursM Term -> Result LiftedRep (OccursM Term)
ret OccursM Term
cont

    v <- reduceProjectionLike $ ignoreBlocking vb
    flexIfBlocked do
    ctx <- ask
    varAllowed <- allowedVars

    reportSDoc "tc.meta.occurs" 45 $
      text ("occursCheck " ++! prettyShow m ++! " (" ++! show (occFlexRig ctx) ++! ") of ") <+> prettyTCM v
    reportSDoc "tc.meta.occurs" 70 $
      nest 2 $ pretty v

    expand \OccursM Term -> Result LiftedRep (OccursM Term)
ret -> case Term
v of
      -- closed terms:
      Lit Literal
l       -> Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
v
      Dummy{}     -> Term -> IO Term
forall a. a -> IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
v

      -- structurally recursive cases:
      Lam ArgInfo
h Abs Term
f     -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
h (Abs Term -> Term)
-> ReaderT OccursEnv (TCMT IO) (Abs Term) -> OccursM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs Term -> ReaderT OccursEnv (TCMT IO) (Abs Term)
forall t. Occurs t => t -> OccursM t
occurs Abs Term
f
      Level Level
l     -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ Level -> Term
Level (Level -> Term)
-> ReaderT OccursEnv (TCMT IO) Level -> OccursM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level -> ReaderT OccursEnv (TCMT IO) Level
forall t. Occurs t => t -> OccursM t
occurs Level
l
      Pi Dom Type
a Abs Type
b      -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ Dom Type -> Abs Type -> Term
Pi    (Dom Type -> Abs Type -> Term)
-> ReaderT OccursEnv (TCMT IO) (Dom Type)
-> ReaderT OccursEnv (TCMT IO) (Abs Type -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom Type -> ReaderT OccursEnv (TCMT IO) (Dom Type)
forall t. Occurs t => t -> OccursM t
occurs Dom Type
a ReaderT OccursEnv (TCMT IO) (Abs Type -> Term)
-> ReaderT OccursEnv (TCMT IO) (Abs Type) -> OccursM Term
forall a b.
ReaderT OccursEnv (TCMT IO) (a -> b)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Abs Type -> ReaderT OccursEnv (TCMT IO) (Abs Type)
forall t. Occurs t => t -> OccursM t
occurs Abs Type
b
      Sort Sort
s      -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ Sort -> Term
Sort  (Sort -> Term) -> ReaderT OccursEnv (TCMT IO) Sort -> OccursM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall t. Occurs t => t -> OccursM t
occurs Sort
s
      DontCare Term
v  -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ Term -> Term
dontCare (Term -> Term) -> OccursM Term -> OccursM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OccursM Term -> OccursM Term
forall a. OccursM a -> OccursM a
underProp (Term -> OccursM Term
forall t. Occurs t => t -> OccursM t
occurs Term
v)
      Def QName
d Elims
es    -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ QName -> Elims -> Term
Def QName
d    (Elims -> Term) -> OccursM Elims -> OccursM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> Elims -> OccursM Elims
defArgs QName
d Elims
es
      Con ConHead
c ConInfo
ci Elims
vs -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ ConHead -> ConInfo -> Elims -> Term
Con ConHead
c ConInfo
ci (Elims -> Term) -> OccursM Elims -> OccursM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Elims -> OccursM Elims -> OccursM Elims
forall a. Elims -> OccursM a -> OccursM a
flexiblyIApply Elims
vs (Elims -> OccursM Elims
forall t. Occurs t => t -> OccursM t
occurs Elims
vs)

      -- interesting cases:
      Var Int
i Elims
es | Int -> Bool
varAllowed Int
i -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ Int -> Elims -> Term
Var Int
i (Elims -> Term) -> OccursM Elims -> OccursM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Elims -> OccursM Elims -> OccursM Elims
forall a. Elims -> OccursM a -> OccursM a
flexiblyIApply Elims
es (Elims -> OccursM Elims
forall t. Occurs t => t -> OccursM t
occurs Elims
es)
      Var Int
i Elims
es -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ Elims -> OccursM Term -> OccursM Term
forall a. Elims -> OccursM a -> OccursM a
flexiblyIApply Elims
es (OccursM Term -> OccursM Term) -> OccursM Term -> OccursM Term
forall a b. (a -> b) -> a -> b
$ do
        -- if the offending variable is of singleton type,
        -- eta-expand it away
        t <- Int -> ReaderT OccursEnv (TCMT IO) Type
forall (m :: * -> *). (MonadDebug m, MonadTCEnv m) => Int -> m Type
typeOfBV Int
i
        reportSDoc "tc.meta.occurs" 35 $
          "offending variable: " <+> prettyTCM (var i)
          $$ "of type " <+> prettyTCM t

        isST <- typeLevelReductions $ isSingletonType t
        reportSDoc "tc.meta.occurs" 35 $ nest 2 $ "(after singleton test)"

        case isST of
          -- not a singleton type
          Maybe Term
Nothing ->
            -- vv TODO: neverUnblock is not correct! What could trigger this eta expansion though?
            Blocker -> TypeError -> OccursM Term
forall a. Blocker -> TypeError -> OccursM a
abort Blocker
neverUnblock (TypeError -> OccursM Term) -> TypeError -> OccursM Term
forall a b. (a -> b) -> a -> b
$ MetaId -> Term -> Int -> TypeError
MetaCannotDependOn MetaId
m (OccursEnv -> Term
occRHS OccursEnv
ctx) Int
i
          -- is a singleton type with unique inhabitant sv
          Just Term
sv -> Term -> OccursM Term
forall a. a -> ReaderT OccursEnv (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> OccursM Term) -> Term -> OccursM Term
forall a b. (a -> b) -> a -> b
$! Term
sv Term -> Elims -> Term
forall t. Apply t => t -> Elims -> t
`applyE` Elims
es

      MetaV MetaId
m' Elims
es -> OccursM Term -> Result LiftedRep (OccursM Term)
ret (OccursM Term -> Result LiftedRep (OccursM Term))
-> OccursM Term -> Result LiftedRep (OccursM Term)
forall a b. (a -> b) -> a -> b
$ do
        m' <- MetaId -> OccursM MetaId
metaCheck MetaId
m'
        -- The arguments of a meta are in a flexible position
        (MetaV m' <$> do flexibly $ occurs es) `catchError` \ TCErr
err -> do
          ctx <- ReaderT OccursEnv (TCMT IO) OccursEnv
forall r (m :: * -> *). MonadReader r m => m r
ask
          reportSDoc "tc.meta.kill" 25 $ vcat
            [ text $ "error during flexible occurs check, we are " ++! show (ctx ^. lensFlexRig)
            , text $ show err
            ]
          case err of
            -- On pattern violations try to remove offending
            -- flexible occurrences (if not already in a flexible context)
            PatternErr{} | Bool -> Bool
not (OccursEnv -> Bool
forall o a. LensFlexRig o a => o -> Bool
isFlexible OccursEnv
ctx) -> do
              String -> Int -> String -> ReaderT OccursEnv (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> String -> m ()
reportSLn String
"tc.meta.kill" Int
20 (String -> ReaderT OccursEnv (TCMT IO) ())
-> String -> ReaderT OccursEnv (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$
                String
"oops, pattern violation for " String -> String -> String
forall a. [a] -> [a] -> [a]
++! MetaId -> String
forall a. Pretty a => a -> String
prettyShow MetaId
m'
              -- Andreas, 2014-03-02, see issue 1070:
              -- Do not prune when meta is projected!
              Maybe [Arg Term]
-> OccursM Term -> ([Arg Term] -> OccursM Term) -> OccursM Term
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (Elims -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es) (TCErr -> OccursM Term
forall a. TCErr -> ReaderT OccursEnv (TCMT IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err) (([Arg Term] -> OccursM Term) -> OccursM Term)
-> ([Arg Term] -> OccursM Term) -> OccursM Term
forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
vs -> do
                killResult <- TCMT IO PruneResult -> ReaderT OccursEnv (TCMT IO) PruneResult
forall (m :: * -> *) a. Monad m => m a -> ReaderT OccursEnv m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO PruneResult -> ReaderT OccursEnv (TCMT IO) PruneResult)
-> TCMT IO PruneResult -> ReaderT OccursEnv (TCMT IO) PruneResult
forall a b. (a -> b) -> a -> b
$ MetaId -> [Arg Term] -> (Int -> Bool) -> TCMT IO PruneResult
prune MetaId
m' [Arg Term]
vs Int -> Bool
varAllowed
                if killResult == PrunedEverything then do
                  -- after successful pruning, restart occurs check
                  reportSDoc "tc.meta.prune" 40 $ "Pruned everything"
                  occurs =<< instantiate (MetaV m' es)
                else throwError err
            TCErr
_ -> TCErr -> OccursM Term
forall a. TCErr -> ReaderT OccursEnv (TCMT IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err

  metaOccurs :: MetaId -> Term -> TCM ()
metaOccurs MetaId
m Term
v = do
    v <- Term -> TCM Term
forall a (m :: * -> *). (Instantiate a, MonadReduce m) => a -> m a
instantiate Term
v
    case v of
      Var Int
i Elims
vs   -> MetaId -> Elims -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Elims
vs
      Lam ArgInfo
h Abs Term
f    -> MetaId -> Abs Term -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Abs Term
f
      Level Level
l    -> MetaId -> Level -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Level
l
      Lit Literal
l      -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Dummy{}    -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      DontCare Term
v -> MetaId -> Term -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Term
v
      Def QName
d Elims
vs   -> MetaId -> QName -> Elims -> TCM ()
forall a b. (Occurs a, Occurs b) => MetaId -> a -> b -> TCM ()
metaOccurs2 MetaId
m QName
d Elims
vs
      Con ConHead
c ConInfo
_ Elims
vs -> MetaId -> Elims -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Elims
vs
      Pi Dom Type
a Abs Type
b     -> MetaId -> Dom Type -> Abs Type -> TCM ()
forall a b. (Occurs a, Occurs b) => MetaId -> a -> b -> TCM ()
metaOccurs2 MetaId
m Dom Type
a Abs Type
b
      Sort Sort
s     -> MetaId -> Sort -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Sort
s              -- vv m is already an unblocker
      MetaV MetaId
m' Elims
vs | MetaId
m MetaId -> MetaId -> Bool
forall a. Eq a => a -> a -> Bool
== MetaId
m'   -> Blocker -> Int -> String -> TCM ()
forall (m :: * -> *) a.
MonadTCM m =>
Blocker -> Int -> String -> m a
patternViolation' Blocker
neverUnblock Int
50 (String -> TCM ()) -> String -> TCM ()
forall a b. (a -> b) -> a -> b
$ String
"Found occurrence of " String -> String -> String
forall a. [a] -> [a] -> [a]
++! MetaId -> String
forall a. Pretty a => a -> String
prettyShow MetaId
m
                  | Bool
otherwise -> Blocker -> TCM () -> TCM ()
forall (m :: * -> *) a.
(PureTCM m, MonadBlock m) =>
Blocker -> m a -> m a
addOrUnblocker (MetaId -> Blocker
unblockOnMeta MetaId
m') (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ MetaId -> Elims -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Elims
vs

instance Occurs QName where
  occurs :: QName -> OccursM QName
occurs QName
d = OccursM QName
forall a. HasCallStack => a
__IMPOSSIBLE__

  metaOccurs :: MetaId -> QName -> TCM ()
metaOccurs MetaId
m QName
d = TCM Bool -> TCM () -> TCM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (QName -> TCM Bool
defNeedsChecking QName
d) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ Account (BenchPhase (TCMT IO)) -> TCM () -> TCM ()
forall (m :: * -> *) c.
MonadBench m =>
Account (BenchPhase m) -> m c -> m c
Bench.billTo [ BenchPhase (TCMT IO)
Phase
Bench.Typing, BenchPhase (TCMT IO)
Phase
Bench.OccursCheck, BenchPhase (TCMT IO)
Phase
Bench.OccursDef ] do
    QName -> TCM ()
tallyDef QName
d
    String -> Int -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.meta.occurs" Int
30 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Checking for occurrences in " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
d
    MetaId -> QName -> TCM ()
metaOccursQName MetaId
m QName
d

metaOccursQName :: MetaId -> QName -> TCM ()
metaOccursQName :: MetaId -> QName -> TCM ()
metaOccursQName MetaId
m QName
x = MetaId -> Defn -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m (Defn -> TCM ()) -> (Definition -> Defn) -> Definition -> TCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Defn
theDef (Definition -> TCM ()) -> TCMT IO Definition -> TCM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
  TCMT IO Definition -> TCMT IO Definition
forall (m :: * -> *) a. MonadTCEnv m => m a -> m a
ignoreAbstractMode (TCMT IO Definition -> TCMT IO Definition)
-> TCMT IO Definition -> TCMT IO Definition
forall a b. (a -> b) -> a -> b
$ QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
x
  -- Andreas, 2019-05-03, issue #3742:
  -- ignoreAbstractMode necessary, as abstract
  -- constructors are also called up.

instance Occurs Defn where
  occurs :: Defn -> OccursM Defn
occurs Defn
def = OccursM Defn
forall a. HasCallStack => a
__IMPOSSIBLE__

  metaOccurs :: MetaId -> Defn -> TCM ()
metaOccurs MetaId
m Axiom{}                      = () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  metaOccurs MetaId
m DataOrRecSig{}               = () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  metaOccurs MetaId
m Function{ funClauses :: Defn -> [Clause]
funClauses = [Clause]
cls } = (Clause -> TCM ()) -> [Clause] -> TCM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (MetaId -> Clause -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m) [Clause]
cls
  -- since a datatype is isomorphic to the sum of its constructor types
  -- we check the constructor types
  metaOccurs MetaId
m Datatype{ dataCons :: Defn -> [QName]
dataCons = [QName]
cs }    = (QName -> TCM ()) -> [QName] -> TCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (MetaId -> QName -> TCM ()
metaOccursQName MetaId
m) [QName]
cs
  metaOccurs MetaId
m Record{ recConHead :: Defn -> ConHead
recConHead = ConHead
c }     = MetaId -> QName -> TCM ()
metaOccursQName MetaId
m (QName -> TCM ()) -> QName -> TCM ()
forall a b. (a -> b) -> a -> b
$ ConHead -> QName
conName ConHead
c
  metaOccurs MetaId
m Constructor{}                = () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  metaOccurs MetaId
m Primitive{}                  = () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  metaOccurs MetaId
m PrimitiveSort{}              = TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__
  metaOccurs MetaId
m AbstractDefn{}               = TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__
  metaOccurs MetaId
m GeneralizableVar{}           = TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__

instance Occurs Clause where
  occurs :: Clause -> OccursM Clause
occurs Clause
cl = OccursM Clause
forall a. HasCallStack => a
__IMPOSSIBLE__

  metaOccurs :: MetaId -> Clause -> TCM ()
metaOccurs MetaId
m Clause
cl = Maybe Term -> (Term -> TCM ()) -> TCM ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (Clause -> Maybe Term
clauseBody Clause
cl) ((Term -> TCM ()) -> TCM ()) -> (Term -> TCM ()) -> TCM ()
forall a b. (a -> b) -> a -> b
$ MetaId -> Term -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m

instance Occurs Level where
  occurs :: Level -> ReaderT OccursEnv (TCMT IO) Level
occurs (Max Integer
n [PlusLevel' Term]
as) = Integer -> [PlusLevel' Term] -> Level
forall t. Integer -> [PlusLevel' t] -> Level' t
Max Integer
n ([PlusLevel' Term] -> Level)
-> ReaderT OccursEnv (TCMT IO) [PlusLevel' Term]
-> ReaderT OccursEnv (TCMT IO) Level
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PlusLevel' Term -> ReaderT OccursEnv (TCMT IO) (PlusLevel' Term))
-> [PlusLevel' Term]
-> ReaderT OccursEnv (TCMT IO) [PlusLevel' Term]
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 PlusLevel' Term -> ReaderT OccursEnv (TCMT IO) (PlusLevel' Term)
forall t. Occurs t => t -> OccursM t
occurs [PlusLevel' Term]
as

  metaOccurs :: MetaId -> Level -> TCM ()
metaOccurs MetaId
m (Max Integer
_ [PlusLevel' Term]
as) =
    Blocker -> TCM () -> TCM ()
forall (m :: * -> *) a.
(PureTCM m, MonadBlock m) =>
Blocker -> m a -> m a
addOrUnblocker ([PlusLevel' Term] -> Blocker
forall t. AllMetas t => t -> Blocker
unblockOnAnyMetaIn [PlusLevel' Term]
as) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ (PlusLevel' Term -> TCM ()) -> [PlusLevel' Term] -> TCM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
(a -> f b) -> t a -> f ()
traverse_ (MetaId -> PlusLevel' Term -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m) [PlusLevel' Term]
as
    -- TODO: Should only be blocking metas in as. But any meta that can
    --       let the Max make progress needs to be included. For instance,
    --       _1 ⊔ _2 = _1 should unblock on _2, even though _1 is the meta
    --       failing occurs check.

instance Occurs PlusLevel where
  occurs :: PlusLevel' Term -> ReaderT OccursEnv (TCMT IO) (PlusLevel' Term)
occurs (Plus Integer
n Term
l) = Integer -> Term -> PlusLevel' Term
forall t. Integer -> t -> PlusLevel' t
Plus Integer
n (Term -> PlusLevel' Term)
-> OccursM Term -> ReaderT OccursEnv (TCMT IO) (PlusLevel' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> OccursM Term
forall t. Occurs t => t -> OccursM t
occurs Term
l

  metaOccurs :: MetaId -> PlusLevel' Term -> TCM ()
metaOccurs MetaId
m (Plus Integer
n Term
l) = MetaId -> Term -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Term
l

instance Occurs Type where
  occurs :: Type -> ReaderT OccursEnv (TCMT IO) Type
occurs (El Sort
s Term
v) = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El (Sort -> Term -> Type)
-> ReaderT OccursEnv (TCMT IO) Sort
-> ReaderT OccursEnv (TCMT IO) (Term -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall t. Occurs t => t -> OccursM t
occurs Sort
s ReaderT OccursEnv (TCMT IO) (Term -> Type)
-> OccursM Term -> ReaderT OccursEnv (TCMT IO) Type
forall a b.
ReaderT OccursEnv (TCMT IO) (a -> b)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> OccursM Term
forall t. Occurs t => t -> OccursM t
occurs Term
v

  metaOccurs :: MetaId -> Type -> TCM ()
metaOccurs MetaId
m (El Sort
s Term
v) = MetaId -> Sort -> Term -> TCM ()
forall a b. (Occurs a, Occurs b) => MetaId -> a -> b -> TCM ()
metaOccurs2 MetaId
m Sort
s Term
v

instance Occurs Sort where
  occurs :: Sort -> ReaderT OccursEnv (TCMT IO) Sort
occurs !Sort
s = Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall t. (Instantiate t, Reduce t) => t -> OccursM t
unfold Sort
s ReaderT OccursEnv (TCMT IO) Sort
-> (Sort -> ReaderT OccursEnv (TCMT IO) Sort)
-> ReaderT OccursEnv (TCMT IO) Sort
forall a b.
ReaderT OccursEnv (TCMT IO) a
-> (a -> ReaderT OccursEnv (TCMT IO) b)
-> ReaderT OccursEnv (TCMT IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    -- closed sorts:
    s :: Sort
s@Inf{}        -> Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall a. a -> ReaderT OccursEnv (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
s
    s :: Sort
s@Sort
LevelUniv    -> Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall a. a -> ReaderT OccursEnv (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
s
    s :: Sort
s@Sort
IntervalUniv -> Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall a. a -> ReaderT OccursEnv (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
s
    s :: Sort
s@Sort
CofUniv      -> Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall a. a -> ReaderT OccursEnv (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
s
    s :: Sort
s@DummyS{}     -> Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall a. a -> ReaderT OccursEnv (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
s

    -- term-like sorts:
    MetaS MetaId
x Elims
es -> do
      MetaV x es <- Term -> OccursM Term
forall t. Occurs t => t -> OccursM t
occurs (MetaId -> Elims -> Term
MetaV MetaId
x Elims
es)
      return $! MetaS x es
    DefS QName
x Elims
es -> do
      Def x es <- Term -> OccursM Term
forall t. Occurs t => t -> OccursM t
occurs (QName -> Elims -> Term
Def QName
x Elims
es)
      return $! DefS x es

    PiSort Dom' Term Term
a Sort
s1 Abs Sort
s2 -> do
      s1' <- ReaderT OccursEnv (TCMT IO) Sort
-> ReaderT OccursEnv (TCMT IO) Sort
forall a. OccursM a -> OccursM a
flexibly (ReaderT OccursEnv (TCMT IO) Sort
 -> ReaderT OccursEnv (TCMT IO) Sort)
-> ReaderT OccursEnv (TCMT IO) Sort
-> ReaderT OccursEnv (TCMT IO) Sort
forall a b. (a -> b) -> a -> b
$ Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall t. Occurs t => t -> OccursM t
occurs Sort
s1
      a'  <- (a $>) <$> do flexibly $ occurs (unDom a)
      s2' <- mapAbstraction (El s1' <$> a') (flexibly . underAbs . occurs) s2
      return $! PiSort a' s1' s2'

    FunSort Sort
s1 Sort
s2 -> Sort -> Sort -> Sort
forall t. Sort' t -> Sort' t -> Sort' t
FunSort (Sort -> Sort -> Sort)
-> ReaderT OccursEnv (TCMT IO) Sort
-> ReaderT OccursEnv (TCMT IO) (Sort -> Sort)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT OccursEnv (TCMT IO) Sort
-> ReaderT OccursEnv (TCMT IO) Sort
forall a. OccursM a -> OccursM a
flexibly (Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall t. Occurs t => t -> OccursM t
occurs Sort
s1) ReaderT OccursEnv (TCMT IO) (Sort -> Sort)
-> ReaderT OccursEnv (TCMT IO) Sort
-> ReaderT OccursEnv (TCMT IO) Sort
forall a b.
ReaderT OccursEnv (TCMT IO) (a -> b)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> ReaderT OccursEnv (TCMT IO) Sort
-> ReaderT OccursEnv (TCMT IO) Sort
forall a. OccursM a -> OccursM a
flexibly (Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall t. Occurs t => t -> OccursM t
occurs Sort
s2)
    Univ Univ
u Level
a   -> Univ -> Level -> Sort
forall t. Univ -> Level' t -> Sort' t
Univ Univ
u (Level -> Sort)
-> ReaderT OccursEnv (TCMT IO) Level
-> ReaderT OccursEnv (TCMT IO) Sort
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level -> ReaderT OccursEnv (TCMT IO) Level
forall t. Occurs t => t -> OccursM t
occurs Level
a
    UnivSort Sort
s -> Sort -> Sort
forall t. Sort' t -> Sort' t
UnivSort (Sort -> Sort)
-> ReaderT OccursEnv (TCMT IO) Sort
-> ReaderT OccursEnv (TCMT IO) Sort
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT OccursEnv (TCMT IO) Sort
-> ReaderT OccursEnv (TCMT IO) Sort
forall a. OccursM a -> OccursM a
flexibly (Sort -> ReaderT OccursEnv (TCMT IO) Sort
forall t. Occurs t => t -> OccursM t
occurs Sort
s)

  metaOccurs :: MetaId -> Sort -> TCM ()
metaOccurs MetaId
m Sort
s = do
    s <- Sort -> TCMT IO Sort
forall a (m :: * -> *). (Instantiate a, MonadReduce m) => a -> m a
instantiate Sort
s
    case s of
      PiSort Dom' Term Term
a Sort
s1 Abs Sort
s2 -> do
        MetaId -> Dom' Term Term -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Dom' Term Term
a
        MetaId -> Sort -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Sort
s1
        MetaId -> Sort -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m (Abs Sort -> Sort
forall a. Subst a => Abs a -> a
absBody Abs Sort
s2)
      FunSort Sort
s1 Sort
s2 -> MetaId -> Sort -> Sort -> TCM ()
forall a b. (Occurs a, Occurs b) => MetaId -> a -> b -> TCM ()
metaOccurs2 MetaId
m Sort
s1 Sort
s2
      Univ Univ
_ Level
a   -> MetaId -> Level -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Level
a
      Inf Univ
_ Integer
_    -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Sort
LevelUniv  -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Sort
IntervalUniv -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Sort
CofUniv -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      UnivSort Sort
s -> MetaId -> Sort -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Sort
s
      MetaS MetaId
x Elims
es -> MetaId -> Term -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m (Term -> TCM ()) -> Term -> TCM ()
forall a b. (a -> b) -> a -> b
$ MetaId -> Elims -> Term
MetaV MetaId
x Elims
es
      DefS QName
d Elims
es  -> MetaId -> Term -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m (Term -> TCM ()) -> Term -> TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> Elims -> Term
Def QName
d Elims
es
      DummyS{}   -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

instance Occurs Elims where
  occurs :: Elims -> OccursM Elims
occurs []     = Elims -> OccursM Elims
forall a. a -> ReaderT OccursEnv (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
  occurs (Elim' Term
e:Elims
es) = do
    String -> Int -> TCMT IO Doc -> ReaderT OccursEnv (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.meta.occurs.elim" Int
45 (TCMT IO Doc -> ReaderT OccursEnv (TCMT IO) ())
-> TCMT IO Doc -> ReaderT OccursEnv (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"occurs" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Elim' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Elim' Term -> m Doc
prettyTCM Elim' Term
e
    String -> Int -> TCMT IO Doc -> ReaderT OccursEnv (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.meta.occurs.elim" Int
70 (TCMT IO Doc -> ReaderT OccursEnv (TCMT IO) ())
-> TCMT IO Doc -> ReaderT OccursEnv (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"occurs" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Elim' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Elim' Term
e
    e' <- case Elim' Term
e of
      Proj ProjOrigin
o QName
f     -> Elim' Term -> ReaderT OccursEnv (TCMT IO) (Elim' Term)
forall a. a -> ReaderT OccursEnv (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Elim' Term
e
      Apply Arg Term
u      -> Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply (Arg Term -> Elim' Term)
-> ReaderT OccursEnv (TCMT IO) (Arg Term)
-> ReaderT OccursEnv (TCMT IO) (Elim' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arg Term -> ReaderT OccursEnv (TCMT IO) (Arg Term)
forall t. Occurs t => t -> OccursM t
occurs Arg Term
u
      IApply Term
x Term
y Term
u -> Term -> Term -> Term -> Elim' Term
forall a. a -> a -> a -> Elim' a
IApply (Term -> Term -> Term -> Elim' Term)
-> OccursM Term
-> ReaderT OccursEnv (TCMT IO) (Term -> Term -> Elim' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> OccursM Term
forall t. Occurs t => t -> OccursM t
occurs Term
x ReaderT OccursEnv (TCMT IO) (Term -> Term -> Elim' Term)
-> OccursM Term -> ReaderT OccursEnv (TCMT IO) (Term -> Elim' Term)
forall a b.
ReaderT OccursEnv (TCMT IO) (a -> b)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> OccursM Term
forall t. Occurs t => t -> OccursM t
occurs Term
y ReaderT OccursEnv (TCMT IO) (Term -> Elim' Term)
-> OccursM Term -> ReaderT OccursEnv (TCMT IO) (Elim' Term)
forall a b.
ReaderT OccursEnv (TCMT IO) (a -> b)
-> ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> OccursM Term
forall t. Occurs t => t -> OccursM t
occurs Term
u
    (e':) <$!> occurs es

  metaOccurs :: MetaId -> Elims -> TCM ()
metaOccurs MetaId
m Elims
es = Elims -> (Elim' Term -> TCM ()) -> TCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ Elims
es ((Elim' Term -> TCM ()) -> TCM ())
-> (Elim' Term -> TCM ()) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \case
    Proj{} -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Apply Arg Term
a -> MetaId -> Arg Term -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Arg Term
a
    IApply Term
x Term
y Term
a -> MetaId -> Term -> Term -> Term -> TCM ()
forall a b c.
(Occurs a, Occurs b, Occurs c) =>
MetaId -> a -> b -> c -> TCM ()
metaOccurs3 MetaId
m Term
x Term
y Term
a

instance (Subst a, Occurs a) => Occurs (Abs a) where
  occurs :: Abs a -> OccursM (Abs a)
occurs (NoAbs ShortText
s a
x) = ShortText -> a -> Abs a
forall a. ShortText -> a -> Abs a
NoAbs ShortText
s (a -> Abs a) -> ReaderT OccursEnv (TCMT IO) a -> OccursM (Abs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReaderT OccursEnv (TCMT IO) a
forall t. Occurs t => t -> OccursM t
occurs a
x
  occurs Abs a
x = (a -> ReaderT OccursEnv (TCMT IO) a) -> Abs a -> OccursM (Abs a)
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
(a -> m b) -> Abs a -> m (Abs b)
mapAbstraction_ (ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a
forall a. OccursM a -> OccursM a
underAbs (ReaderT OccursEnv (TCMT IO) a -> ReaderT OccursEnv (TCMT IO) a)
-> (a -> ReaderT OccursEnv (TCMT IO) a)
-> a
-> ReaderT OccursEnv (TCMT IO) a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReaderT OccursEnv (TCMT IO) a
forall t. Occurs t => t -> OccursM t
occurs) Abs a
x

  metaOccurs :: MetaId -> Abs a -> TCM ()
metaOccurs MetaId
m (Abs   ShortText
_ a
x) = MetaId -> a -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m a
x
  metaOccurs MetaId
m (NoAbs ShortText
_ a
x) = MetaId -> a -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m a
x

instance Occurs a => Occurs (Arg a) where
  occurs :: Arg a -> OccursM (Arg a)
occurs (Arg ArgInfo
info a
v) = ArgInfo -> a -> Arg a
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info (a -> Arg a) -> ReaderT OccursEnv (TCMT IO) a -> OccursM (Arg a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReaderT OccursEnv (TCMT IO) a
forall t. Occurs t => t -> OccursM t
occurs a
v
  metaOccurs :: MetaId -> Arg a -> TCM ()
metaOccurs MetaId
m = MetaId -> a -> TCM ()
forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m (a -> TCM ()) -> (Arg a -> a) -> Arg a -> TCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg a -> a
forall e. Arg e -> e
unArg

instance Occurs a => Occurs (Dom a) where
  occurs :: Dom a -> OccursM (Dom a)
  occurs :: Dom a -> OccursM (Dom a)
occurs (Dom ArgInfo
info Maybe NamedName
n Bool
f Maybe Term
t a
x) =
    ArgInfo -> Maybe NamedName -> Bool -> Maybe Term -> a -> Dom a
forall t e.
ArgInfo -> Maybe NamedName -> Bool -> Maybe t -> e -> Dom' t e
Dom ArgInfo
info Maybe NamedName
n Bool
f Maybe Term
t (a -> Dom a) -> ReaderT OccursEnv (TCMT IO) a -> OccursM (Dom a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReaderT OccursEnv (TCMT IO) a
forall t. Occurs t => t -> OccursM t
occurs a
x

---------------------------------------------------------------------------
-- * Pruning: getting rid of flexible occurrences.

-- | @prune m' vs xs@ attempts to remove all arguments from @vs@ whose
--   free variables are not contained in @xs@.
--   If successful, @m'@ is solved by the new, pruned meta variable and we
--   return @True@ else @False@.
--
--   Issue 1147:
--   If any of the meta args @vs@ is matchable, e.g., is a constructor term,
--   we cannot prune, because the offending variables could be removed by
--   reduction for a suitable instantiation of the meta variable.
prune ::
     MetaId         -- ^ Meta to prune.
  -> Args           -- ^ Arguments to meta variable.
  -> (Nat -> Bool)  -- ^ Test for allowed variable (de Bruijn index).
  -> TCM PruneResult
prune :: MetaId -> [Arg Term] -> (Int -> Bool) -> TCMT IO PruneResult
prune MetaId
m' [Arg Term]
vs Int -> Bool
xs = do
  TCMT IO (Either () [Bool])
-> (() -> TCMT IO PruneResult)
-> ([Bool] -> TCMT IO PruneResult)
-> TCMT IO PruneResult
forall (m :: * -> *) a b c.
Monad m =>
m (Either a b) -> (a -> m c) -> (b -> m c) -> m c
caseEitherM (ExceptT () (TCMT IO) [Bool] -> TCMT IO (Either () [Bool])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT () (TCMT IO) [Bool] -> TCMT IO (Either () [Bool]))
-> ExceptT () (TCMT IO) [Bool] -> TCMT IO (Either () [Bool])
forall a b. (a -> b) -> a -> b
$ (Arg Term -> ExceptT () (TCMT IO) Bool)
-> [Arg Term] -> ExceptT () (TCMT IO) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (((Int -> Bool) -> Term -> ExceptT () (TCMT IO) Bool
hasBadRigid Int -> Bool
xs) (Term -> ExceptT () (TCMT IO) Bool)
-> (Arg Term -> Term) -> Arg Term -> ExceptT () (TCMT IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term]
vs)
    (TCMT IO PruneResult -> () -> TCMT IO PruneResult
forall a b. a -> b -> a
const (TCMT IO PruneResult -> () -> TCMT IO PruneResult)
-> TCMT IO PruneResult -> () -> TCMT IO PruneResult
forall a b. (a -> b) -> a -> b
$ PruneResult -> TCMT IO PruneResult
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PruneResult
PrunedNothing) (([Bool] -> TCMT IO PruneResult) -> TCMT IO PruneResult)
-> ([Bool] -> TCMT IO PruneResult) -> TCMT IO PruneResult
forall a b. (a -> b) -> a -> b
$ \ [Bool]
kills -> do
    String -> Int -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.meta.kill" Int
10 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ TCMT IO Doc
"attempting kills"
      , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"m'    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> MetaId -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty MetaId
m'
        -- , "xs    =" <+> prettyList (map (prettyTCM . var) xs)  -- no longer printable
        , TCMT IO Doc
"vs    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
prettyList ((Arg Term -> TCMT IO Doc) -> [Arg Term] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM [Arg Term]
vs)
        , TCMT IO Doc
"kills =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text ([Bool] -> String
forall a. Show a => a -> String
show [Bool]
kills)
        ]
      ]
    [Bool] -> MetaId -> TCMT IO PruneResult
killArgs [Bool]
kills MetaId
m'

-- | @hasBadRigid xs v = Just True@ iff one of the rigid variables in @v@ is not in @xs@.
--   Actually we can only prune if a bad variable is in the head. See issue 458.
--   Or in a non-eliminateable position (see succeed/PruningNonMillerPattern).
--
--   @hasBadRigid xs v = Nothing@ means that
--   we cannot prune at all as one of the meta args is matchable.
--   (See issue 1147.)
hasBadRigid ::
     (Nat -> Bool)      -- ^ Test for allowed variable (de Bruijn index).
  -> Term               -- ^ Argument of meta variable.
  -> ExceptT () TCM Bool  -- ^ Exception if argument is matchable.
hasBadRigid :: (Int -> Bool) -> Term -> ExceptT () (TCMT IO) Bool
hasBadRigid Int -> Bool
xs Term
t = do
  -- We fail if we encounter a matchable argument.
  let failure :: ExceptT () (TCMT IO) a
failure = () -> ExceptT () (TCMT IO) a
forall a. () -> ExceptT () (TCMT IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ()
  tb <- Term -> ExceptT () (TCMT IO) (Blocked Term)
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Term
t
  let t = Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
tb
  case t of
    Var Int
x Elims
_      -> Bool -> ExceptT () (TCMT IO) Bool
forall a. a -> ExceptT () (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ExceptT () (TCMT IO) Bool)
-> Bool -> ExceptT () (TCMT IO) Bool
forall a b. (a -> b) -> a -> b
$! Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Int -> Bool
xs Int
x
    -- Issue 1153: A lambda has to be considered matchable.
    -- Lam _ v    -> hasBadRigid (0 : map (+1) xs) (absBody v)
    Lam ArgInfo
_ Abs Term
v      -> ExceptT () (TCMT IO) Bool
forall {a}. ExceptT () (TCMT IO) a
failure
    DontCare Term
v   -> (Int -> Bool) -> Term -> ExceptT () (TCMT IO) Bool
hasBadRigid Int -> Bool
xs Term
v
    -- The following types of arguments cannot be eliminated by a pattern
    -- match: data, record, Pi, levels, sorts
    -- Thus, their offending rigid variables are bad.
    v :: Term
v@(Def QName
f Elims
es) -> ExceptT () (TCMT IO) Bool
-> ExceptT () (TCMT IO) Bool
-> ExceptT () (TCMT IO) Bool
-> ExceptT () (TCMT IO) Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM (Blocked Term -> QName -> Elims -> ExceptT () (TCMT IO) Bool
forall (m :: * -> *) t.
HasConstInfo m =>
Blocked t -> QName -> Elims -> m Bool
isNeutral Blocked Term
tb QName
f Elims
es) ExceptT () (TCMT IO) Bool
forall {a}. ExceptT () (TCMT IO) a
failure (ExceptT () (TCMT IO) Bool -> ExceptT () (TCMT IO) Bool)
-> ExceptT () (TCMT IO) Bool -> ExceptT () (TCMT IO) Bool
forall a b. (a -> b) -> a -> b
$ {- else -} do
      TCM Bool -> ExceptT () (TCMT IO) Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM Bool -> ExceptT () (TCMT IO) Bool)
-> TCM Bool -> ExceptT () (TCMT IO) Bool
forall a b. (a -> b) -> a -> b
$ Elims
es Elims -> (Int -> Bool) -> TCM Bool
forall (m :: * -> *) a.
(PureTCM m, AnyRigid a) =>
a -> (Int -> Bool) -> m Bool
`rigidVarsNotContainedIn` Int -> Bool
xs
    -- Andreas, 2012-05-03: There is room for further improvement.
    -- We could also consider a defined f which is not blocked by a meta.
    Pi Dom Type
a Abs Type
b       -> TCM Bool -> ExceptT () (TCMT IO) Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM Bool -> ExceptT () (TCMT IO) Bool)
-> TCM Bool -> ExceptT () (TCMT IO) Bool
forall a b. (a -> b) -> a -> b
$ (Dom Type
a,Abs Type
b) (Dom Type, Abs Type) -> (Int -> Bool) -> TCM Bool
forall (m :: * -> *) a.
(PureTCM m, AnyRigid a) =>
a -> (Int -> Bool) -> m Bool
`rigidVarsNotContainedIn` Int -> Bool
xs
    Level Level
v      -> TCM Bool -> ExceptT () (TCMT IO) Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM Bool -> ExceptT () (TCMT IO) Bool)
-> TCM Bool -> ExceptT () (TCMT IO) Bool
forall a b. (a -> b) -> a -> b
$ Level
v Level -> (Int -> Bool) -> TCM Bool
forall (m :: * -> *) a.
(PureTCM m, AnyRigid a) =>
a -> (Int -> Bool) -> m Bool
`rigidVarsNotContainedIn` Int -> Bool
xs
    Sort Sort
s       -> TCM Bool -> ExceptT () (TCMT IO) Bool
forall (m :: * -> *) a. Monad m => m a -> ExceptT () m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM Bool -> ExceptT () (TCMT IO) Bool)
-> TCM Bool -> ExceptT () (TCMT IO) Bool
forall a b. (a -> b) -> a -> b
$ Sort
s Sort -> (Int -> Bool) -> TCM Bool
forall (m :: * -> *) a.
(PureTCM m, AnyRigid a) =>
a -> (Int -> Bool) -> m Bool
`rigidVarsNotContainedIn` Int -> Bool
xs
    -- Since constructors can be eliminated by pattern-matching,
    -- offending variables under a constructor could be removed by
    -- the right instantiation of the meta variable.
    -- Thus, they are not rigid.
    Con ConHead
c ConInfo
_ Elims
es | Just [Arg Term]
args <- Elims -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es -> do
      ExceptT () (TCMT IO) Bool
-> ExceptT () (TCMT IO) Bool
-> ExceptT () (TCMT IO) Bool
-> ExceptT () (TCMT IO) Bool
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (QName -> ExceptT () (TCMT IO) Bool
forall (m :: * -> *).
(HasCallStack, HasConstInfo m) =>
QName -> m Bool
isEtaCon (ConHead -> QName
conName ConHead
c))
        -- in case of a record con, we can in principle prune
        -- (but not this argument; the meta could become a projection!)
        ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool)
-> ExceptT () (TCMT IO) [Bool] -> ExceptT () (TCMT IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Arg Term -> ExceptT () (TCMT IO) Bool)
-> [Arg Term] -> ExceptT () (TCMT IO) [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Int -> Bool) -> Term -> ExceptT () (TCMT IO) Bool
hasBadRigid Int -> Bool
xs (Term -> ExceptT () (TCMT IO) Bool)
-> (Arg Term -> Term) -> Arg Term -> ExceptT () (TCMT IO) Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term]
args)  -- not andM, we need to force the exceptions!
        ExceptT () (TCMT IO) Bool
forall {a}. ExceptT () (TCMT IO) a
failure
    Con ConHead
c ConInfo
_ Elims
es | Bool
otherwise -> ExceptT () (TCMT IO) Bool
forall {a}. ExceptT () (TCMT IO) a
failure
    Lit{}        -> ExceptT () (TCMT IO) Bool
forall {a}. ExceptT () (TCMT IO) a
failure -- matchable
    MetaV{}      -> ExceptT () (TCMT IO) Bool
forall {a}. ExceptT () (TCMT IO) a
failure -- potentially matchable
    Dummy{}      -> Bool -> ExceptT () (TCMT IO) Bool
forall a. a -> ExceptT () (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Check whether a term @Def f es@ is finally stuck.
--   Currently, we give only a crude approximation.
isNeutral :: (HasConstInfo m) => Blocked t -> QName -> Elims -> m Bool
isNeutral :: forall (m :: * -> *) t.
HasConstInfo m =>
Blocked t -> QName -> Elims -> m Bool
isNeutral Blocked t
b QName
f Elims
es = do
  let yes :: m Bool
yes = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      no :: m Bool
no  = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  def <- QName -> m Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
f
  case theDef def of
    AbstractDefn{} -> m Bool
yes
    Axiom{}    -> m Bool
yes
    Datatype{} -> m Bool
yes
    Record{}   -> m Bool
yes
    Function{} -> case Blocked t
b of
      NotBlocked StuckOn{}   t
_ -> m Bool
yes
      NotBlocked NotBlocked' Term
AbsurdMatch t
_ -> m Bool
yes
      Blocked t
_                        -> m Bool
no
    GeneralizableVar{} -> m Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
    Defn
_          -> m Bool
no

-- | Check whether any of the variables (given as de Bruijn indices)
--   occurs *definitely* in the term in a rigid position.
--   Reduces the term successively to remove variables in dead subterms.
--   This fixes issue 1386.
rigidVarsNotContainedIn
  :: (PureTCM m, AnyRigid a)
  => a
  -> (Nat -> Bool)   -- ^ Test for allowed variable (de Bruijn index).
  -> m Bool
rigidVarsNotContainedIn :: forall (m :: * -> *) a.
(PureTCM m, AnyRigid a) =>
a -> (Int -> Bool) -> m Bool
rigidVarsNotContainedIn a
v Int -> Bool
is = do
  n0 <- m Int
forall (m :: * -> *). MonadTCEnv m => m Int
getContextSize
  let -- allowed variables as de Bruijn levels
      levels = Int -> Bool
is (Int -> Bool) -> (Int -> Int) -> Int -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int
n0Int -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
-)
      -- test if index is forbidden by converting it to level
      test Int
i = do
        n <- m Int
forall (m :: * -> *). MonadTCEnv m => m Int
getContextSize
        -- get de Bruijn level for i
        let l = Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
i
            -- If l >= n0 then it is a bound variable and can be
            -- ignored.  Otherwise, it has to be in the allowed levels.
            forbidden = Int
l Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
n0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Int -> Bool
levels Int
l)
        when forbidden $
          reportSLn "tc.meta.kill" 20 $
            "found forbidden de Bruijn level " ++! show l
        return forbidden
  anyRigid test v

-- | Collect the *definitely* rigid variables in a monoid.
--   We need to successively reduce the expression to do this.

class AnyRigid a where
  anyRigid :: (PureTCM tcm)
           => (Nat -> tcm Bool) -> a -> tcm Bool

instance AnyRigid Term where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Term -> tcm Bool
anyRigid Int -> tcm Bool
f Term
t = do
    b <- Term -> tcm (Blocked Term)
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Term
t
    case ignoreBlocking b of
      -- Upon entry, we are in rigid position, thus,
      -- bound variables are rigid ones.
      Var Int
i Elims
es   -> Int -> tcm Bool
f Int
i tcm Bool -> tcm Bool -> tcm Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`or2M` (Int -> tcm Bool) -> Elims -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Elims -> tcm Bool
anyRigid Int -> tcm Bool
f Elims
es
      Lam ArgInfo
_ Abs Term
t    -> (Int -> tcm Bool) -> Abs Term -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Abs Term -> tcm Bool
anyRigid Int -> tcm Bool
f Abs Term
t
      Lit{}      -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Def QName
_ Elims
es   -> case Blocked Term
b of
        -- If the definition is blocked by a meta, its arguments
        -- may be in flexible positions.
        Blocked{}                   -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        -- If the definition is incomplete, arguments might disappear
        -- by reductions that come with more clauses, thus, these
        -- arguments are not rigid.
        NotBlocked (MissingClauses QName
_) Term
_ -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        -- _        -> mempty -- breaks: ImproveInertRHS, Issue442, PruneRecord, PruningNonMillerPattern
        Blocked Term
_        -> (Int -> tcm Bool) -> Elims -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Elims -> tcm Bool
anyRigid Int -> tcm Bool
f Elims
es
      Con ConHead
_ ConInfo
_ Elims
ts -> (Int -> tcm Bool) -> Elims -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Elims -> tcm Bool
anyRigid Int -> tcm Bool
f Elims
ts
      Pi Dom Type
a Abs Type
b     -> (Int -> tcm Bool) -> (Dom Type, Abs Type) -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> (Dom Type, Abs Type) -> tcm Bool
anyRigid Int -> tcm Bool
f (Dom Type
a,Abs Type
b)
      Sort Sort
s     -> (Int -> tcm Bool) -> Sort -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Sort -> tcm Bool
anyRigid Int -> tcm Bool
f Sort
s
      Level Level
l    -> (Int -> tcm Bool) -> Level -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Level -> tcm Bool
anyRigid Int -> tcm Bool
f Level
l
      MetaV{}    -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      DontCare{} -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Dummy{}    -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

instance AnyRigid Type where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Type -> tcm Bool
anyRigid Int -> tcm Bool
f (El Sort
s Term
t) = (Int -> tcm Bool) -> (Sort, Term) -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> (Sort, Term) -> tcm Bool
anyRigid Int -> tcm Bool
f (Sort
s,Term
t)

instance AnyRigid Sort where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Sort -> tcm Bool
anyRigid Int -> tcm Bool
f Sort
s =
    case Sort
s of
      Univ Univ
_ Level
l   -> (Int -> tcm Bool) -> Level -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Level -> tcm Bool
anyRigid Int -> tcm Bool
f Level
l
      Inf Univ
_ Integer
_    -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Sort
LevelUniv  -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Sort
IntervalUniv -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      PiSort Dom' Term Term
a Sort
s1 Abs Sort
s2 -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      FunSort Sort
s1 Sort
s2 -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      UnivSort Sort
s -> (Int -> tcm Bool) -> Sort -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Sort -> tcm Bool
anyRigid Int -> tcm Bool
f Sort
s
      Sort
CofUniv    -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      MetaS{}    -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      DefS{}     -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      DummyS{}   -> Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

instance AnyRigid Level where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Level -> tcm Bool
anyRigid Int -> tcm Bool
f (Max Integer
_ [PlusLevel' Term]
ls) = (Int -> tcm Bool) -> [PlusLevel' Term] -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> [PlusLevel' Term] -> tcm Bool
anyRigid Int -> tcm Bool
f [PlusLevel' Term]
ls

instance AnyRigid PlusLevel where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> PlusLevel' Term -> tcm Bool
anyRigid Int -> tcm Bool
f (Plus Integer
_ Term
l) = (Int -> tcm Bool) -> Term -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Term -> tcm Bool
anyRigid Int -> tcm Bool
f Term
l

instance (Subst a, AnyRigid a) => AnyRigid (Abs a) where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Abs a -> tcm Bool
anyRigid Int -> tcm Bool
f Abs a
b = Abs a -> (a -> tcm Bool) -> tcm Bool
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs a
b ((a -> tcm Bool) -> tcm Bool) -> (a -> tcm Bool) -> tcm Bool
forall a b. (a -> b) -> a -> b
$ (Int -> tcm Bool) -> a -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> a -> tcm Bool
anyRigid Int -> tcm Bool
f

instance AnyRigid a => AnyRigid (Arg a) where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Arg a -> tcm Bool
anyRigid Int -> tcm Bool
f Arg a
a = (Int -> tcm Bool) -> a -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> a -> tcm Bool
anyRigid Int -> tcm Bool
f (a -> tcm Bool) -> a -> tcm Bool
forall a b. (a -> b) -> a -> b
$ Arg a -> a
forall e. Arg e -> e
unArg Arg a
a

instance AnyRigid a => AnyRigid (Dom a) where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Dom a -> tcm Bool
anyRigid Int -> tcm Bool
f = (Int -> tcm Bool) -> a -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> a -> tcm Bool
anyRigid Int -> tcm Bool
f (a -> tcm Bool) -> (Dom a -> a) -> Dom a -> tcm Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom a -> a
forall t e. Dom' t e -> e
unDom

instance AnyRigid a => AnyRigid (Elim' a) where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Elim' a -> tcm Bool
anyRigid Int -> tcm Bool
f (Apply Arg a
a)      = (Int -> tcm Bool) -> Arg a -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> Arg a -> tcm Bool
anyRigid Int -> tcm Bool
f Arg a
a
  anyRigid Int -> tcm Bool
f (IApply a
x a
y a
a) = (Int -> tcm Bool) -> (a, (a, a)) -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> (a, (a, a)) -> tcm Bool
anyRigid Int -> tcm Bool
f (a
x,(a
y,a
a))
  anyRigid Int -> tcm Bool
f Proj{}         = Bool -> tcm Bool
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

instance AnyRigid a => AnyRigid [a] where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> [a] -> tcm Bool
anyRigid = (a -> tcm Bool) -> [a] -> tcm Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
(a -> m Bool) -> f a -> m Bool
anyM ((a -> tcm Bool) -> [a] -> tcm Bool)
-> ((Int -> tcm Bool) -> a -> tcm Bool)
-> (Int -> tcm Bool)
-> [a]
-> tcm Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> tcm Bool) -> a -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> a -> tcm Bool
anyRigid

instance (AnyRigid a, AnyRigid b) => AnyRigid (a,b) where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> (a, b) -> tcm Bool
anyRigid Int -> tcm Bool
f (a
a,b
b) = (Int -> tcm Bool) -> a -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> a -> tcm Bool
anyRigid Int -> tcm Bool
f a
a tcm Bool -> tcm Bool -> tcm Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`or2M` (Int -> tcm Bool) -> b -> tcm Bool
forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Int -> tcm Bool) -> a -> tcm Bool
forall (tcm :: * -> *).
PureTCM tcm =>
(Int -> tcm Bool) -> b -> tcm Bool
anyRigid Int -> tcm Bool
f b
b


data PruneResult
  = NothingToPrune   -- ^ the kill list is empty or only @False@s
  | PrunedNothing    -- ^ there is no possible kill (because of type dep.)
  | PrunedSomething  -- ^ managed to kill some args in the list
  | PrunedEverything -- ^ all prescribed kills where performed
    deriving (PruneResult -> PruneResult -> Bool
(PruneResult -> PruneResult -> Bool)
-> (PruneResult -> PruneResult -> Bool) -> Eq PruneResult
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: PruneResult -> PruneResult -> Bool
== :: PruneResult -> PruneResult -> Bool
$c/= :: PruneResult -> PruneResult -> Bool
/= :: PruneResult -> PruneResult -> Bool
Eq, Int -> PruneResult -> String -> String
[PruneResult] -> String -> String
PruneResult -> String
(Int -> PruneResult -> String -> String)
-> (PruneResult -> String)
-> ([PruneResult] -> String -> String)
-> Show PruneResult
forall a.
(Int -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Int -> PruneResult -> String -> String
showsPrec :: Int -> PruneResult -> String -> String
$cshow :: PruneResult -> String
show :: PruneResult -> String
$cshowList :: [PruneResult] -> String -> String
showList :: [PruneResult] -> String -> String
Show)

-- | @killArgs [k1,...,kn] X@ prunes argument @i@ from metavar @X@ if @ki==True@.
--   Pruning is carried out whenever > 0 arguments can be pruned.
killArgs :: [Bool] -> MetaId -> TCM PruneResult
killArgs :: [Bool] -> MetaId -> TCMT IO PruneResult
killArgs [Bool]
kills MetaId
_
  | Bool -> Bool
not ([Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
kills) = PruneResult -> TCMT IO PruneResult
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PruneResult
NothingToPrune  -- nothing to kill
killArgs [Bool]
kills MetaId
m = do
  mv <- MetaId -> TCMT IO MetaVariable
forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m MetaVariable
lookupLocalMeta MetaId
m
  allowAssign <- viewTC eAssignMetas

  -- Fail early if we're not allowed to assign this meta
  if mvFrozen mv == Frozen || not allowAssign then return PrunedNothing else do

  -- Calling killedType does the necessary amount of instantiation (or
  -- reduction) to be sure whether the variables are prunable or not.
  --
  -- It returns a list with the same length as the input indicating
  -- whether that argument was killed or not, together with the new
  -- (quantified) type for the meta.
  TelV tel b <- teleView $ jMetaType $ mvJudgement mv
  let args = [Dom (ShortText, Type)]
-> Infinite Bool -> [(Dom (ShortText, Type), Bool)]
forall a b. [a] -> Infinite b -> [(a, b)]
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b.
Zip f g h =>
f a -> g b -> h (a, b)
zip (Tele (Dom Type) -> [Dom (ShortText, Type)]
forall t. Tele (Dom t) -> [Dom (ShortText, t)]
telToList Tele (Dom Type)
tel) ([Bool] -> Bool -> Infinite Bool
forall a. [a] -> a -> ListInf a
ListInf.pad [Bool]
kills Bool
False)
  (kills', a') <- killedType args b

  reportSDoc "tc.meta.kill" 10 $  "after kill analysis" $$ nest 2 (vcat
    [ "metavar =" <+> prettyTCM m
    , "kills   =" <+> prettyTCM kills
    , "kills'  =" <+> prettyTCM kills'
    , "oldType =" <+> pretty (jMetaType $ mvJudgement mv)
    , "newType =" <+> pretty a'
    ])

  -- Now classify the result of pruning. First, we might have failed to
  -- kill anything at all, in which case we do not alter the metas.
  if not (any unArg kills') then return PrunedNothing else do
    addContext tel $ performKill kills' m a'
    -- Complete success happens if we killed all the arguments that were
    -- requested, i.e. if each position in the input list implies the
    -- corresponding position in the output list.
    return $! if (and $ zipWith' (<=) kills $ map' unArg kills')
      then PrunedEverything
      else PrunedSomething

-- | @killedType [((x1,a1),k1)..((xn,an),kn)] b = ([k'1..k'n],t')@
--   (ignoring @Dom@).  Let @t' = (xs:as) -> b@.
--   Invariant: @k'i == True@ iff @ki == True@ and pruning the @i@th argument from
--   type @b@ is possible without creating unbound variables.
--   @t'@ is type @t@ after pruning all @k'i==True@.
killedType :: (MonadReduce m) => [(Dom (ArgName, Type), Bool)] -> Type -> m ([Arg Bool], Teletype)
killedType :: forall (m :: * -> *).
MonadReduce m =>
[(Dom (ShortText, Type), Bool)] -> Type -> m ([Arg Bool], Teletype)
killedType [(Dom (ShortText, Type), Bool)]
args Type
b = do

  let n :: Int
n = [(Dom (ShortText, Type), Bool)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [(Dom (ShortText, Type), Bool)]
args
  let iargs :: [(Int, (Dom (ShortText, Type), Bool))]
iargs = [Int]
-> [(Dom (ShortText, Type), Bool)]
-> [(Int, (Dom (ShortText, Type), Bool))]
forall a b. [a] -> [b] -> [(a, b)]
zip' (Int -> [Int]
forall a. Integral a => a -> [a]
downFrom Int
n) [(Dom (ShortText, Type), Bool)]
args

  -- Turn list of bools into an VarSet containing the variables we want to kill
  -- (indices relative to b).
  let tokill :: VarSet
tokill = [Int] -> VarSet
VarSet.fromList [ Int
i | (Int
i, (Dom (ShortText, Type)
_, Bool
True)) <- [(Int, (Dom (ShortText, Type), Bool))]
iargs ]

  -- First, check the free variables of b to see if they prevent any kills.
  (tokill, b) <- VarSet -> Type -> m (VarSet, Type)
forall (m :: * -> *).
MonadReduce m =>
VarSet -> Type -> m (VarSet, Type)
reallyNotFreeIn VarSet
tokill Type
b

  -- Then recurse over the telescope (right-to-left), building up the final type.
  (killed, b) <- go (reverse $ map' fst args) tokill (EmptyTt b)

  -- Turn the VarSet of killed variables into the list of Arg Bool's to return.
  let kills = [ ArgInfo -> Bool -> Arg Bool
forall e. ArgInfo -> e -> Arg e
Arg (Dom (ShortText, Type) -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom (ShortText, Type)
dom) (Int -> VarSet -> Bool
VarSet.member Int
i VarSet
killed)
              | (Int
i, (Dom (ShortText, Type)
dom, Bool
_)) <- [(Int, (Dom (ShortText, Type), Bool))]
iargs ]
  return (kills, b)
  where
    -- go Δ xs B
    -- Invariants:
    --   - Δ ⊢ B
    --   - Δ is represented as a list in right-to-left order
    --   - xs are deBruijn indices into Δ
    --   - xs ∩ FV(B) = Ø
    -- Result: (ys, Δ' → B')
    --    where Δ' ⊆ Δ  (possibly reduced to remove dependencies, see #3177)
    --          ys ⊆ xs are the variables that were dropped from Δ
    --          B' = strengthen ys B
    go :: (MonadReduce m) => [Dom (ArgName, Type)] -> VarSet -> Teletype -> m (VarSet, Teletype)
    go :: forall (m :: * -> *).
MonadReduce m =>
[Dom (ShortText, Type)]
-> VarSet -> Teletype -> m (VarSet, Teletype)
go [] VarSet
xs Teletype
b
      | VarSet -> Bool
forall a. Null a => a -> Bool
null VarSet
xs   = (VarSet, Teletype) -> m (VarSet, Teletype)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarSet
xs, Teletype
b)
      | Bool
otherwise = m (VarSet, Teletype)
forall a. HasCallStack => a
__IMPOSSIBLE__
    go (Dom (ShortText, Type)
arg : [Dom (ShortText, Type)]
args) VarSet
xs Teletype
b  -- go (Δ (x : A)) xs B, (x = deBruijn index 0)
      | Int -> VarSet -> Bool
VarSet.member Int
0 VarSet
xs = do
          -- Case x ∈ xs. We know x ∉ FV(B), so we can safely drop x from the
          -- telescope. Drop x from xs (and shift indices) and recurse with
          -- `strengthen x B`.
          let ys :: VarSet
ys = Int -> VarSet -> VarSet
VarSet.strengthen Int
1 VarSet
xs
          (ys, b) <- [Dom (ShortText, Type)]
-> VarSet -> Teletype -> m (VarSet, Teletype)
forall (m :: * -> *).
MonadReduce m =>
[Dom (ShortText, Type)]
-> VarSet -> Teletype -> m (VarSet, Teletype)
go [Dom (ShortText, Type)]
args VarSet
ys (Teletype -> m (VarSet, Teletype))
-> Teletype -> m (VarSet, Teletype)
forall a b. (a -> b) -> a -> b
$ Impossible -> Teletype -> Teletype
forall a. Subst a => Impossible -> a -> a
strengthen Impossible
HasCallStack => Impossible
impossible Teletype
b
          -- We need to return a set of killed variables relative to Δ (x : A), so
          -- shift ys and add x back in.
          let !ys' = Int -> VarSet -> VarSet
VarSet.insert Int
0 (VarSet -> VarSet) -> VarSet -> VarSet
forall a b. (a -> b) -> a -> b
$ Int -> VarSet -> VarSet
VarSet.weaken Int
1 VarSet
ys
          return (ys', b)
      | Bool
otherwise = do
          -- Case x ∉ xs. We either can't or don't want to get rid of x. In
          -- this case we have to check A for potential dependencies preventing
          -- us from killing variables in xs.
          let xs' :: VarSet
xs'       = Int -> VarSet -> VarSet
VarSet.strengthen Int
1 VarSet
xs -- Shift to make relative to Δ ⊢ A
              (ShortText
name, Type
a) = Dom (ShortText, Type) -> (ShortText, Type)
forall t e. Dom' t e -> e
unDom Dom (ShortText, Type)
arg
          (ys, a) <- VarSet -> Type -> m (VarSet, Type)
forall (m :: * -> *).
MonadReduce m =>
VarSet -> Type -> m (VarSet, Type)
reallyNotFreeIn VarSet
xs' Type
a
          -- Recurse on Δ, ys, and (x : A') → B, where A reduces to A' and ys ⊆ xs'
          -- not free in A'. We already know ys not free in B.
          (zs, b) <- go args ys $ teleCons ((name, a) <$ arg) b
          -- Shift back up to make it relative to Δ (x : A) again.
          let !zs' = Int -> VarSet -> VarSet
VarSet.weaken Int
1 VarSet
zs
          return (zs', b)

reallyNotFreeIn :: (MonadReduce m) => VarSet -> Type -> m (VarSet, Type)
reallyNotFreeIn :: forall (m :: * -> *).
MonadReduce m =>
VarSet -> Type -> m (VarSet, Type)
reallyNotFreeIn VarSet
xs Type
a | VarSet -> Bool
forall a. Null a => a -> Bool
null VarSet
xs = (VarSet, Type) -> m (VarSet, Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarSet
xs, Type
a) -- Shortcut
reallyNotFreeIn VarSet
xs Type
a = do
  let fvs :: VarMap
fvs      = Type -> VarMap
forall t. Free t => t -> VarMap
freeVarMap Type
a
      anywhere :: VarSet
anywhere = VarMap -> VarSet
allVars VarMap
fvs
      rigid :: VarSet
rigid    = VarSet -> VarSet -> VarSet
VarSet.union (VarMap -> VarSet
stronglyRigidVars VarMap
fvs) (VarMap -> VarSet
unguardedVars VarMap
fvs)
      nonrigid :: VarSet
nonrigid = VarSet -> VarSet -> VarSet
VarSet.difference VarSet
anywhere VarSet
rigid
      hasNo :: VarSet -> Bool
hasNo    = VarSet -> VarSet -> Bool
VarSet.disjoint VarSet
xs
  if VarSet -> Bool
hasNo VarSet
nonrigid
    then do
       -- No non-rigid occurrences. We can't do anything about the rigid
       -- occurrences so drop those and leave `a` untouched.
       let !diff :: VarSet
diff = VarSet -> VarSet -> VarSet
VarSet.difference VarSet
xs VarSet
rigid
       (VarSet, Type) -> m (VarSet, Type)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (VarSet
diff, Type
a)
    else do
      -- If there are non-rigid occurrences we need to reduce to see if
      -- we can get rid of them (#3177).
      (fvs, a) <- ReduceM (IntMap IsFree, Type) -> m (IntMap IsFree, Type)
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM (IntMap IsFree, Type) -> m (IntMap IsFree, Type))
-> ReduceM (IntMap IsFree, Type) -> m (IntMap IsFree, Type)
forall a b. (a -> b) -> a -> b
$ VarSet -> Type -> ReduceM (IntMap IsFree, Type)
forall a.
(ForceNotFree a, Reduce a) =>
VarSet -> a -> ReduceM (IntMap IsFree, a)
forceNotFree (VarSet -> VarSet -> VarSet
VarSet.difference VarSet
xs VarSet
rigid) Type
a
      let !xs = IntMap IsFree -> VarSet
nonFreeVars IntMap IsFree
fvs
      return (xs, a)

-- | Instantiate a meta variable with a new one that only takes
--   the arguments which are not pruneable.
performKill ::
     [Arg Bool]    -- ^ Arguments to old meta var in left to right order
                   --   with @Bool@ indicating whether they can be pruned.
  -> MetaId        -- ^ The old meta var to receive pruning.
  -> Teletype      -- ^ The pruned type of the new meta var.
  -> TCM ()
performKill :: [Arg Bool] -> MetaId -> Teletype -> TCM ()
performKill [Arg Bool]
kills MetaId
m Teletype
a = do
  mv <- MetaId -> TCMT IO MetaVariable
forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m MetaVariable
lookupLocalMeta MetaId
m
  when (mvFrozen mv == Frozen) __IMPOSSIBLE__
  -- Arity of the old meta.
  let n = [Arg Bool] -> Int
forall a. Sized a => a -> Int
size [Arg Bool]
kills
  -- The permutation of the new meta picks the arguments
  -- which are not pruned in left to right order
  -- (de Bruijn level order).
  let perm = Int -> [Int] -> Permutation
Perm Int
n
             [ Int
i | (Int
i, Arg ArgInfo
_ Bool
False) <- Infinite Int -> [Arg Bool] -> [(Int, Arg Bool)]
forall a b. Infinite a -> [b] -> [(a, b)]
forall (f :: * -> *) (g :: * -> *) (h :: * -> *) a b.
Zip f g h =>
f a -> g b -> h (a, b)
zip (Int -> Infinite Int
forall n. Enum n => n -> ListInf n
ListInf.upFrom Int
0) [Arg Bool]
kills ]
      -- The permutation for the old meta might range over a prefix of the arguments
      oldPerm = Int -> Permutation -> Permutation
liftP (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
m) Permutation
p
        where p :: Permutation
p = MetaVariable -> Permutation
mvPermutation MetaVariable
mv
              m :: Int
m = Permutation -> Int
forall a. Sized a => a -> Int
size Permutation
p
      judg = case MetaVariable -> Judgement MetaId
mvJudgement MetaVariable
mv of
        HasType{ jComparison :: forall a. Judgement a -> Comparison
jComparison = Comparison
cmp } -> ZonkAny 0 -> Comparison -> Teletype -> Judgement (ZonkAny 0)
forall a. a -> Comparison -> Teletype -> Judgement a
HasType ZonkAny 0
forall a. HasCallStack => a
__IMPOSSIBLE__ Comparison
cmp Teletype
a
        IsSort{}  -> ZonkAny 0 -> Teletype -> Judgement (ZonkAny 0)
forall a. a -> Teletype -> Judgement a
IsSort  ZonkAny 0
forall a. HasCallStack => a
__IMPOSSIBLE__ Teletype
a
  m' <- newMeta Instantiable (mvInfo mv) (mvPriority mv) (composeP perm oldPerm) judg
  -- Andreas, 2010-10-15 eta expand new meta variable if necessary
  etaExpandMetaSafe m'
  let -- Arguments to new meta (de Bruijn indices)
      -- in left to right order.
      vars = [ ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info (Int -> Term
var Int
i)
             | (Int
i, Arg ArgInfo
info Bool
False) <- [Int] -> [Arg Bool] -> [(Int, Arg Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip' (Int -> [Int]
forall a. Integral a => a -> [a]
downFrom Int
n) [Arg Bool]
kills ]
      u       = MetaId -> Elims -> Term
MetaV MetaId
m' (Elims -> Term) -> Elims -> Term
forall a b. (a -> b) -> a -> b
$! (Arg Term -> Elim' Term) -> [Arg Term] -> Elims
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply [Arg Term]
vars
      -- Arguments to the old meta (just arg infos and name hints)
      -- in left to right order.
      tel     = (Arg Bool -> Arg ShortText) -> [Arg Bool] -> [Arg ShortText]
forall a b. (a -> b) -> [a] -> [b]
map' (ShortText
"v" ShortText -> Arg Bool -> Arg ShortText
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) [Arg Bool]
kills
  dbg m' u
  assignTerm m tel u  -- m tel := u
  where
    dbg :: MetaId -> Term -> TCM ()
dbg MetaId
m' Term
u = String -> Int -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.meta.kill" Int
10 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ TCMT IO Doc
"actual killing"
      , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"new meta:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> MetaId -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty MetaId
m'
        , TCMT IO Doc
"kills   :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList_ ((Arg Bool -> TCMT IO Doc) -> [Arg Bool] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map' (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (String -> TCMT IO Doc)
-> (Arg Bool -> String) -> Arg Bool -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> String
forall a. Show a => a -> String
show (Bool -> String) -> (Arg Bool -> Bool) -> Arg Bool -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Bool -> Bool
forall e. Arg e -> e
unArg) [Arg Bool]
kills)
        , TCMT IO Doc
"inst    :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> MetaId -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty MetaId
m TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
":=" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
u
        ]
      ]