{-# 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 Agda.TypeChecking.MetaVars.Occurs where

import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader

import Data.Foldable (traverse_)
import Data.Functor
import Data.Monoid
import Data.Set (Set)
import qualified Data.Set as Set
import qualified Data.IntMap as IntMap
import qualified Data.IntSet as IntSet
import Data.IntSet (IntSet)

import qualified Agda.Benchmarking as Bench

import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.Syntax.Internal.MetaVars

import Agda.TypeChecking.Constraints ( wakeupConstraints )
import Agda.TypeChecking.Monad
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Free
import Agda.TypeChecking.Free.Lazy
import Agda.TypeChecking.Free.Reduce
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Datatypes
import Agda.TypeChecking.Records
import {-# SOURCE #-} Agda.TypeChecking.MetaVars

import Agda.Utils.Either
import Agda.Utils.Lens
import Agda.Utils.List (downFrom)
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Permutation
import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.Size

import Agda.Utils.Impossible

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

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

data B : Set where
  inn : A -> B

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

postulate
  P : (y : A) (z : Unit -> B) → Set
  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 = Lens' (Set QName) TCState
stOccursCheckDefs forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> (a -> a) -> m ()
`modifyTCLens` Set QName -> Set QName
f

-- | Set the names of definitions to be looked at
--   to the defs in the current mutual block.
initOccursCheck :: MetaVariable -> TCM ()
initOccursCheck :: MetaVariable -> TCM ()
initOccursCheck MetaVariable
mv = (Set QName -> Set QName) -> TCM ()
modifyOccursCheckDefs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> b -> a
const forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
  if (MetaInfo -> RunMetaOccursCheck
miMetaOccursCheck (MetaVariable -> MetaInfo
mvInfo MetaVariable
mv) forall a. Eq a => a -> a -> Bool
== RunMetaOccursCheck
DontRunMetaOccursCheck)
   then do
     forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.occurs" Nat
20 forall a b. (a -> b) -> a -> b
$
       [Char]
"initOccursCheck: we do not look into definitions"
     forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
Set.empty
   else do
     forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.occurs" Nat
20 forall a b. (a -> b) -> a -> b
$
       [Char]
"initOccursCheck: we look into the following definitions:"
     Maybe MutualId
mb <- forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Maybe MutualId
envMutualBlock
     case Maybe MutualId
mb of
       Maybe MutualId
Nothing -> do
         forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.occurs" Nat
20 forall a b. (a -> b) -> a -> b
$ [Char]
"(none)"
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
Set.empty
       Just MutualId
b  -> do
         Set QName
ds <- MutualBlock -> Set QName
mutualNames forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (tcm :: * -> *).
ReadTCState tcm =>
MutualId -> tcm MutualBlock
lookupMutualBlock MutualId
b
         forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList Set QName
ds
         forall (m :: * -> *) a. Monad m => a -> m a
return Set QName
ds


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

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

-- | Extra environment for the occurs check.  (Complements 'FreeEnv'.)
data OccursExtra = OccursExtra
  { OccursExtra -> UnfoldStrategy
occUnfold  :: UnfoldStrategy
  , OccursExtra -> VarMap
occVars    :: VarMap          -- ^ The allowed variables with their variance.
  , OccursExtra -> MetaId
occMeta    :: MetaId          -- ^ The meta we want to solve.
  , OccursExtra -> Nat
occCxtSize :: Nat             -- ^ The size of the typing context upon invocation.
  }

type OccursCtx  = FreeEnv' () OccursExtra AllowedVar
type OccursM    = ReaderT OccursCtx TCM

-- ** Modality handling.

-- | The passed modality is the one of the current context.
type AllowedVar = Modality -> All

instance IsVarSet () AllowedVar where
  withVarOcc :: VarOcc' () -> AllowedVar -> AllowedVar
withVarOcc VarOcc' ()
o AllowedVar
f = AllowedVar
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Modality -> Modality -> Modality
composeModality (forall a. LensModality a => a -> Modality
getModality VarOcc' ()
o)

-- | Check whether a free variable is allowed in the context as
--   specified by the modality.
variableCheck :: VarMap -> Maybe Variable -> AllowedVar
variableCheck :: VarMap -> Maybe Nat -> AllowedVar
variableCheck VarMap
xs Maybe Nat
mi Modality
q = Bool -> All
All forall a b. (a -> b) -> a -> b
$
  -- Bound variables are always allowed to occur:
  forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe Nat
mi Bool
True forall a b. (a -> b) -> a -> b
$ \ Nat
i ->
    -- Free variables not listed in @xs@ are forbidden:
    forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (forall a. Nat -> VarMap' a -> Maybe (VarOcc' a)
lookupVarMap Nat
i VarMap
xs) Bool
False forall a b. (a -> b) -> a -> b
$ \ VarOcc' MetaSet
o ->
      -- For listed variables it holds:
      -- The ascribed modality @o@ must be submodality of the
      -- modality @q@ of the current context.
      -- E.g. irrelevant variables (ascribed, lhs) can only
      -- be used in irrelevant position (rhs).
      forall a. LensModality a => a -> Modality
getModality VarOcc' MetaSet
o Modality -> Modality -> Bool
`moreUsableModality` Modality
q

-- | Occurs check fails if a defined name is not available
--   since it was declared in irrelevant or erased context.
definitionCheck :: QName -> OccursM ()
definitionCheck :: QName -> OccursM ()
definitionCheck QName
d = do
  OccursCtx
cxt <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let irr :: Bool
irr = forall a. LensRelevance a => a -> Bool
isIrrelevant OccursCtx
cxt
      er :: Bool
er  = forall a. LensQuantity a => a -> Bool
hasQuantity0 OccursCtx
cxt
      m :: MetaId
m   = OccursExtra -> MetaId
occMeta forall a b. (a -> b) -> a -> b
$ forall a b c. FreeEnv' a b c -> b
feExtra OccursCtx
cxt
  -- Anything goes if we are both irrelevant and erased.
  -- Otherwise, have to check the modality of the defined name.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
irr Bool -> Bool -> Bool
&& Bool
er) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Either SigError Definition)
getConstInfo' QName
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
   Left SigError
_ -> do
    -- Andreas, 2021-07-29.
    -- The definition is not in scope.
    -- This shouldn't happen, but does so in issue #5492.
    -- Let's bail out...
    forall (m :: * -> *) a.
MonadTCM m =>
Blocker -> Nat -> [Char] -> m a
patternViolation' Blocker
alwaysUnblock Nat
35 forall a b. (a -> b) -> a -> b
$
      [[Char]] -> [Char]
unwords [[Char]
"occursCheck: definition", forall a. Pretty a => a -> [Char]
prettyShow QName
d, [Char]
"not in scope" ]
   Right Definition
def -> do
    let dmod :: Modality
dmod = forall a. LensModality a => a -> Modality
getModality Definition
def
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
irr Bool -> Bool -> Bool
|| forall a. LensRelevance a => a -> Bool
usableRelevance Modality
dmod) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
35 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
hsep
        [ TCMT IO Doc
"occursCheck: definition"
        , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
d
        , TCMT IO Doc
"has relevance"
        , forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. LensRelevance a => a -> Relevance
getRelevance Modality
dmod
        ]
      forall a. Blocker -> TypeError -> OccursM a
abort Blocker
neverUnblock forall a b. (a -> b) -> a -> b
$ MetaId -> Term -> TypeError
MetaIrrelevantSolution MetaId
m forall a b. (a -> b) -> a -> b
$ QName -> Elims -> Term
Def QName
d []
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Bool
er Bool -> Bool -> Bool
|| forall a. LensQuantity a => a -> Bool
usableQuantity Modality
dmod) forall a b. (a -> b) -> a -> b
$ do
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
35 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
hsep
        [ TCMT IO Doc
"occursCheck: definition"
        , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
d
        , TCMT IO Doc
"has quantity"
        , forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. LensQuantity a => a -> Quantity
getQuantity Modality
dmod
        ]
      forall a. Blocker -> TypeError -> OccursM a
abort Blocker
neverUnblock forall a b. (a -> b) -> a -> b
$ MetaId -> Term -> TypeError
MetaErasedSolution MetaId
m forall a b. (a -> b) -> a -> b
$ QName -> Elims -> Term
Def QName
d []

metaCheck :: MetaId -> OccursM MetaId
metaCheck :: MetaId -> OccursM MetaId
metaCheck MetaId
m = do
  OccursCtx
cxt <- forall r (m :: * -> *). MonadReader r m => m r
ask
  let rel :: Relevance
rel = forall a. LensRelevance a => a -> Relevance
getRelevance OccursCtx
cxt
      qnt :: Quantity
qnt = forall a. LensQuantity a => a -> Quantity
getQuantity OccursCtx
cxt
      m0 :: MetaId
m0  = OccursExtra -> MetaId
occMeta forall a b. (a -> b) -> a -> b
$ forall a b c. FreeEnv' a b c -> b
feExtra OccursCtx
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'
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MetaId
m forall a. Eq a => a -> a -> Bool
== MetaId
m0) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadTCM m =>
Blocker -> Nat -> [Char] -> m a
patternViolation' Blocker
neverUnblock Nat
50 forall a b. (a -> b) -> a -> b
$ [Char]
"occursCheck failed: Found " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow MetaId
m

  MetaVariable
mv <- forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m MetaVariable
lookupLocalMeta MetaId
m
  let mmod :: Modality
mmod = forall a. LensModality a => a -> Modality
getModality MetaVariable
mv
      mmod' :: Modality
mmod' = forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
rel forall a b. (a -> b) -> a -> b
$ forall a. LensQuantity a => Quantity -> a -> a
setQuantity Quantity
qnt forall a b. (a -> b) -> a -> b
$ Modality
mmod
  if (Modality
mmod Modality -> Modality -> Bool
`moreUsableModality` Modality
mmod') then forall (m :: * -> *) a. Monad m => a -> m a
return MetaId
m else do
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
35 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
hsep
      [ TCMT IO Doc
"occursCheck: meta variable"
      , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM MetaId
m
      , TCMT IO Doc
"has relevance"
      , forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. LensRelevance a => a -> Relevance
getRelevance Modality
mmod
      , TCMT IO Doc
"and quantity"
      , forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. LensQuantity a => a -> Quantity
getQuantity Modality
mmod
      ]
    Bool
allowAssign <- forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Bool
envAssignMetas
    -- Jesper, 2020-11-10: if we encounter a metavariable that is
    -- unusable because of its modality (e.g. irrelevant or erased) we
    -- try to *promote* the meta to the required modality, by creating
    -- a new meta with that modality and solving the old one with
    -- it. Don't do this if the meta occurs in a flexible or unguarded
    -- position:
    -- - If it is in a flexible position, it could disappear when
    --   another meta is solved, so promotion is maybe not necessary.
    -- - If it is in a top-level position, we can instead solve the
    --   equation by instantiating the other way around, so promotion
    --   is not necessary.
    let fail :: TCMT IO Doc -> OccursM ()
fail TCMT IO Doc
reason = do
          forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Meta occurs check found bad relevance"
          forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"aborting because" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
reason
          forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation forall a b. (a -> b) -> a -> b
$ MetaId -> Blocker
unblockOnMeta MetaId
m
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MetaVariable -> Frozen
mvFrozen MetaVariable
mv forall a. Eq a => a -> a -> Bool
== Frozen
Frozen)             forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> OccursM ()
fail TCMT IO Doc
"meta is frozen"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (MetaInstantiation -> Bool
isOpenMeta forall a b. (a -> b) -> a -> b
$ MetaVariable -> MetaInstantiation
mvInstantiation MetaVariable
mv) forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> OccursM ()
fail TCMT IO Doc
"meta is already solved"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
allowAssign                       forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> OccursM ()
fail TCMT IO Doc
"assigning metas is not allowed here"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a o. LensFlexRig a o => o -> Bool
isFlexible OccursCtx
cxt)                    forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> OccursM ()
fail TCMT IO Doc
"occurrence is flexible"
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a o. LensFlexRig a o => o -> Bool
isUnguarded OccursCtx
cxt)                   forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> OccursM ()
fail TCMT IO Doc
"occurrence is unguarded"

    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Promoting meta" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM MetaId
m forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"to modality" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Modality
mmod'
    forall (m :: * -> *).
MonadMetaSolver m =>
MetaId -> (MetaVariable -> MetaVariable) -> m ()
updateMetaVar MetaId
m forall a b. (a -> b) -> a -> b
$ \ MetaVariable
mv -> MetaVariable
mv { mvInfo :: MetaInfo
mvInfo = forall a. LensModality a => Modality -> a -> a
setModality Modality
mmod' forall a b. (a -> b) -> a -> b
$ MetaVariable -> MetaInfo
mvInfo MetaVariable
mv }
    forall (m :: * -> *). MonadMetaSolver m => MetaId -> m ()
etaExpandListeners MetaId
m
    forall (m :: * -> *). MonadMetaSolver m => MetaId -> m ()
wakeupConstraints MetaId
m
    forall (m :: * -> *) a. Monad m => a -> m a
return MetaId
m

-- | Construct a test whether a de Bruijn index is allowed
--   or needs to be pruned.
allowedVars :: OccursM (Nat -> Bool)
allowedVars :: OccursM (Nat -> Bool)
allowedVars = do
  -- @n@ is the number of binders we have stepped under.
  Nat
n  <- forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (-) forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Nat
getContextSize (forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (OccursExtra -> Nat
occCxtSize forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. FreeEnv' a b c -> b
feExtra))
  TheVarMap' MetaSet
xs <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (forall a. VarMap' a -> TheVarMap' a
theVarMap forall b c a. (b -> c) -> (a -> b) -> a -> c
. OccursExtra -> VarMap
occVars forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. FreeEnv' a b c -> b
feExtra)
  -- Bound variables are allowed, and those mentioned in occVars.
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ Nat
i -> Nat
i forall a. Ord a => a -> a -> Bool
< Nat
n Bool -> Bool -> Bool
|| (Nat
i forall a. Num a => a -> a -> a
- Nat
n) forall a. Nat -> IntMap a -> Bool
`IntMap.member` TheVarMap' MetaSet
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: UnfoldStrategy -> UnfoldStrategy -> Bool
$c/= :: UnfoldStrategy -> UnfoldStrategy -> Bool
== :: UnfoldStrategy -> UnfoldStrategy -> Bool
$c== :: UnfoldStrategy -> UnfoldStrategy -> Bool
Eq, Nat -> UnfoldStrategy -> ShowS
[UnfoldStrategy] -> ShowS
UnfoldStrategy -> [Char]
forall a.
(Nat -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [UnfoldStrategy] -> ShowS
$cshowList :: [UnfoldStrategy] -> ShowS
show :: UnfoldStrategy -> [Char]
$cshow :: UnfoldStrategy -> [Char]
showsPrec :: Nat -> UnfoldStrategy -> ShowS
$cshowsPrec :: Nat -> UnfoldStrategy -> ShowS
Show)

defArgs :: OccursM a -> OccursM a
defArgs :: forall a. OccursM a -> OccursM a
defArgs OccursM a
m = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (OccursExtra -> UnfoldStrategy
occUnfold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. FreeEnv' a b c -> b
feExtra) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  UnfoldStrategy
NoUnfold  -> forall a. OccursM a -> OccursM a
flexibly OccursM a
m
  UnfoldStrategy
YesUnfold -> forall a. OccursM a -> OccursM a
weakly OccursM a
m

-- | For a path constructor `c : ... -> Path D a b`, we have that e.g. `c es i0` reduces to `a`.
--   So we have to consider its arguments as flexible when we do not actually unfold.
conArgs :: Elims -> OccursM a -> OccursM a
conArgs :: forall a. Elims -> OccursM a -> OccursM a
conArgs Elims
es OccursM a
m = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (OccursExtra -> UnfoldStrategy
occUnfold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. FreeEnv' a b c -> b
feExtra) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  UnfoldStrategy
YesUnfold -> OccursM a
m
  UnfoldStrategy
NoUnfold | forall (t :: * -> *) a. Foldable t => t a -> Bool
null [ () | IApply{} <- Elims
es ]
            -> OccursM a
m
  UnfoldStrategy
NoUnfold  -> forall a. OccursM a -> OccursM a
flexibly OccursM a
m

unfoldB :: (Instantiate t, Reduce t) => t -> OccursM (Blocked t)
unfoldB :: forall t. (Instantiate t, Reduce t) => t -> OccursM (Blocked t)
unfoldB t
v = do
  UnfoldStrategy
unfold <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b. (a -> b) -> a -> b
$ OccursExtra -> UnfoldStrategy
occUnfold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. FreeEnv' a b c -> b
feExtra
  Modality
rel    <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks forall a b c. FreeEnv' a b c -> Modality
feModality
  case UnfoldStrategy
unfold of
    UnfoldStrategy
YesUnfold | Bool -> Bool
not (forall a. LensRelevance a => a -> Bool
isIrrelevant Modality
rel) -> forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB t
v
    UnfoldStrategy
_                                  -> forall a t. a -> Blocked' t a
notBlocked forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *). (Instantiate a, MonadReduce m) => a -> m a
instantiate t
v

unfold :: (Instantiate t, Reduce t) => t -> OccursM t
unfold :: forall t. (Instantiate t, Reduce t) => t -> OccursM t
unfold t
v = forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (OccursExtra -> UnfoldStrategy
occUnfold forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. FreeEnv' a b c -> b
feExtra) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  UnfoldStrategy
NoUnfold  -> forall a (m :: * -> *). (Instantiate a, MonadReduce m) => a -> m a
instantiate t
v
  UnfoldStrategy
YesUnfold -> forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce t
v

-- ** Managing rigidiy during occurs check.

-- | Leave the strongly rigid position.
weakly :: OccursM a -> OccursM a
weakly :: forall a. OccursM a -> OccursM a
weakly = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall i o. Lens' i o -> LensMap i o
over forall a o. LensFlexRig a o => Lens' (FlexRig' a) o
lensFlexRig forall a b. (a -> b) -> a -> b
$ forall a. Semigroup a => FlexRig' a -> FlexRig' a -> FlexRig' a
composeFlexRig forall a. FlexRig' a
WeaklyRigid

strongly :: OccursM a -> OccursM a
strongly :: forall a. OccursM a -> OccursM a
strongly = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall i o. Lens' i o -> LensMap i o
over forall a o. LensFlexRig a o => Lens' (FlexRig' a) o
lensFlexRig forall a b. (a -> b) -> a -> b
$ \case
  FlexRig' ()
WeaklyRigid -> forall a. FlexRig' a
StronglyRigid
  FlexRig' ()
Unguarded   -> forall a. FlexRig' a
StronglyRigid
  FlexRig' ()
ctx -> FlexRig' ()
ctx

flexibly :: OccursM a -> OccursM a
flexibly :: forall a. OccursM a -> OccursM a
flexibly = forall r (m :: * -> *) a. MonadReader r m => (r -> r) -> m a -> m a
local forall a b. (a -> b) -> a -> b
$ forall i o. Lens' i o -> LensSet i o
set forall a o. LensFlexRig a o => Lens' (FlexRig' a) o
lensFlexRig forall a b. (a -> b) -> a -> b
$ 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 -> Nat -> [Char] -> m a
patternViolation' Blocker
unblock Nat
n [Char]
err = forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.occurs" Nat
n [Char]
err
  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
  OccursCtx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
  forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
    if | forall a. LensRelevance a => a -> Bool
isIrrelevant OccursCtx
ctx                    -> TCM a
soft
       | FlexRig' ()
StronglyRigid <- OccursCtx
ctx forall o i. o -> Lens' i o -> i
^. forall a o. LensFlexRig a o => Lens' (FlexRig' a) o
lensFlexRig -> TCM a
hard
       | Bool
otherwise -> TCM a
soft
  where
  hard :: TCM a
hard = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
err -- here, throw an uncatchable error (unsolvable constraint)
  soft :: TCM a
soft = forall (m :: * -> *) a.
MonadTCM m =>
Blocker -> Nat -> [Char] -> m a
patternViolation' Blocker
unblock Nat
70 (forall a. Show a => a -> [Char]
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 occurs :: (Traversable f, Occurs a, f a ~ t) => t -> OccursM t
  occurs = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall t. Occurs t => t -> OccursM t
occurs

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

-- | 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
  :: (Occurs a, InstantiateFull a, PrettyTCM a)
  => MetaId -> VarMap -> a -> TCM a
occursCheck :: forall a.
(Occurs a, InstantiateFull a, PrettyTCM a) =>
MetaId -> VarMap -> a -> TCM a
occursCheck MetaId
m VarMap
xs a
v = forall (m :: * -> *) c.
MonadBench m =>
Account (BenchPhase m) -> m c -> m c
Bench.billTo [ Phase
Bench.Typing, Phase
Bench.OccursCheck ] forall a b. (a -> b) -> a -> b
$ do
  MetaVariable
mv <- forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m MetaVariable
lookupLocalMeta MetaId
m
  Nat
n  <- forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Nat
getContextSize
  forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.occurs" Nat
35 forall a b. (a -> b) -> a -> b
$ [Char]
"occursCheck " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show MetaId
m forall a. [a] -> [a] -> [a]
++ [Char]
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show VarMap
xs
  let initEnv :: UnfoldStrategy -> OccursCtx
initEnv UnfoldStrategy
unf = FreeEnv
        {  feExtra :: OccursExtra
feExtra = OccursExtra
          { occUnfold :: UnfoldStrategy
occUnfold  = UnfoldStrategy
unf
          , occVars :: VarMap
occVars    = VarMap
xs
          , occMeta :: MetaId
occMeta    = MetaId
m
          , occCxtSize :: Nat
occCxtSize = Nat
n
          }
        , feFlexRig :: FlexRig' ()
feFlexRig   = forall a. FlexRig' a
StronglyRigid -- ? Unguarded
        , feModality :: Modality
feModality  = forall a. LensModality a => a -> Modality
getModality MetaVariable
mv
        , feSingleton :: Maybe Nat -> AllowedVar
feSingleton = VarMap -> Maybe Nat -> AllowedVar
variableCheck VarMap
xs
        }
  MetaVariable -> TCM ()
initOccursCheck MetaVariable
mv
  forall a. TCM a -> TCM a
nicerErrorMessage forall a b. (a -> b) -> a -> b
$ do
    -- First try without normalising the term
    (forall t. Occurs t => t -> OccursM t
occurs a
v forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` UnfoldStrategy -> OccursCtx
initEnv UnfoldStrategy
NoUnfold) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \TCErr
err -> do
      -- If first run is inconclusive, try again with normalization
      -- (unless metavariable is irrelevant, in which case the
      -- constraint will anyway be dropped)
      case TCErr
err of
        PatternErr{} | Bool -> Bool
not (forall a. LensRelevance a => a -> Bool
isIrrelevant forall a b. (a -> b) -> a -> b
$ forall a. LensModality a => a -> Modality
getModality MetaVariable
mv) -> do
          MetaVariable -> TCM ()
initOccursCheck MetaVariable
mv
          forall t. Occurs t => t -> OccursM t
occurs a
v forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` UnfoldStrategy -> OccursCtx
initEnv UnfoldStrategy
YesUnfold
        TCErr
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err

  where
    -- Produce nicer error messages
    nicerErrorMessage :: TCM a -> TCM a
    nicerErrorMessage :: forall a. TCM a -> TCM a
nicerErrorMessage TCM a
f = TCM a
f forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ TCErr
err -> case TCErr
err of
      TypeError CallStack
_ TCState
_ Closure TypeError
cl -> case forall a. Closure a -> a
clValue Closure TypeError
cl of
        MetaOccursInItself{} ->
          forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"Refuse to construct infinite term by instantiating"
                 , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM MetaId
m
                 , TCMT IO Doc
"to"
                 , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *).
(InstantiateFull a, MonadReduce m) =>
a -> m a
instantiateFull a
v
                 ]
        MetaCannotDependOn MetaId
_ Nat
i ->
          forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *). ReadTCState m => MetaId -> m Bool
isSortMeta MetaId
m forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`and2M` (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m Bool
hasUniversePolymorphism))
          ( forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"Cannot instantiate the metavariable"
                 , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM MetaId
m
                 , TCMT IO Doc
"to"
                 , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
v
                 , TCMT IO Doc
"since universe polymorphism is disabled"
                 ]
          ) {- else -}
          ( forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
              forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"Cannot instantiate the metavariable"
                   , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM MetaId
m
                   , TCMT IO Doc
"to solution"
                   , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
v
                   , TCMT IO Doc
"since it contains the variable"
                   , forall (m :: * -> *) a c b.
(MonadTCEnv m, ReadTCState m, LensClosure a c) =>
c -> (a -> m b) -> m b
enterClosure Closure TypeError
cl forall a b. (a -> b) -> a -> b
$ \TypeError
_ -> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Nat -> Elims -> Term
Var Nat
i [])
                   , TCMT IO Doc
"which is not in scope of the metavariable"
                   ]
            )
        MetaIrrelevantSolution MetaId
_ Term
_ ->
          forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"Cannot instantiate the metavariable"
                 , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM MetaId
m
                 , TCMT IO Doc
"to solution"
                 , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
v
                 , TCMT IO Doc
"since (part of) the solution was created in an irrelevant context"
                 ]
        MetaErasedSolution MetaId
_ Term
_ ->
          forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
            forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"Cannot instantiate the metavariable"
                 , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM MetaId
m
                 , TCMT IO Doc
"to solution"
                 , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
v
                 , TCMT IO Doc
"since (part of) the solution was created in an erased context"
                 ]
        TypeError
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
      TCErr
_ -> 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
    Blocked Term
vb  <- forall t. (Instantiate t, Reduce t) => t -> OccursM (Blocked t)
unfoldB Term
v
    -- occurs' ctx $ ignoreBlocking v  -- fails test/succeed/DontPruneBlocked
    let flexIfBlocked :: OccursM Term -> OccursM Term
flexIfBlocked = case Blocked Term
vb of
          -- Don't fail on blocked terms or metas
          Blocked Blocker
_ MetaV{} -> forall a. a -> a
id
          Blocked Blocker
b Term
_ -> forall a. OccursM a -> OccursM a
flexibly forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. MonadBlock m => Blocker -> m a -> m a
addOrUnblocker Blocker
b
          -- 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} -> forall a. OccursM a -> OccursM a
flexibly
          NotBlocked{} -> forall a. a -> a
id
    let v :: Term
v = forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
vb
    OccursM Term -> OccursM Term
flexIfBlocked forall a b. (a -> b) -> a -> b
$ do
        OccursCtx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
        let m :: MetaId
m = OccursExtra -> MetaId
occMeta forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. FreeEnv' a b c -> b
feExtra forall a b. (a -> b) -> a -> b
$ OccursCtx
ctx
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
45 forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char]
"occursCheck " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow MetaId
m forall a. [a] -> [a] -> [a]
++ [Char]
" (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a b c. FreeEnv' a b c -> FlexRig' a
feFlexRig OccursCtx
ctx) forall a. [a] -> [a] -> [a]
++ [Char]
") of ") forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
v
        forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
70 forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v
        case Term
v of
          Var Nat
i Elims
es   -> do
            Bool
allowed <- All -> Bool
getAll forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a b. (a -> b) -> a -> b
$ Modality
unitModality) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a c b.
(Monad m, IsVarSet a c) =>
Nat -> FreeT a b m c
variable Nat
i
            if Bool
allowed then Nat -> Elims -> Term
Var Nat
i forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. OccursM a -> OccursM a
weakly (forall t. Occurs t => t -> OccursM t
occurs Elims
es) else do
              -- if the offending variable is of singleton type,
              -- eta-expand it away
              forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
35 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"offending variable: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Nat -> Term
var Nat
i)
              Type
t <-  forall (m :: * -> *).
(Applicative m, MonadFail m, MonadTCEnv m) =>
Nat -> m Type
typeOfBV Nat
i
              forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
35 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"of type " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
t
              Maybe Term
isST <- forall (m :: * -> *).
(PureTCM m, MonadBlock m) =>
Type -> m (Maybe Term)
isSingletonType Type
t
              forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.occurs" Nat
35 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"(after singleton test)"
              case Maybe Term
isST of
                -- not a singleton type
                Maybe Term
Nothing ->
                  -- #4480: Only hard fail if the variable is not in scope. Wrong modality/relevance
                  -- could potentially be salvaged by eta expansion.
                  forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ((forall a b. (a -> b) -> a -> b
$ Nat
i) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> OccursM (Nat -> Bool)
allowedVars) -- vv TODO: neverUnblock is not correct! What could trigger this eta expansion though?
                      (forall (m :: * -> *) a.
MonadTCM m =>
Blocker -> Nat -> [Char] -> m a
patternViolation' Blocker
neverUnblock Nat
70 forall a b. (a -> b) -> a -> b
$ [Char]
"Disallowed var " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Nat
i forall a. [a] -> [a] -> [a]
++ [Char]
" due to modality/relevance")
                      (forall a. OccursM a -> OccursM a
strongly forall a b. (a -> b) -> a -> b
$ forall a. Blocker -> TypeError -> OccursM a
abort Blocker
neverUnblock forall a b. (a -> b) -> a -> b
$ MetaId -> Nat -> TypeError
MetaCannotDependOn MetaId
m Nat
i)
                -- is a singleton type with unique inhabitant sv
                (Just Term
sv) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Term
sv forall t. Apply t => t -> Elims -> t
`applyE` Elims
es
          Lam ArgInfo
h Abs Term
f     -> ArgInfo -> Abs Term -> Term
Lam ArgInfo
h forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs Abs Term
f
          Level Level
l     -> Level -> Term
Level forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs Level
l
          Lit Literal
l       -> forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
          Dummy{}     -> forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
          DontCare Term
v  -> Term -> Term
dontCare forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall r (m :: * -> *) o z.
(MonadReader r m, LensRelevance r, LensRelevance o) =>
o -> m z -> m z
underRelevance Relevance
Irrelevant forall a b. (a -> b) -> a -> b
$ forall t. Occurs t => t -> OccursM t
occurs Term
v
          Def QName
d Elims
es    -> do
            QName -> OccursM ()
definitionCheck QName
d
            QName -> Elims -> Term
Def QName
d forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {b}. Occurs b => QName -> b -> ReaderT OccursCtx (TCMT IO) b
occDef QName
d Elims
es
          Con ConHead
c ConInfo
ci Elims
vs -> do
            QName -> OccursM ()
definitionCheck (ConHead -> QName
conName ConHead
c)
            ConHead -> ConInfo -> Elims -> Term
Con ConHead
c ConInfo
ci forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Elims -> OccursM a -> OccursM a
conArgs Elims
vs (forall t. Occurs t => t -> OccursM t
occurs Elims
vs)  -- if strongly rigid, remain so, except with unreduced IApply arguments.
          Pi Dom Type
a Abs Type
b      -> forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Dom Type -> Abs Type -> Term
Pi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs (Dom Type
a,Abs Type
b)
          Sort Sort
s      -> Sort -> Term
Sort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall r (m :: * -> *) o z.
(MonadReader r m, LensRelevance r, LensRelevance o) =>
o -> m z -> m z
underRelevance Relevance
NonStrict forall a b. (a -> b) -> a -> b
$ forall t. Occurs t => t -> OccursM t
occurs Sort
s
          MetaV MetaId
m' Elims
es -> do
            MetaId
m' <- MetaId -> OccursM MetaId
metaCheck MetaId
m'

            forall (m :: * -> *) a. MonadBlock m => Blocker -> m a -> m a
addOrUnblocker (MetaId -> Blocker
unblockOnMeta MetaId
m') forall a b. (a -> b) -> a -> b
$ do
                         -- If getting stuck here, we need to trigger wakeup if this meta is
                         -- solved.
              -- The arguments of a meta are in a flexible position
              (MetaId -> Elims -> Term
MetaV MetaId
m' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall a. OccursM a -> OccursM a
flexibly forall a b. (a -> b) -> a -> b
$ forall t. Occurs t => t -> OccursM t
occurs Elims
es) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ TCErr
err -> do
                OccursCtx
ctx <- forall r (m :: * -> *). MonadReader r m => m r
ask
                forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.kill" Nat
25 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
                  [ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"error during flexible occurs check, we are " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (OccursCtx
ctx forall o i. o -> Lens' i o -> i
^. forall a o. LensFlexRig a o => Lens' (FlexRig' a) o
lensFlexRig)
                  , forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show TCErr
err
                  ]
                case TCErr
err of
                  -- On pattern violations try to remove offending
                  -- flexible occurrences (if not already in a flexible context)
                  PatternErr{} | Bool -> Bool
not (forall a o. LensFlexRig a o => o -> Bool
isFlexible OccursCtx
ctx) -> do
                    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.kill" Nat
20 forall a b. (a -> b) -> a -> b
$
                      [Char]
"oops, pattern violation for " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow MetaId
m'
                    -- Andreas, 2014-03-02, see issue 1070:
                    -- Do not prune when meta is projected!
                    forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es) (forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err) forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
vs -> do
                      PruneResult
killResult <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(PureTCM m, MonadMetaSolver m) =>
MetaId -> [Arg Term] -> (Nat -> Bool) -> m PruneResult
prune MetaId
m' [Arg Term]
vs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< OccursM (Nat -> Bool)
allowedVars
                      if (PruneResult
killResult forall a. Eq a => a -> a -> Bool
== PruneResult
PrunedEverything)
                        -- after successful pruning, restart occurs check
                        then forall t. Occurs t => t -> OccursM t
occurs forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *). (Instantiate a, MonadReduce m) => a -> m a
instantiate (MetaId -> Elims -> Term
MetaV MetaId
m' Elims
es)
                        else forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
                  TCErr
_ -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
          where
            -- a data or record type constructor propagates strong occurrences
            -- since e.g. x = List x is unsolvable
            occDef :: QName -> b -> ReaderT OccursCtx (TCMT IO) b
occDef QName
d b
vs = do
              MetaId
m   <- forall r (m :: * -> *) a. MonadReader r m => (r -> a) -> m a
asks (OccursExtra -> MetaId
occMeta forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. FreeEnv' a b c -> b
feExtra)
              forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m QName
d
              forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCM (Maybe DataOrRecord)
isDataOrRecordType QName
d)
                {-then-} (forall t. Occurs t => t -> OccursM t
occurs b
vs)
                {-else-} (forall a. OccursM a -> OccursM a
defArgs forall a b. (a -> b) -> a -> b
$ forall t. Occurs t => t -> OccursM t
occurs b
vs)

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

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

  metaOccurs :: MetaId -> QName -> TCM ()
metaOccurs MetaId
m QName
d = forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (QName -> TCM Bool
defNeedsChecking QName
d) forall a b. (a -> b) -> a -> b
$ do
    QName -> TCM ()
tallyDef QName
d
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.occurs" Nat
30 forall a b. (a -> b) -> a -> b
$ [Char]
"Checking for occurrences in " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show QName
d
    MetaId -> QName -> TCM ()
metaOccursQName MetaId
m QName
d

metaOccursQName :: MetaId -> QName -> TCM ()
metaOccursQName :: MetaId -> QName -> TCM ()
metaOccursQName MetaId
m QName
x = forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Defn
theDef forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
  forall (m :: * -> *) a. MonadTCEnv m => m a -> m a
ignoreAbstractMode forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). HasConstInfo m => 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 = forall a. HasCallStack => a
__IMPOSSIBLE__

  metaOccurs :: MetaId -> Defn -> TCM ()
metaOccurs MetaId
m Axiom{}                      = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  metaOccurs MetaId
m DataOrRecSig{}               = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  metaOccurs MetaId
m Function{ funClauses :: Defn -> [Clause]
funClauses = [Clause]
cls } = 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 }    = 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 forall a b. (a -> b) -> a -> b
$ ConHead -> QName
conName ConHead
c
  metaOccurs MetaId
m Constructor{}                = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  metaOccurs MetaId
m Primitive{}                  = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  metaOccurs MetaId
m PrimitiveSort{}              = forall a. HasCallStack => a
__IMPOSSIBLE__
  metaOccurs MetaId
m AbstractDefn{}               = forall a. HasCallStack => a
__IMPOSSIBLE__
  metaOccurs MetaId
m GeneralizableVar{}           = forall a. HasCallStack => a
__IMPOSSIBLE__

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

  metaOccurs :: MetaId -> Clause -> TCM ()
metaOccurs MetaId
m = forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clause -> Maybe Term
clauseBody

instance Occurs Level where
  occurs :: Level -> OccursM Level
occurs (Max Integer
n [PlusLevel' Term]
as) = forall t. Integer -> [PlusLevel' t] -> Level' t
Max Integer
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs [PlusLevel' Term]
as

  metaOccurs :: MetaId -> Level -> TCM ()
metaOccurs MetaId
m (Max Integer
_ [PlusLevel' Term]
as) = forall (m :: * -> *) a. MonadBlock m => Blocker -> m a -> m a
addOrUnblocker (forall t. AllMetas t => t -> Blocker
unblockOnAnyMetaIn [PlusLevel' Term]
as) forall a b. (a -> b) -> a -> b
$ 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 -> OccursM (PlusLevel' Term)
occurs (Plus Integer
n Term
l) = forall t. Integer -> t -> PlusLevel' t
Plus Integer
n forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs Term
l

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

instance Occurs Type where
  occurs :: Type -> OccursM Type
occurs (El Sort
s Term
v) = forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry forall t a. Sort' t -> a -> Type'' t a
El forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs (Sort
s,Term
v)

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

instance Occurs Sort where
  occurs :: Sort -> ReaderT OccursCtx (TCMT IO) Sort
occurs Sort
s = do
    forall t. (Instantiate t, Reduce t) => t -> OccursM t
unfold Sort
s forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      PiSort Dom' Term Term
a Sort
s1 Abs Sort
s2 -> do
        Sort
s1' <- forall a. OccursM a -> OccursM a
flexibly forall a b. (a -> b) -> a -> b
$ forall t. Occurs t => t -> OccursM t
occurs Sort
s1
        Dom' Term Term
a'  <- (Dom' Term Term
a forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall a. OccursM a -> OccursM a
flexibly forall a b. (a -> b) -> a -> b
$ forall t. Occurs t => t -> OccursM t
occurs forall a b. (a -> b) -> a -> b
$ forall t e. Dom' t e -> e
unDom Dom' Term Term
a
        Abs Sort
s2' <- forall a b (m :: * -> *).
(Subst a, Subst b, MonadAddContext m) =>
Dom Type -> (a -> m b) -> Abs a -> m (Abs b)
mapAbstraction (forall t a. Sort' t -> a -> Type'' t a
El Sort
s1' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom' Term Term
a') (forall a. OccursM a -> OccursM a
flexibly forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c (m :: * -> *) z.
MonadReader (FreeEnv' a b c) m =>
m z -> m z
underBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Occurs t => t -> OccursM t
occurs) Abs Sort
s2
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. Dom' t t -> Sort' t -> Abs (Sort' t) -> Sort' t
PiSort Dom' Term Term
a' Sort
s1' Abs Sort
s2'
      FunSort Sort
s1 Sort
s2 -> forall t. Sort' t -> Sort' t -> Sort' t
FunSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. OccursM a -> OccursM a
flexibly (forall t. Occurs t => t -> OccursM t
occurs Sort
s1) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall a. OccursM a -> OccursM a
flexibly (forall t. Occurs t => t -> OccursM t
occurs Sort
s2)
      Type Level
a     -> forall t. Level' t -> Sort' t
Type forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs Level
a
      Prop Level
a     -> forall t. Level' t -> Sort' t
Prop forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs Level
a
      s :: Sort
s@Inf{}    -> forall (m :: * -> *) a. Monad m => a -> m a
return Sort
s
      SSet Level
a     -> forall t. Level' t -> Sort' t
SSet forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs Level
a
      s :: Sort
s@Sort
SizeUniv -> forall (m :: * -> *) a. Monad m => a -> m a
return Sort
s
      s :: Sort
s@Sort
LockUniv -> forall (m :: * -> *) a. Monad m => a -> m a
return Sort
s
      s :: Sort
s@Sort
IntervalUniv -> forall (m :: * -> *) a. Monad m => a -> m a
return Sort
s
      UnivSort Sort
s -> forall t. Sort' t -> Sort' t
UnivSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall a. OccursM a -> OccursM a
flexibly forall a b. (a -> b) -> a -> b
$ forall t. Occurs t => t -> OccursM t
occurs Sort
s
      MetaS MetaId
x Elims
es -> do
        MetaV MetaId
x Elims
es <- forall t. Occurs t => t -> OccursM t
occurs (MetaId -> Elims -> Term
MetaV MetaId
x Elims
es)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. MetaId -> [Elim' t] -> Sort' t
MetaS MetaId
x Elims
es
      DefS QName
x Elims
es -> do
        Def QName
x Elims
es <- forall t. Occurs t => t -> OccursM t
occurs (QName -> Elims -> Term
Def QName
x Elims
es)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. QName -> [Elim' t] -> Sort' t
DefS QName
x Elims
es
      DummyS{}   -> forall (m :: * -> *) a. Monad m => a -> m a
return Sort
s

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

instance Occurs a => Occurs (Elim' a) where
  occurs :: Elim' a -> OccursM (Elim' a)
occurs e :: Elim' a
e@(Proj ProjOrigin
_ QName
f)   = Elim' a
e forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ QName -> OccursM ()
definitionCheck QName
f
  occurs (Apply Arg a
a)      = forall a. Arg a -> Elim' a
Apply  forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs Arg a
a
  occurs (IApply a
x a
y a
a) = forall a. a -> a -> a -> Elim' a
IApply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Occurs t => t -> OccursM t
occurs a
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Occurs t => t -> OccursM t
occurs a
a

  metaOccurs :: MetaId -> Elim' a -> TCM ()
metaOccurs MetaId
m (Proj{} ) = forall (m :: * -> *) a. Monad m => a -> m a
return ()
  metaOccurs MetaId
m (Apply Arg a
a) = forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m Arg a
a
  metaOccurs MetaId
m (IApply a
x a
y a
a) = forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m (a
x,(a
y,a
a))

instance (Occurs a, Subst a) => Occurs (Abs a) where
  occurs :: Abs a -> OccursM (Abs a)
occurs b :: Abs a
b@(Abs [Char]
s a
_) = forall a. [Char] -> a -> Abs a
Abs   [Char]
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs a
b forall a b. (a -> b) -> a -> b
$ forall a b c (m :: * -> *) z.
MonadReader (FreeEnv' a b c) m =>
m z -> m z
underBinder forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Occurs t => t -> OccursM t
occurs
  occurs (NoAbs [Char]
s a
x) = forall a. [Char] -> a -> Abs a
NoAbs [Char]
s forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs a
x

  metaOccurs :: MetaId -> Abs a -> TCM ()
metaOccurs MetaId
m (Abs   [Char]
_ a
x) = forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m a
x
  metaOccurs MetaId
m (NoAbs [Char]
_ a
x) = 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) = forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do forall r (m :: * -> *) o z.
(MonadReader r m, LensModality r, LensModality o) =>
o -> m z -> m z
underModality ArgInfo
info forall a b. (a -> b) -> a -> b
$ forall t. Occurs t => t -> OccursM t
occurs a
v
  metaOccurs :: MetaId -> Arg a -> TCM ()
metaOccurs MetaId
m = forall t. Occurs t => MetaId -> t -> TCM ()
metaOccurs MetaId
m forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg

instance Occurs a => Occurs (Dom a) where
instance Occurs a => Occurs [a] where
instance Occurs a => Occurs (Maybe a) where

instance (Occurs a, Occurs b) => Occurs (a,b) where
  occurs :: (a, b) -> OccursM (a, b)
occurs (a
x,b
y) = (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Occurs t => t -> OccursM t
occurs b
y

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

instance (Occurs a, Occurs b, Occurs c) => Occurs (a,b,c) where
  occurs :: (a, b, c) -> OccursM (a, b, c)
occurs (a
x,b
y,c
z) = (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Occurs t => t -> OccursM t
occurs a
x forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Occurs t => t -> OccursM t
occurs b
y forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. Occurs t => t -> OccursM t
occurs c
z

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

---------------------------------------------------------------------------
-- * 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
  :: (PureTCM m, MonadMetaSolver m)
  => MetaId         -- ^ Meta to prune.
  -> Args           -- ^ Arguments to meta variable.
  -> (Nat -> Bool)  -- ^ Test for allowed variable (de Bruijn index).
  -> m PruneResult
prune :: forall (m :: * -> *).
(PureTCM m, MonadMetaSolver m) =>
MetaId -> [Arg Term] -> (Nat -> Bool) -> m PruneResult
prune MetaId
m' [Arg Term]
vs Nat -> Bool
xs = do
  forall (m :: * -> *) a b c.
Monad m =>
m (Either a b) -> (a -> m c) -> (b -> m c) -> m c
caseEitherM (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((forall (m :: * -> *).
PureTCM m =>
(Nat -> Bool) -> Term -> ExceptT () m Bool
hasBadRigid Nat -> Bool
xs) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term]
vs)
    (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return PruneResult
PrunedNothing) forall a b. (a -> b) -> a -> b
$ \ [Bool]
kills -> do
    forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.kill" Nat
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ TCMT IO Doc
"attempting kills"
      , forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"m'    =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m 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    =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList (forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Arg Term]
vs)
        , TCMT IO Doc
"kills =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Applicative m => [Char] -> m Doc
text (forall a. Show a => a -> [Char]
show [Bool]
kills)
        ]
      ]
    forall (m :: * -> *).
MonadMetaSolver m =>
[Bool] -> MetaId -> m 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
  :: PureTCM m
  => (Nat -> Bool)      -- ^ Test for allowed variable (de Bruijn index).
  -> Term               -- ^ Argument of meta variable.
  -> ExceptT () m Bool  -- ^ Exception if argument is matchable.
hasBadRigid :: forall (m :: * -> *).
PureTCM m =>
(Nat -> Bool) -> Term -> ExceptT () m Bool
hasBadRigid Nat -> Bool
xs Term
t = do
  -- We fail if we encounter a matchable argument.
  let failure :: ExceptT () m a
failure = forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError ()
  Blocked Term
tb <- forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Term
t
  let t :: Term
t = forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
tb
  case Term
t of
    Var Nat
x Elims
_      -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ Nat -> Bool
xs Nat
x
    -- Issue 1153: A lambda has to be considered matchable.
    -- Lam _ v    -> hasBadRigid (0 : map (+1) xs) (absBody v)
    Lam ArgInfo
_ Abs Term
v      -> forall {a}. ExceptT () m a
failure
    DontCare Term
v   -> forall (m :: * -> *).
PureTCM m =>
(Nat -> Bool) -> Term -> ExceptT () m Bool
hasBadRigid Nat -> 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) -> forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifNotM (forall (m :: * -> *) t.
HasConstInfo m =>
Blocked t -> QName -> Elims -> m Bool
isNeutral Blocked Term
tb QName
f Elims
es) forall {a}. ExceptT () m a
failure forall a b. (a -> b) -> a -> b
$ {- else -} do
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Elims
es forall (m :: * -> *) a.
(PureTCM m, AnyRigid a) =>
a -> (Nat -> Bool) -> m Bool
`rigidVarsNotContainedIn` Nat -> 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       -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ (Dom Type
a,Abs Type
b) forall (m :: * -> *) a.
(PureTCM m, AnyRigid a) =>
a -> (Nat -> Bool) -> m Bool
`rigidVarsNotContainedIn` Nat -> Bool
xs
    Level Level
v      -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Level
v forall (m :: * -> *) a.
(PureTCM m, AnyRigid a) =>
a -> (Nat -> Bool) -> m Bool
`rigidVarsNotContainedIn` Nat -> Bool
xs
    Sort Sort
s       -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Sort
s forall (m :: * -> *) a.
(PureTCM m, AnyRigid a) =>
a -> (Nat -> Bool) -> m Bool
`rigidVarsNotContainedIn` Nat -> 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 <- forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es -> do
      forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *). 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!)
        (forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *).
PureTCM m =>
(Nat -> Bool) -> Term -> ExceptT () m Bool
hasBadRigid Nat -> Bool
xs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term]
args)  -- not andM, we need to force the exceptions!
        forall {a}. ExceptT () m a
failure
    Con ConHead
c ConInfo
_ Elims
es | Bool
otherwise -> forall {a}. ExceptT () m a
failure
    Lit{}        -> forall {a}. ExceptT () m a
failure -- matchable
    MetaV{}      -> forall {a}. ExceptT () m a
failure -- potentially matchable
    Dummy{}      -> 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 = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
      no :: m Bool
no  = forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  Definition
def <- forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
f
  if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null forall a b. (a -> b) -> a -> b
$ Definition -> Set QName
defMatchable Definition
def) then m Bool
no else do
  case Definition -> Defn
theDef Definition
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{} -> 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 -> (Nat -> Bool) -> m Bool
rigidVarsNotContainedIn a
v Nat -> Bool
is = do
  Nat
n0 <- forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Nat
getContextSize
  let -- allowed variables as de Bruijn levels
      levels :: Nat -> Bool
levels = Nat -> Bool
is forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Nat
n0forall a. Num a => a -> a -> a
-Nat
1 forall a. Num a => a -> a -> a
-)
      -- test if index is forbidden by converting it to level
      test :: Nat -> m Bool
test Nat
i = do
        Nat
n <- forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Nat
getContextSize
        -- get de Bruijn level for i
        let l :: Nat
l = Nat
nforall a. Num a => a -> a -> a
-Nat
1 forall a. Num a => a -> a -> a
- Nat
i
            -- If l >= n0 then it is a bound variable and can be
            -- ignored.  Otherwise, it has to be in the allowed levels.
            forbidden :: Bool
forbidden = Nat
l forall a. Ord a => a -> a -> Bool
< Nat
n0 Bool -> Bool -> Bool
&& Bool -> Bool
not (Nat -> Bool
levels Nat
l)
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
forbidden forall a b. (a -> b) -> a -> b
$
          forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.kill" Nat
20 forall a b. (a -> b) -> a -> b
$
            [Char]
"found forbidden de Bruijn level " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show Nat
l
        forall (m :: * -> *) a. Monad m => a -> m a
return Bool
forbidden
  forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> m Bool
test a
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 =>
(Nat -> tcm Bool) -> Term -> tcm Bool
anyRigid Nat -> tcm Bool
f Term
t = do
    Blocked Term
b <- forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Term
t
    case forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
b of
      -- Upon entry, we are in rigid position, thus,
      -- bound variables are rigid ones.
      Var Nat
i Elims
es   -> Nat -> tcm Bool
f Nat
i forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`or2M` forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> tcm Bool
f Elims
es
      Lam ArgInfo
_ Abs Term
t    -> forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> tcm Bool
f Abs Term
t
      Lit{}      -> 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{}                   -> 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        -- _        -> mempty -- breaks: ImproveInertRHS, Issue442, PruneRecord, PruningNonMillerPattern
        Blocked Term
_        -> forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> tcm Bool
f Elims
es
      Con ConHead
_ ConInfo
_ Elims
ts -> forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> tcm Bool
f Elims
ts
      Pi Dom Type
a Abs Type
b     -> forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> tcm Bool
f (Dom Type
a,Abs Type
b)
      Sort Sort
s     -> forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> tcm Bool
f Sort
s
      Level Level
l    -> forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> tcm Bool
f Level
l
      MetaV{}    -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      DontCare{} -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Dummy{}    -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

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

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

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

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

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

instance AnyRigid a => AnyRigid (Arg a) where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Nat -> tcm Bool) -> Arg a -> tcm Bool
anyRigid Nat -> tcm Bool
f Arg a
a =
    case forall a. LensRelevance a => a -> Relevance
getRelevance Arg a
a of
      -- Irrelevant arguments are definitionally equal to
      -- values, so the variables there are not considered
      -- "definitely rigid".
      Relevance
Irrelevant -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      Relevance
_          -> forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> tcm Bool
f forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg a
a

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

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

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

instance (AnyRigid a, AnyRigid b) => AnyRigid (a,b) where
  anyRigid :: forall (tcm :: * -> *).
PureTCM tcm =>
(Nat -> tcm Bool) -> (a, b) -> tcm Bool
anyRigid Nat -> tcm Bool
f (a
a,b
b) = forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> tcm Bool
f a
a forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`or2M` forall a (tcm :: * -> *).
(AnyRigid a, PureTCM tcm) =>
(Nat -> tcm Bool) -> a -> tcm Bool
anyRigid Nat -> 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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: PruneResult -> PruneResult -> Bool
$c/= :: PruneResult -> PruneResult -> Bool
== :: PruneResult -> PruneResult -> Bool
$c== :: PruneResult -> PruneResult -> Bool
Eq, Nat -> PruneResult -> ShowS
[PruneResult] -> ShowS
PruneResult -> [Char]
forall a.
(Nat -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [PruneResult] -> ShowS
$cshowList :: [PruneResult] -> ShowS
show :: PruneResult -> [Char]
$cshow :: PruneResult -> [Char]
showsPrec :: Nat -> PruneResult -> ShowS
$cshowsPrec :: Nat -> PruneResult -> ShowS
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 :: (MonadMetaSolver m) => [Bool] -> MetaId -> m PruneResult
killArgs :: forall (m :: * -> *).
MonadMetaSolver m =>
[Bool] -> MetaId -> m PruneResult
killArgs [Bool]
kills MetaId
_
  | Bool -> Bool
not (forall (t :: * -> *). Foldable t => t Bool -> Bool
or [Bool]
kills) = forall (m :: * -> *) a. Monad m => a -> m a
return PruneResult
NothingToPrune  -- nothing to kill
killArgs [Bool]
kills MetaId
m = do
  MetaVariable
mv <- forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m MetaVariable
lookupLocalMeta MetaId
m
  Bool
allowAssign <- forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Bool
envAssignMetas
  if MetaVariable -> Frozen
mvFrozen MetaVariable
mv forall a. Eq a => a -> a -> Bool
== Frozen
Frozen Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
allowAssign then forall (m :: * -> *) a. Monad m => a -> m a
return PruneResult
PrunedNothing else do
      -- Andreas 2011-04-26, we allow pruning in MetaV and MetaS
      let a :: Type
a = forall a. Judgement a -> Type
jMetaType forall a b. (a -> b) -> a -> b
$ MetaVariable -> Judgement MetaId
mvJudgement MetaVariable
mv
      TelV Tele (Dom Type)
tel Type
b <- Type -> TelV Type
telView' forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(InstantiateFull a, MonadReduce m) =>
a -> m a
instantiateFull Type
a
      let args :: [(Dom ([Char], Type), Bool)]
args         = forall a b. [a] -> [b] -> [(a, b)]
zip (forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Tele (Dom Type)
tel) ([Bool]
kills forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Bool
False)
      ([Arg Bool]
kills', Type
a') <- forall (m :: * -> *).
MonadReduce m =>
[(Dom ([Char], Type), Bool)] -> Type -> m ([Arg Bool], Type)
killedType [(Dom ([Char], Type), Bool)]
args Type
b
      [Arg Bool] -> Type -> Type -> m ()
dbg [Arg Bool]
kills' Type
a Type
a'
      -- If there is any prunable argument, perform the pruning
      if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any forall e. Arg e -> e
unArg [Arg Bool]
kills') then forall (m :: * -> *) a. Monad m => a -> m a
return PruneResult
PrunedNothing else do
        forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Tele (Dom Type)
tel forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadMetaSolver m =>
[Arg Bool] -> MetaId -> Type -> m ()
performKill [Arg Bool]
kills' MetaId
m Type
a'
        -- Only successful if all occurrences were killed
        -- Andreas, 2011-05-09 more precisely, check that at least
        -- the in 'kills' prescribed kills were carried out
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ if (forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Bool -> Bool -> Bool
implies [Bool]
kills forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg Bool]
kills')
                   then PruneResult
PrunedEverything
                   else PruneResult
PrunedSomething
  where
    implies :: Bool -> Bool -> Bool
    implies :: Bool -> Bool -> Bool
implies Bool
False Bool
_ = Bool
True
    implies Bool
True  Bool
x = Bool
x
    dbg :: [Arg Bool] -> Type -> Type -> m ()
dbg [Arg Bool]
kills' Type
a Type
a' =
      forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.kill" Nat
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"after kill analysis"
        , forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"metavar =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM MetaId
m
          , TCMT IO Doc
"kills   =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Applicative m => [Char] -> m Doc
text (forall a. Show a => a -> [Char]
show [Bool]
kills)
          , TCMT IO Doc
"kills'  =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList (forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Arg Bool]
kills')
          , TCMT IO Doc
"oldType =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
a
          , TCMT IO Doc
"newType =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
a'
          ]
        ]

-- | @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], Type)
killedType :: forall (m :: * -> *).
MonadReduce m =>
[(Dom ([Char], Type), Bool)] -> Type -> m ([Arg Bool], Type)
killedType [(Dom ([Char], Type), Bool)]
args Type
b = do

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

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

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

  -- Then recurse over the telescope (right-to-left), building up the final type.
  (IntSet
killed, Type
b) <- forall (m :: * -> *).
MonadReduce m =>
[Dom ([Char], Type)] -> IntSet -> Type -> m (IntSet, Type)
go (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Dom ([Char], Type), Bool)]
args) IntSet
tokill Type
b

  -- Turn the IntSet of killed variables into the list of Arg Bool's to return.
  let kills :: [Arg Bool]
kills = [ forall e. ArgInfo -> e -> Arg e
Arg (forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom ([Char], Type)
dom) (Nat -> IntSet -> Bool
IntSet.member Nat
i IntSet
killed)
              | (Nat
i, (Dom ([Char], Type)
dom, Bool
_)) <- [(Nat, (Dom ([Char], Type), Bool))]
iargs ]
  forall (m :: * -> *) a. Monad m => a -> m a
return ([Arg Bool]
kills, Type
b)
  where
    down :: IntSet -> IntSet
down = (Nat -> Nat) -> IntSet -> IntSet
IntSet.map forall a. Enum a => a -> a
pred
    up :: IntSet -> IntSet
up   = (Nat -> Nat) -> IntSet -> IntSet
IntSet.map forall a. Enum a => a -> a
succ

    -- 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)] -> IntSet -> Type -> m (IntSet, Type)
    go :: forall (m :: * -> *).
MonadReduce m =>
[Dom ([Char], Type)] -> IntSet -> Type -> m (IntSet, Type)
go [] IntSet
xs Type
b | IntSet -> Bool
IntSet.null IntSet
xs = forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet
xs, Type
b)
               | Bool
otherwise      = forall a. HasCallStack => a
__IMPOSSIBLE__
    go (Dom ([Char], Type)
arg : [Dom ([Char], Type)]
args) IntSet
xs Type
b  -- go (Δ (x : A)) xs B, (x = deBruijn index 0)
      | Nat -> IntSet -> Bool
IntSet.member Nat
0 IntSet
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 :: IntSet
ys = IntSet -> IntSet
down (Nat -> IntSet -> IntSet
IntSet.delete Nat
0 IntSet
xs)
          (IntSet
ys, Type
b) <- forall (m :: * -> *).
MonadReduce m =>
[Dom ([Char], Type)] -> IntSet -> Type -> m (IntSet, Type)
go [Dom ([Char], Type)]
args IntSet
ys forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Impossible -> a -> a
strengthen HasCallStack => Impossible
impossible Type
b
          -- We need to return a set of killed variables relative to Δ (x : A), so
          -- shift ys and add x back in.
          forall (m :: * -> *) a. Monad m => a -> m a
return (Nat -> IntSet -> IntSet
IntSet.insert Nat
0 forall a b. (a -> b) -> a -> b
$ IntSet -> IntSet
up IntSet
ys, Type
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' :: IntSet
xs'       = IntSet -> IntSet
down IntSet
xs -- Shift to make relative to Δ ⊢ A
              ([Char]
name, Type
a) = forall t e. Dom' t e -> e
unDom Dom ([Char], Type)
arg
          (IntSet
ys, Type
a) <- forall (m :: * -> *).
MonadReduce m =>
IntSet -> Type -> m (IntSet, Type)
reallyNotFreeIn IntSet
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.
          (IntSet
zs, Type
b) <- forall (m :: * -> *).
MonadReduce m =>
[Dom ([Char], Type)] -> IntSet -> Type -> m (IntSet, Type)
go [Dom ([Char], Type)]
args IntSet
ys forall a b. (a -> b) -> a -> b
$ Dom ([Char], Type) -> Type -> Type
mkPi (([Char]
name, Type
a) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Dom ([Char], Type)
arg) Type
b
          -- Shift back up to make it relative to Δ (x : A) again.
          forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> IntSet
up IntSet
zs, Type
b)

reallyNotFreeIn :: (MonadReduce m) => IntSet -> Type -> m (IntSet, Type)
reallyNotFreeIn :: forall (m :: * -> *).
MonadReduce m =>
IntSet -> Type -> m (IntSet, Type)
reallyNotFreeIn IntSet
xs Type
a | IntSet -> Bool
IntSet.null IntSet
xs = forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet
xs, Type
a) -- Shortcut
reallyNotFreeIn IntSet
xs Type
a = do
  let fvs :: VarMap
fvs      = forall a c t. (IsVarSet a c, Singleton Nat c, Free t) => t -> c
freeVars Type
a
      anywhere :: IntSet
anywhere = VarMap -> IntSet
allVars VarMap
fvs
      rigid :: IntSet
rigid    = forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions [VarMap -> IntSet
stronglyRigidVars VarMap
fvs, VarMap -> IntSet
unguardedVars VarMap
fvs]
      nonrigid :: IntSet
nonrigid = IntSet -> IntSet -> IntSet
IntSet.difference IntSet
anywhere IntSet
rigid
      hasNo :: IntSet -> Bool
hasNo    = IntSet -> IntSet -> Bool
IntSet.disjoint IntSet
xs
  if IntSet -> Bool
hasNo IntSet
nonrigid
    then
       -- No non-rigid occurrences. We can't do anything about the rigid
       -- occurrences so drop those and leave `a` untouched.
       forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet -> IntSet -> IntSet
IntSet.difference IntSet
xs IntSet
rigid, Type
a)
    else do
      -- If there are non-rigid occurrences we need to reduce a to see if
      -- we can get rid of them (#3177).
      (IntMap IsFree
fvs, Type
a) <- forall a (m :: * -> *).
(ForceNotFree a, Reduce a, MonadReduce m) =>
IntSet -> a -> m (IntMap IsFree, a)
forceNotFree (IntSet -> IntSet -> IntSet
IntSet.difference IntSet
xs IntSet
rigid) Type
a
      let xs :: IntSet
xs = forall a. IntMap a -> IntSet
IntMap.keysSet forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> IntMap a -> IntMap a
IntMap.filter (forall a. Eq a => a -> a -> Bool
== IsFree
NotFree) IntMap IsFree
fvs
      forall (m :: * -> *) a. Monad m => a -> m a
return (IntSet
xs, Type
a)

-- | Instantiate a meta variable with a new one that only takes
--   the arguments which are not pruneable.
performKill
  :: MonadMetaSolver m
  => [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.
  -> Type          -- ^ The pruned type of the new meta var.
  -> m ()
performKill :: forall (m :: * -> *).
MonadMetaSolver m =>
[Arg Bool] -> MetaId -> Type -> m ()
performKill [Arg Bool]
kills MetaId
m Type
a = do
  MetaVariable
mv <- forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m MetaVariable
lookupLocalMeta MetaId
m
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (MetaVariable -> Frozen
mvFrozen MetaVariable
mv forall a. Eq a => a -> a -> Bool
== Frozen
Frozen) forall a. HasCallStack => a
__IMPOSSIBLE__
  -- Arity of the old meta.
  let n :: Nat
n = forall a. Sized a => a -> Nat
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 :: Permutation
perm = Nat -> [Nat] -> Permutation
Perm Nat
n
             [ Nat
i | (Nat
i, Arg ArgInfo
_ Bool
False) <- forall a b. [a] -> [b] -> [(a, b)]
zip [Nat
0..] [Arg Bool]
kills ]
      -- The permutation for the old meta might range over a prefix of the arguments
      oldPerm :: Permutation
oldPerm = Nat -> Permutation -> Permutation
liftP (forall a. Ord a => a -> a -> a
max Nat
0 forall a b. (a -> b) -> a -> b
$ Nat
n forall a. Num a => a -> a -> a
- Nat
m) Permutation
p
        where p :: Permutation
p = MetaVariable -> Permutation
mvPermutation MetaVariable
mv
              m :: Nat
m = forall a. Sized a => a -> Nat
size Permutation
p
      judg :: Judgement Any
judg = case MetaVariable -> Judgement MetaId
mvJudgement MetaVariable
mv of
        HasType{ jComparison :: forall a. Judgement a -> Comparison
jComparison = Comparison
cmp } -> forall a. a -> Comparison -> Type -> Judgement a
HasType forall a. HasCallStack => a
__IMPOSSIBLE__ Comparison
cmp Type
a
        IsSort{}  -> forall a. a -> Type -> Judgement a
IsSort  forall a. HasCallStack => a
__IMPOSSIBLE__ Type
a
  MetaId
m' <- forall (m :: * -> *) a.
MonadMetaSolver m =>
Frozen
-> MetaInfo
-> MetaPriority
-> Permutation
-> Judgement a
-> m MetaId
newMeta Frozen
Instantiable (MetaVariable -> MetaInfo
mvInfo MetaVariable
mv) (MetaVariable -> MetaPriority
mvPriority MetaVariable
mv) (Permutation -> Permutation -> Permutation
composeP Permutation
perm Permutation
oldPerm) Judgement Any
judg
  -- Andreas, 2010-10-15 eta expand new meta variable if necessary
  forall (m :: * -> *). MonadMetaSolver m => MetaId -> m ()
etaExpandMetaSafe MetaId
m'
  let -- Arguments to new meta (de Bruijn indices)
      -- in left to right order.
      vars :: [Arg Term]
vars = [ forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info (Nat -> Term
var Nat
i)
             | (Nat
i, Arg ArgInfo
info Bool
False) <- forall a b. [a] -> [b] -> [(a, b)]
zip (forall a. Integral a => a -> [a]
downFrom Nat
n) [Arg Bool]
kills ]
      u :: Term
u       = MetaId -> Elims -> Term
MetaV MetaId
m' forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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 [Char]]
tel     = forall a b. (a -> b) -> [a] -> [b]
map ([Char]
"v" forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$) [Arg Bool]
kills
  MetaId -> Term -> m ()
dbg MetaId
m' Term
u
  forall (m :: * -> *).
MonadMetaSolver m =>
MetaId -> [Arg [Char]] -> Term -> m ()
assignTerm MetaId
m [Arg [Char]]
tel Term
u  -- m tel := u
  where
    dbg :: MetaId -> Term -> m ()
dbg MetaId
m' Term
u = forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.kill" Nat
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ TCMT IO Doc
"actual killing"
      , forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"new meta:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty MetaId
m'
        , TCMT IO Doc
"kills   :" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList_ (forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Bool]
kills)
        , TCMT IO Doc
"inst    :" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty MetaId
m forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
":=" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
u
        ]
      ]