{-# LANGUAGE CPP #-}
{-# LANGUAGE NondecreasingIndentation #-}
-- {-# OPTIONS_GHC -Wunused-imports #-}
-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-}

{-# OPTIONS_GHC -fmax-pmcheck-models=390 #-} -- Andreas, 2023-05-12, limit determined by binary search

module Agda.TypeChecking.Conversion
  ( module Agda.TypeChecking.Conversion
  , failConversion
  )
  where

import Control.Monad.Except ( MonadError(..) )

import Data.Function (on)
import Data.IntMap (IntMap)

-- import qualified Data.List   as List
import qualified Data.IntMap as IntMap
import qualified Data.Set    as Set

import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.Syntax.Internal.MetaVars
import Agda.Syntax.Translation.InternalToAbstract (reify)

import Agda.TypeChecking.Monad
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.MetaVars.Occurs (killArgs,PruneResult(..),rigidVarsNotContainedIn)
import Agda.TypeChecking.Names
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import qualified Agda.TypeChecking.SyntacticEquality as SynEq
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Constraints
import Agda.TypeChecking.Conversion.Pure (pureCompareAs, runPureConversion)
import Agda.TypeChecking.Forcing (isForced, nextIsForced)
import Agda.TypeChecking.Free
import Agda.TypeChecking.Datatypes (getConType, getFullyAppliedConType)
import Agda.TypeChecking.Records
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Injectivity
import Agda.TypeChecking.Polarity
import Agda.TypeChecking.SizedTypes
import Agda.TypeChecking.Level
import Agda.TypeChecking.Implicit (implicitArgs)
import Agda.TypeChecking.Irrelevance
import Agda.TypeChecking.Primitive
import Agda.TypeChecking.ProjectionLike
import Agda.TypeChecking.Warnings (MonadWarning)
import Agda.TypeChecking.Conversion.Errors
import Agda.Interaction.Options

import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.List1 (List1, pattern (:|))
import qualified Agda.Utils.List1 as List1
import Agda.Utils.Monad
import Agda.Utils.Maybe
import Agda.Utils.Permutation
import Agda.Syntax.Common.Pretty (prettyShow)
import qualified Agda.Interaction.Options.ProfileOptions as Profile
import Agda.Utils.BoolSet (BoolSet)
import qualified Agda.Utils.BoolSet as BoolSet
import Agda.Utils.Size
import Agda.Utils.Tuple
import Agda.Utils.Unsafe ( unsafeComparePointers )
import qualified Agda.Utils.VarSet as VarSet
import Agda.Utils.ExpandCase

import Agda.Utils.Impossible


-- | Try whether a computation runs without errors or new constraints
--   (may create new metas, though).
--   Restores state upon failure.
tryConversion :: TCM () -> TCM Bool
tryConversion :: TCMT IO () -> TCMT IO Bool
tryConversion = Maybe () -> Bool
forall a. Maybe a -> Bool
isJust (Maybe () -> Bool)
-> (TCMT IO () -> TCMT IO (Maybe ())) -> TCMT IO () -> TCMT IO Bool
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> TCMT IO () -> TCMT IO (Maybe ())
forall a. TCM a -> TCM (Maybe a)
tryConversion'

-- | Try whether a computation runs without errors or new constraints
--   (may create new metas, though).
--   Return 'Just' the result upon success.
--   Return 'Nothing' and restore state upon failure.
tryConversion' :: TCM a -> TCM (Maybe a)
tryConversion' :: forall a. TCM a -> TCM (Maybe a)
tryConversion' TCM a
m = TCM a -> TCMT IO (Maybe a)
forall e (m :: * -> *) a. MonadError e m => m a -> m (Maybe a)
tryMaybe (TCM a -> TCMT IO (Maybe a)) -> TCM a -> TCMT IO (Maybe a)
forall a b. (a -> b) -> a -> b
$ TCM a -> TCM a
forall (m :: * -> *) a.
(MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) =>
m a -> m a
noConstraints TCM a
m

-- | Check if to lists of arguments are the same (and all variables).
--   Precondition: the lists have the same length.
sameVars :: Elims -> Elims -> Bool
sameVars :: [Elim] -> [Elim] -> Bool
sameVars [Elim]
xs [Elim]
ys = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> [Bool] -> Bool
forall a b. (a -> b) -> a -> b
$ (Elim -> Elim -> Bool) -> [Elim] -> [Elim] -> [Bool]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Elim -> Elim -> Bool
same [Elim]
xs [Elim]
ys
    where
        same :: Elim -> Elim -> Bool
same (Apply (Arg ArgInfo
_ (Var Nat
n []))) (Apply (Arg ArgInfo
_ (Var Nat
m []))) = Nat
n Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
m
        same Elim
_ Elim
_ = Bool
False

-- | @intersectVars us vs@ checks whether all relevant elements in @us@ and @vs@
--   are variables, and if yes, returns a prune list which says @True@ for
--   arguments which are different and can be pruned.
intersectVars :: Elims -> Elims -> Maybe [Bool]
intersectVars :: [Elim] -> [Elim] -> Maybe [Bool]
intersectVars = (Elim -> Elim -> Maybe Bool) -> [Elim] -> [Elim] -> Maybe [Bool]
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m [c]
zipWithM Elim -> Elim -> Maybe Bool
areVars where
    -- ignore irrelevant args
    areVars :: Elim -> Elim -> Maybe Bool
areVars (Apply Arg Term
u) Elim
v | Arg Term -> Bool
forall a. LensRelevance a => a -> Bool
isIrrelevant Arg Term
u = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False -- do not prune
    areVars (Apply (Arg ArgInfo
_ (Var Nat
n []))) (Apply (Arg ArgInfo
_ (Var Nat
m []))) = Bool -> Maybe Bool
forall a. a -> Maybe a
Just (Bool -> Maybe Bool) -> Bool -> Maybe Bool
forall a b. (a -> b) -> a -> b
$ Nat
n Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
/= Nat
m -- prune different vars
    areVars Elim
_ Elim
_                                   = Maybe Bool
forall a. Maybe a
Nothing

-- | @guardPointerEquality x y s m@ behaves as @m@ if @x@ and @y@ are equal as pointers,
-- or does nothing otherwise.
-- Use with care, see the documentation for 'unsafeComparePointers'
guardPointerEquality :: a -> a -> String -> TCM () -> TCM ()
guardPointerEquality :: forall a. a -> a -> [Char] -> TCMT IO () -> TCMT IO ()
guardPointerEquality a
u a
v [Char]
profileSection TCMT IO ()
action =
  if a -> a -> Bool
forall a. a -> a -> Bool
unsafeComparePointers a
u a
v
  then ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
profileSection
  else TCMT IO ()
action

equalTerm :: Type -> Term -> Term -> TCM ()
equalTerm :: Type'' Term Term -> Term -> Term -> TCMT IO ()
equalTerm = Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTerm Comparison
CmpEq

equalAtom :: CompareAs -> Term -> Term -> TCM ()
equalAtom :: CompareAs -> Term -> Term -> TCMT IO ()
equalAtom = Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAtom Comparison
CmpEq

equalType :: Type -> Type -> TCM ()
equalType :: Type'' Term Term -> Type'' Term Term -> TCMT IO ()
equalType = Comparison -> Type'' Term Term -> Type'' Term Term -> TCMT IO ()
compareType Comparison
CmpEq

{- Comparing in irrelevant context always succeeds.

   However, we might want to dig for solutions of irrelevant metas.

   To this end, we can just ignore errors during conversion checking.
 -}

-- convError ::  MonadTCM tcm => TypeError -> tcm a
-- | Ignore errors in irrelevant context.
convError :: TypeError -> TCM ()
convError :: TypeError -> TCMT IO ()
convError TypeError
err =
  TCMT IO Bool -> TCMT IO () -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Relevance -> Bool
forall a. LensRelevance a => a -> Bool
isIrrelevant (Relevance -> Bool) -> TCMT IO Relevance -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' TCEnv Relevance -> TCMT IO Relevance
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (Relevance -> f Relevance) -> TCEnv -> f TCEnv
Lens' TCEnv Relevance
eRelevance)
    (() -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
    (TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
err)


-- | Type directed equality on values.
--
compareTerm :: Comparison -> Type -> Term -> Term -> TCM ()
compareTerm :: Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTerm !Comparison
cmp !Type'' Term Term
a !Term
u !Term
v = Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAs Comparison
cmp (Type'' Term Term -> CompareAs
AsTermsOf Type'' Term Term
a) Term
u Term
v


-- | Type directed equality on terms or types.
compareAs :: Comparison -> CompareAs -> Term -> Term -> TCM ()
  -- If one term is a meta, try to instantiate right away. This avoids unnecessary unfolding.
  -- Andreas, 2012-02-14: This is UNSOUND for subtyping!
compareAs :: Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAs !Comparison
cmp !CompareAs
a !Term
u !Term
v = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.term" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
    [ TCMT IO Doc
"compareTerm"
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
u TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Comparison -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Comparison -> m Doc
prettyTCM Comparison
cmp TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ CompareAs -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => CompareAs -> m Doc
prettyTCM CompareAs
a
    ]
  ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare"

  -- OLD CODE, traverses the *full* terms u v at each step, even if they
  -- are different somewhere.  Leads to infeasibility in issue 854.
  -- (u, v) <- instantiateFull (u, v)
  -- let equal = u == v

  -- Check syntactic equality. This actually saves us quite a bit of work.
  Term -> Term -> [Char] -> TCMT IO () -> TCMT IO ()
forall a. a -> a -> [Char] -> TCMT IO () -> TCMT IO ()
guardPointerEquality Term
u Term
v [Char]
"pointer equality: terms" (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Term
-> Term
-> (Term -> Term -> TCMT IO ())
-> (Term -> Term -> TCMT IO ())
-> TCMT IO ()
forall a (m :: * -> *) b.
(Instantiate a, SynEq a, MonadReduce m) =>
a -> a -> (a -> a -> m b) -> (a -> a -> m b) -> m b
SynEq.checkSyntacticEquality Term
u Term
v
    (\Term
_ Term
_ -> ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare equal") ((Term -> Term -> TCMT IO ()) -> TCMT IO ())
-> (Term -> Term -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    \Term
u Term
v -> do
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.term" Nat
15 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        [ TCMT IO Doc
"compareTerm (not syntactically equal)"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
u TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Comparison -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Comparison -> m Doc
prettyTCM Comparison
cmp TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ CompareAs -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => CompareAs -> m Doc
prettyTCM CompareAs
a
        ]
      -- If we are at type Size, we cannot short-cut comparison
      -- against metas by assignment.
      -- Andreas, 2014-04-12: this looks incomplete.
      -- It seems to assume we are never comparing
      -- at function types into Size.
      let fallback :: TCMT IO ()
fallback = Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAs' Comparison
cmp CompareAs
a Term
u Term
v
          unlessSubtyping :: TCM () -> TCM ()
          unlessSubtyping :: TCMT IO () -> TCMT IO ()
unlessSubtyping TCMT IO ()
cont =
              if Comparison
cmp Comparison -> Comparison -> Bool
forall a. Eq a => a -> a -> Bool
== Comparison
CmpEq then TCMT IO ()
cont else do
                -- Andreas, 2014-04-12 do not short cut if type is blocked.
                CompareAs
-> (Blocker -> CompareAs -> TCMT IO ())
-> (NotBlocked -> CompareAs -> TCMT IO ())
-> TCMT IO ()
forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked CompareAs
a (\ Blocker
_ CompareAs
_ -> TCMT IO ()
fallback) {-else-} ((NotBlocked -> CompareAs -> TCMT IO ()) -> TCMT IO ())
-> (NotBlocked -> CompareAs -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ NotBlocked
_ CompareAs
a -> do
                  -- do not short circuit size comparison!
                  TCMT IO (Maybe BoundedSize)
-> TCMT IO () -> (BoundedSize -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (CompareAs -> TCMT IO (Maybe BoundedSize)
forall a (m :: * -> *).
(IsSizeType a, HasOptions m, HasBuiltins m) =>
a -> m (Maybe BoundedSize)
forall (m :: * -> *).
(HasOptions m, HasBuiltins m) =>
CompareAs -> m (Maybe BoundedSize)
isSizeType CompareAs
a) TCMT IO ()
cont (\ BoundedSize
_ -> TCMT IO ()
fallback)

          dir :: CompareDirection
dir = Comparison -> CompareDirection
fromCmp Comparison
cmp
          rid :: CompareDirection
rid = CompareDirection -> CompareDirection
flipCmp CompareDirection
dir     -- The reverse direction.  Bad name, I know.
      case (Term
u, Term
v) of
        (MetaV MetaId
x [Elim]
us, MetaV MetaId
y [Elim]
vs)
          | MetaId
x MetaId -> MetaId -> Bool
forall a. Eq a => a -> a -> Bool
/= MetaId
y    -> TCMT IO () -> TCMT IO ()
unlessSubtyping (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO ()
solve1 TCMT IO () -> TCMT IO () -> TCMT IO ()
`orelse` TCMT IO ()
solve2 TCMT IO () -> TCMT IO () -> TCMT IO ()
`orelse` TCMT IO ()
fallback
          | Bool
otherwise -> TCMT IO ()
fallback
          where
            (TCMT IO ()
solve1, TCMT IO ()
solve2) | MetaId
x MetaId -> MetaId -> Bool
forall a. Ord a => a -> a -> Bool
> MetaId
y     = (CompareDirection -> MetaId -> [Elim] -> Term -> TCMT IO ()
assign CompareDirection
dir MetaId
x [Elim]
us Term
v, CompareDirection -> MetaId -> [Elim] -> Term -> TCMT IO ()
assign CompareDirection
rid MetaId
y [Elim]
vs Term
u)
                             | Bool
otherwise = (CompareDirection -> MetaId -> [Elim] -> Term -> TCMT IO ()
assign CompareDirection
rid MetaId
y [Elim]
vs Term
u, CompareDirection -> MetaId -> [Elim] -> Term -> TCMT IO ()
assign CompareDirection
dir MetaId
x [Elim]
us Term
v)
        (MetaV MetaId
x [Elim]
us, Term
_) -> TCMT IO () -> TCMT IO ()
unlessSubtyping (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ CompareDirection -> MetaId -> [Elim] -> Term -> TCMT IO ()
assign CompareDirection
dir MetaId
x [Elim]
us Term
v TCMT IO () -> TCMT IO () -> TCMT IO ()
`orelse` TCMT IO ()
fallback
        (Term
_, MetaV MetaId
y [Elim]
vs) -> TCMT IO () -> TCMT IO ()
unlessSubtyping (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ CompareDirection -> MetaId -> [Elim] -> Term -> TCMT IO ()
assign CompareDirection
rid MetaId
y [Elim]
vs Term
u TCMT IO () -> TCMT IO () -> TCMT IO ()
`orelse` TCMT IO ()
fallback
        (Def QName
f [Elim]
es, Def QName
f' [Elim]
es') | QName
f QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
f' -> do
          def <- QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
f
          opts <- pragmaOptions
          let shortcut = case Definition -> Defn
theDef Definition
def of
                Defn
_ | PragmaOptions -> Bool
optFirstOrder PragmaOptions
opts                       -> Bool
True
                d :: Defn
d@Function{}
                  | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PragmaOptions -> Bool
optRequireUniqueMetaSolutions PragmaOptions
opts -> Defn
d Defn -> Getting Bool Defn Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Defn Bool
Lens' Defn Bool
funFirstOrder
                Defn
_                                            -> Bool
False
          if not shortcut then fallback else unlessSubtyping $ do
          -- We do not shortcut projection-likes,
          -- Andreas, 2022-03-07, issue #5809:
          -- but irrelevant projections since they are applied to their parameters.
          -- Amy, 2023-01-04, issue #6415: and not
          -- prim^unglue/prim^unglueU either! removing the unglue from a
          -- transport/hcomp may cause an infinite loop.
          unglue  <- getName' builtin_unglue
          unglueU <- getName' builtin_unglueU
          let
            notFirstOrder = Maybe Projection -> Bool
forall a. Maybe a -> Bool
isJust (Definition -> Maybe Projection
isRelevantProjection_ Definition
def) Bool -> Bool -> Bool
|| QName -> Maybe QName
forall a. a -> Maybe a
Just QName
f Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
unglue Bool -> Bool -> Bool
|| QName -> Maybe QName
forall a. a -> Maybe a
Just QName
f Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
unglueU
          if notFirstOrder then fallback else do
          pol <- getPolarity' cmp f
          whenProfile Profile.Conversion $ tick "compare first-order shortcut"
          compareElims pol [] (defType def) (Def f []) es es' `orelse` fallback
        (Term, Term)
_               -> TCMT IO ()
fallback
  where
    assign :: CompareDirection -> MetaId -> Elims -> Term -> TCM ()
    assign :: CompareDirection -> MetaId -> [Elim] -> Term -> TCMT IO ()
assign CompareDirection
dir MetaId
x [Elim]
es Term
v = do
      -- Andreas, 2013-10-19 can only solve if no projections
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.term.shortcut" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ TCMT IO Doc
"attempting shortcut"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM (MetaId -> [Elim] -> Term
MetaV MetaId
x [Elim]
es) TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
":=" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v
        ]
      TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (MetaId -> TCMT IO Bool
forall a (m :: * -> *).
(IsInstantiatedMeta a, ReadTCState m) =>
a -> m Bool
forall (m :: * -> *). ReadTCState m => MetaId -> m Bool
isInstantiatedMeta MetaId
x) (Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
alwaysUnblock) -- Already instantiated, retry right away
      ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare meta shortcut"
      CompareDirection
-> MetaId
-> [Elim]
-> Term
-> CompareAs
-> (Term -> Term -> TCMT IO ())
-> TCMT IO ()
assignE CompareDirection
dir MetaId
x [Elim]
es Term
v CompareAs
a ((Term -> Term -> TCMT IO ()) -> TCMT IO ())
-> (Term -> Term -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ CompareDirection -> CompareAs -> Term -> Term -> TCMT IO ()
compareAsDir CompareDirection
dir CompareAs
a
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.term.shortcut" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"shortcut successful" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
$$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc
"result:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Term -> TCMT IO Doc) -> TCMT IO Term -> TCMT IO Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> TCMT IO Term
forall a (m :: * -> *). (Instantiate a, MonadReduce m) => a -> m a
instantiate (MetaId -> [Elim] -> Term
MetaV MetaId
x [Elim]
es)))
      ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare meta shortcut successful"
    -- Should be ok with catchError_ but catchError is much safer since we don't
    -- rethrow errors.
    orelse :: TCM () -> TCM () -> TCM ()
    orelse :: TCMT IO () -> TCMT IO () -> TCMT IO ()
orelse TCMT IO ()
m TCMT IO ()
h = TCMT IO () -> (TCErr -> TCMT IO ()) -> TCMT IO ()
forall a. TCMT IO a -> (TCErr -> TCMT IO a) -> TCMT IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError TCMT IO ()
m (\TCErr
_ -> TCMT IO ()
h)

-- | Try to assign meta.  If meta is projected, try to eta-expand
--   and run conversion check again.
assignE :: CompareDirection -> MetaId -> Elims -> Term -> CompareAs
        -> (Term -> Term -> TCM ()) -> TCM ()
assignE :: CompareDirection
-> MetaId
-> [Elim]
-> Term
-> CompareAs
-> (Term -> Term -> TCMT IO ())
-> TCMT IO ()
assignE CompareDirection
dir MetaId
x [Elim]
es Term
v CompareAs
a Term -> Term -> TCMT IO ()
comp = do
  ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare meta"
  case [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es of
    Just [Arg Term]
vs -> CompareDirection
-> MetaId -> [Arg Term] -> Term -> CompareAs -> TCMT IO ()
forall (m :: * -> *).
MonadMetaSolver m =>
CompareDirection
-> MetaId -> [Arg Term] -> Term -> CompareAs -> m ()
assignV CompareDirection
dir MetaId
x [Arg Term]
vs Term
v CompareAs
a
    Maybe [Arg Term]
Nothing -> do
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.assign" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ TCMT IO Doc
"assigning to projected meta "
        , MetaId -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => MetaId -> m Doc
prettyTCM MetaId
x TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep ((Elim -> TCMT IO Doc) -> [Elim] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map' Elim -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Elim -> m Doc
prettyTCM [Elim]
es) TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CompareDirection -> [Char]
forall a. Show a => a -> [Char]
show CompareDirection
dir) TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v
        ]
      [MetaClass] -> MetaId -> TCMT IO ()
forall (m :: * -> *).
MonadMetaSolver m =>
[MetaClass] -> MetaId -> m ()
etaExpandMeta [MetaClass
Records] MetaId
x
      res <- MetaId -> TCMT IO (Maybe Term)
forall (m :: * -> *). ReadTCState m => MetaId -> m (Maybe Term)
isInstantiatedMeta' MetaId
x
      case res of
        Just Term
u  -> do
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.assign" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
            [ TCMT IO Doc
"seems like eta expansion instantiated meta "
            , MetaId -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => MetaId -> m Doc
prettyTCM MetaId
x TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text  ([Char]
":" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ CompareDirection -> [Char]
forall a. Show a => a -> [Char]
show CompareDirection
dir) TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
u
            ]
          let w :: Term
w = Term
u Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [Elim]
es
          Term -> Term -> TCMT IO ()
comp Term
w Term
v
        Maybe Term
Nothing ->  do
          [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.assign" Nat
30 [Char]
"eta expansion did not instantiate meta"
          Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation (Blocker -> TCMT IO ()) -> Blocker -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ MetaId -> Blocker
unblockOnMeta MetaId
x -- nothing happened, give up

compareAsDir :: CompareDirection -> CompareAs -> Term -> Term -> TCM ()
compareAsDir :: CompareDirection -> CompareAs -> Term -> Term -> TCMT IO ()
compareAsDir !CompareDirection
dir !CompareAs
a = (Comparison -> Term -> Term -> TCMT IO ())
-> CompareDirection -> Term -> Term -> TCMT IO ()
forall a c.
(Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c
dirToCmp (Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
`compareAs'` CompareAs
a) CompareDirection
dir

compareAs' :: Comparison -> CompareAs -> Term -> Term -> TCM ()
compareAs' :: Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAs' !Comparison
cmp !CompareAs
tt !Term
m !Term
n = case CompareAs
tt of
  AsTermsOf Type'' Term Term
a -> Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTerm' Comparison
cmp Type'' Term Term
a Term
m Term
n
  CompareAs
AsSizes     -> Comparison -> Term -> Term -> TCMT IO ()
compareSizes Comparison
cmp Term
m Term
n
  CompareAs
AsTypes     -> Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAtom Comparison
cmp CompareAs
AsTypes Term
m Term
n

compareTerm' :: Comparison -> Type -> Term -> Term -> TCM ()
compareTerm' :: Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTerm' !Comparison
cmp !Type'' Term Term
a !Term
m !Term
n =
  [Char] -> Nat -> [Char] -> TCMT IO () -> TCMT IO ()
forall a. [Char] -> Nat -> [Char] -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Nat -> [Char] -> m a -> m a
verboseBracket [Char]
"tc.conv.term" Nat
20 [Char]
"compareTerm" (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
  (ba, a') <- Type'' Term Term -> TCMT IO (Blocker, Type'' Term Term)
forall a (m :: * -> *).
(Reduce a, IsMeta a, MonadReduce m) =>
a -> m (Blocker, a)
reduceWithBlocker Type'' Term Term
a
  (catchConstraint (ValueCmp cmp (AsTermsOf a') m n) :: TCM () -> TCM ()) $ blockOnError ba $ do
    reportSDoc "tc.conv.term" 30 $ fsep
      [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a' ]
    propIrr  <- isPropEnabled
    isSize   <- isJust <$> isSizeType a'
    (bs, s)  <- reduceWithBlocker $ getSort a'
    mlvl     <- getBuiltin' builtinLevel
    reportSDoc "tc.conv.term" 40 $ fsep
      [ "compareTerm", prettyTCM m, prettyTCM cmp, prettyTCM n, ":", prettyTCM a'
      , "at sort", prettyTCM s]
    reportSDoc "tc.conv.level" 60 $ nest 2 $ sep
      [ "a'   =" <+> pretty a'
      , "mlvl =" <+> pretty mlvl
      , text $ "(Just (unEl a') == mlvl) = " ++ show (Just (unEl a') == mlvl)
      ]
    blockOnError bs $
      expand \TCMT IO () -> Result (TCMT IO ())
ret -> case Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
a' of
        Term
_ | Bool
propIrr
          , Sort' Term -> Bool
forall t. Sort' t -> Bool
isProp Sort' Term
s  -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ Type'' Term Term -> Term -> Term -> TCMT IO ()
compareIrrelevant Type'' Term Term
a' Term
m Term
n
        Term
_ | Bool
isSize    -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ Comparison -> Term -> Term -> TCMT IO ()
compareSizes Comparison
cmp Term
m Term
n
        Term
a | Term -> Maybe Term
forall a. a -> Maybe a
Just Term
a Maybe Term -> Maybe Term -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Term
mlvl -> TCMT IO () -> Result (TCMT IO ())
ret do
          a <- Term -> TCMT IO (Level' Term)
forall (m :: * -> *). PureTCM m => Term -> m (Level' Term)
levelView Term
m
          b <- levelView n
          nowConversionChecking cmp (Level a) (Level b) (AsTermsOf a') $
            equalLevel a b
        a :: Term
a@Pi{}    -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Term -> Term -> Term -> TCMT IO ()
equalFun Sort' Term
s Term
a Term
m Term
n
        Lam ArgInfo
_ Abs Term
_   -> TCMT IO () -> Result (TCMT IO ())
ret do
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.term.sort" Nat
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep
            [ TCMT IO Doc
"compareTerm", Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
m, Comparison -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Comparison -> m Doc
prettyTCM Comparison
cmp, Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
n, TCMT IO Doc
":", Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
a'
            , TCMT IO Doc
"at sort", Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s
            ]
          TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
        Def QName
r [Elim]
es  -> TCMT IO () -> Result (TCMT IO ())
ret do
          isrec <- QName -> TCMT IO Bool
forall (m :: * -> *).
(HasCallStack, HasConstInfo m) =>
QName -> m Bool
isEtaRecord QName
r
          expand \TCMT IO () -> Result (TCMT IO ())
ret -> if Bool
isrec
            then TCMT IO () -> Result (TCMT IO ())
ret do
              ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare at eta record"
              sig <- TCMT IO Signature
forall (m :: * -> *). ReadTCState m => m Signature
getSignature

              transp <- getPrimitiveName' builtinTrans
              hcomp <- getPrimitiveName' builtinHComp

              let
                ps = [Elim] -> [Arg Term]
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims [Elim]
es
                -- Andreas, 2010-10-11: allowing neutrals to be blocked things does not seem
                -- to change Agda's behavior
                --    isNeutral Blocked{}          = False
                isNeutral (NotBlocked NotBlocked' t
_ Con{}) = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

                -- Andreas, 2013-09-18 / 2015-06-29: a Def by copatterns is
                -- not neutral if it is blocked (there can be missing projections
                -- to trigger a reduction.
                isNeutral (NotBlocked NotBlocked' t
r (Def QName
q [Elim]
_)) = do    -- Andreas, 2014-12-06 optimize this using r !!
                  Bool -> Bool
not (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> m Bool
forall (m :: * -> *). HasConstInfo m => QName -> m Bool
usesCopatterns QName
q -- a def by copattern can reduce if projected
                isNeutral (NotBlocked NotBlocked' t
r (Var Nat
i [Elim]
_)) = do
                  -- Local rewrite rules can also make a variable applications
                  -- reduce if projected
                  Bool -> Bool
not (Bool -> Bool) -> m Bool -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> RewriteHead -> m Bool
forall (m :: * -> *). HasConstInfo m => RewriteHead -> m Bool
rewUsesCopatterns (Nat -> RewriteHead
RewVarHead Nat
i)
                isNeutral Blocked' t Term
_                   = Bool -> m Bool
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

                -- Amy, 2024-01-29: Is this blocked application headed by one of the
                -- cubical primitives that behave as though they are copattern matching?
                isCubicalPrimHead (NotBlocked NotBlocked
r (Def QName
q [Elim]
_)) -- Amy, 2024-01-29: optimise this using r !!
                  | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
transp Bool -> Bool -> Bool
|| QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
hcomp
                  = QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q
                isCubicalPrimHead Blocked Term
_ = Maybe QName
forall a. Maybe a
Nothing

                isMeta Blocked' t Term
b = case Blocked' t Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' t Term
b of
                  MetaV{} -> Bool
True
                  Term
_       -> Bool
False

              reportSDoc "tc.conv.term" 30 $ prettyTCM a <+> "is eta record type"
              m <- reduceB m
              mNeutral <- isNeutral m
              n <- reduceB n
              nNeutral <- isNeutral n

              let
                h1 = Blocked Term -> Maybe QName
isCubicalPrimHead Blocked Term
m
                h2 = Blocked Term -> Maybe QName
isCubicalPrimHead Blocked Term
n

                mCub = Maybe QName -> Bool
forall a. Maybe a -> Bool
isJust (Blocked Term -> Maybe QName
isCubicalPrimHead Blocked Term
m)
                nCub = Maybe QName -> Bool
forall a. Maybe a -> Bool
isJust (Blocked Term -> Maybe QName
isCubicalPrimHead Blocked Term
n)

                 -- Amy, 2024-01-29 (fixing issue pointed out by Tom Jack):
                 --
                 -- Cubical primitives reduce to something awful, so we would like to skip comparing them (causes
                 -- "timeout" in GroupPath).
                 --
                 -- We would also like to skip comparing a cubical primitive against something that is *small* and
                 -- actually neutral (causes "timeout" in KleinBottle cohomology groups, comparing a 93KiB(!) transport
                 -- against an application of set-truncation recursion to a metavariable)
                 --
                 -- The conditions for skipping eta expansion are thus:
                 --
                 --   (n)  both are neutrals (which in this case also includes a "suspended"/copattern transp/hcomp); and
                 --
                 --   (c1) if both are headed by a cubical primitive, then they are the same primitive; or
                 --
                 --   (New! 2025-07-23:)
                 --   (c2) if one side is a cubical primitive, then the other side must be actually *blocked*
                 --        This prevents us from not noticing things like transport (λ i → Nat × Nat) x ≡ x
                 --        (transport on Σ is "defined by copatterns" so both sides are "neutral",
                 --         but the transport is a pair that contains x .fst and x .snd!)
                 --
                 -- So we will skip expanding transp A φ u0 = transp A' φ' u0', since it's definitionally injective;
                 -- We will skip expanding transp A φ u0 = f ?, since it's wasted work; but we will not skip
                 -- transp A φ u0 = hcomp u u0', since those must both compute if they are to be equal.
                cubSkipOk
                  | Bool
mCub Bool -> Bool -> Bool
&& Bool
nCub         = Maybe QName
h1 Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
h2
                  | Bool
mCub, Blocked{} <- Blocked Term
n = Bool
True
                  | Blocked{} <- Blocked Term
m, Bool
nCub = Bool
True
                  | Bool
otherwise            = Bool
mCub Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool
nCub

              when (mCub || nCub) $
                reportSDoc "tc.conv.term.cubical" 30 $ vcat
                  [ ("m (" <> prettyTCM mNeutral <> ", " <> prettyTCM mCub <> ", " <> prettyTCM h1 <> "):")
                  , nest 2 (prettyTCM m)
                  , ("n (" <> prettyTCM nNeutral <> ", " <> prettyTCM nCub <> ", " <> prettyTCM h2 <> "):")
                  , nest 2 (prettyTCM n)
                  , "at type"
                  , nest 2 (prettyTCM a')
                  , "same head:" <+> prettyTCM (h1 == h2)
                  , "skipping:" <+> prettyTCM cubSkipOk
                  ]

              if | isMeta m || isMeta n -> do
                     whenProfile Profile.Conversion $ tick "compare at eta-record: meta"
                     compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)

                 | mNeutral && nNeutral && cubSkipOk -> do
                     whenProfile Profile.Conversion $ tick "compare at eta-record: both neutral"
                     -- Andreas 2011-03-23: (fixing issue 396)
                     -- if we are dealing with a singleton record,
                     -- we can succeed immediately
                     let profUnitEta = ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare at eta-record: both neutral at unit"
                     ifM (isSingletonRecordModuloRelevance r ps) profUnitEta $ do
                       -- do not eta-expand if comparing two neutrals
                       compareAtom cmp (AsTermsOf a') (ignoreBlocking m) (ignoreBlocking n)

                 | otherwise -> do
                    whenProfile Profile.Conversion $ tick "compare at eta-record: eta-expanding"
                    (tel, m') <- etaExpandRecord r ps $ ignoreBlocking m
                    (_  , n') <- etaExpandRecord r ps $ ignoreBlocking n
                    -- No subtyping on record terms
                    c <- getRecordConstructor r
                    -- Record constructors are covariant (see test/succeed/CovariantConstructors).
                    compareArgs (repeat $ polFromCmp cmp) []
                      (telePi_ tel (raise (size tel) a'))
                      (Con c ConOSystem [])
                      m' n'

            else TCMT IO () -> Result (TCMT IO ())
ret do pathview <- Type'' Term Term -> TCMT IO PathView
forall (m :: * -> *).
HasBuiltins m =>
Type'' Term Term -> m PathView
pathView Type'' Term Term
a'
                        equalPath pathview a' m n
        Term
_ -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAtom Comparison
cmp (Type'' Term Term -> CompareAs
AsTermsOf Type'' Term Term
a') Term
m Term
n
  where
    -- equality at function type (accounts for eta)
    equalFun :: Sort -> Term -> Term -> Term -> TCM ()
    equalFun :: Sort' Term -> Term -> Term -> Term -> TCMT IO ()
equalFun Sort' Term
s a :: Term
a@(Pi Dom' Term (Type'' Term Term)
dom Abs (Type'' Term Term)
b) Term
m Term
n | Dom' Term (Type'' Term Term) -> Bool
forall t e. Dom' t e -> Bool
domIsFinite Dom' Term (Type'' Term Term)
dom = do
       !mp <- (Term -> QName) -> Maybe Term -> Maybe QName
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> QName
getPrimName (Maybe Term -> Maybe QName)
-> TCMT IO (Maybe Term) -> TCMT IO (Maybe QName)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuiltinId -> TCMT IO (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
builtinIsOne
       let dom' = ASetter
  (Dom' Term (Type'' Term Term))
  (Dom' Term (Type'' Term Term))
  Bool
  Bool
-> Bool
-> Dom' Term (Type'' Term Term)
-> Dom' Term (Type'' Term Term)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Dom' Term (Type'' Term Term))
  (Dom' Term (Type'' Term Term))
  Bool
  Bool
forall t e (f :: * -> *).
Functor f =>
(Bool -> f Bool) -> Dom' t e -> f (Dom' t e)
dIsFinite Bool
False Dom' Term (Type'' Term Term)
dom
       let asFn = Sort' Term -> Term -> Type'' Term Term
forall t a. Sort' t -> a -> Type'' t a
El Sort' Term
s (Dom' Term (Type'' Term Term) -> Abs (Type'' Term Term) -> Term
Pi Dom' Term (Type'' Term Term)
dom' Abs (Type'' Term Term)
b)
       case unEl $ unDom dom of
          Def QName
q [Apply Arg Term
phi]
              | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mp -> Comparison
-> Term -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTermOnFace Comparison
cmp (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
phi) Type'' Term Term
asFn Term
m Term
n
          Term
_                  -> Sort' Term -> Term -> Term -> Term -> TCMT IO ()
equalFun Sort' Term
s (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
asFn) Term
m Term
n

    equalFun Sort' Term
_ (Pi dom :: Dom' Term (Type'' Term Term)
dom@(Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
-> Dom' Term (Type'' Term Term) -> ArgInfo
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo -> ArgInfo
info) Abs (Type'' Term Term)
b) (Lam ArgInfo
_ Abs Term
m) (Lam ArgInfo
_ Abs Term
n) = do
      ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare at function type"
      let name :: [Char]
name = [Suggestion] -> [Char]
suggests [ Abs (Type'' Term Term) -> Suggestion
forall a. Suggest a => a -> Suggestion
Suggestion Abs (Type'' Term Term)
b , Abs Term -> Suggestion
forall a. Suggest a => a -> Suggestion
Suggestion Abs Term
m , Abs Term -> Suggestion
forall a. Suggest a => a -> Suggestion
Suggestion Abs Term
n ]
      (ConversionZipper -> ConversionZipper) -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCError m =>
(ConversionZipper -> ConversionZipper) -> m a -> m a
addConversionContext (Dom' Term (Type'' Term Term)
-> Abs () -> [Char] -> ConversionZipper -> ConversionZipper
ConvLam Dom' Term (Type'' Term Term)
dom (Abs (Type'' Term Term) -> Abs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Abs (Type'' Term Term)
b) [Char]
name)
        (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ([Char], Dom' Term (Type'' Term Term)) -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
([Char], Dom' Term (Type'' Term Term)) -> m a -> m a
addContext ([Char]
name, Dom' Term (Type'' Term Term)
dom)
        (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTerm Comparison
cmp (Abs (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> a
absBody Abs (Type'' Term Term)
b) (Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
m) (Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
n)

    equalFun Sort' Term
_ (Pi dom :: Dom' Term (Type'' Term Term)
dom@(Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
-> Dom' Term (Type'' Term Term) -> ArgInfo
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo -> ArgInfo
info) Abs (Type'' Term Term)
b) Term
m Term
n = do
      ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare at function type"
      let
        (Term
m', Term
n') = let !v :: Term
v = Nat -> Term
var Nat
0 in Nat -> (Term, Term) -> (Term, Term)
forall a. Subst a => Nat -> a -> a
raise Nat
1 (Term
m,Term
n) (Term, Term) -> [Arg Term] -> (Term, Term)
forall t. Apply t => t -> [Arg Term] -> t
`apply` [ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info Term
v]
        name :: [Char]
name     = [Suggestion] -> [Char]
suggests [ Abs (Type'' Term Term) -> Suggestion
forall a. Suggest a => a -> Suggestion
Suggestion Abs (Type'' Term Term)
b , Term -> Suggestion
forall a. Suggest a => a -> Suggestion
Suggestion Term
m , Term -> Suggestion
forall a. Suggest a => a -> Suggestion
Suggestion Term
n ]
      (ConversionZipper -> ConversionZipper) -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCError m =>
(ConversionZipper -> ConversionZipper) -> m a -> m a
addConversionContext (Dom' Term (Type'' Term Term)
-> Abs () -> [Char] -> ConversionZipper -> ConversionZipper
ConvLam Dom' Term (Type'' Term Term)
dom (Abs (Type'' Term Term) -> Abs ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Abs (Type'' Term Term)
b) [Char]
name)
        (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ([Char], Dom' Term (Type'' Term Term)) -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
([Char], Dom' Term (Type'' Term Term)) -> m a -> m a
addContext ([Char]
name, Dom' Term (Type'' Term Term)
dom)
        (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTerm Comparison
cmp (Abs (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> a
absBody Abs (Type'' Term Term)
b) Term
m' Term
n'

    equalFun Sort' Term
_ Term
_ Term
_ Term
_ = TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__

    equalPath :: PathView -> Type -> Term -> Term -> TCM ()
    equalPath :: PathView -> Type'' Term Term -> Term -> Term -> TCMT IO ()
equalPath (PathType Sort' Term
s QName
_ Arg Term
l Arg Term
a Arg Term
x Arg Term
y) Type'' Term Term
_ Term
m Term
n = do
      ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare at path type"
      interval <- TCMT IO Term -> TCMT IO (Type'' Term Term)
forall (m :: * -> *). Functor m => m Term -> m (Type'' Term Term)
el TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primInterval
      let
        (m', n') = raise 1 (m, n) `applyE` [IApply (raise 1 $ unArg x) (raise 1 $ unArg y) (var 0)]
        name     = [Char]
"i" :: String
      addContext (name, defaultDom interval) $ cutConversionErrors $
        compareTerm cmp (El (raise 1 s) $ raise 1 (unArg a) `apply` [argN $ var 0]) m' n'
    equalPath OType{} Type'' Term Term
a' Term
m Term
n = Type'' Term Term -> Term -> Term -> TCMT IO ()
cmpDef Type'' Term Term
a' Term
m Term
n

    cmpDef :: Type'' Term Term -> Term -> Term -> TCMT IO ()
cmpDef a' :: Type'' Term Term
a'@(El Sort' Term
s Term
ty) Term
m Term
n = do
      mI     <- BuiltinId -> TCMT IO (Maybe QName)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe QName)
getBuiltinName'   BuiltinId
builtinInterval
      mIsOne <- getBuiltinName'   builtinIsOne
      mGlue  <- getPrimitiveName' builtinGlue
      mHComp <- getPrimitiveName' builtinHComp
      mSub   <- getBuiltinName' builtinSub
      mUnglueU <- getPrimitiveTerm' builtin_unglueU
      mSubIn   <- getBuiltin' builtinSubIn
      case ty of
        Def QName
q [Elim]
es | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mIsOne -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Def QName
q [Elim]
es | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mGlue, Just args :: [Arg Term]
args@(Arg Term
l:Arg Term
_:Arg Term
a:Arg Term
phi:[Arg Term]
_) <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es -> do
          aty <- TCMT IO Term -> TCMT IO Term -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> m (Type'' Term Term)
el' (Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
l) (Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a)
          unglue <- prim_unglue
          let mkUnglue Term
m = Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
unglue ([Arg Term] -> Term) -> [Arg Term] -> Term
forall a b. (a -> b) -> a -> b
$ ((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map' (Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) [Arg Term]
args) [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++! [Term -> Arg Term
forall e. e -> Arg e
argN Term
m]
          reportSDoc "conv.glue" 20 $ prettyTCM (aty,mkUnglue m,mkUnglue n)

          -- Amy, 2023-01-04: Here and in hcompu below we *used to*
          -- also compare whatever the glued terms would evaluate to
          -- on φ. This is very loopy (consider φ = f i or φ = i0:
          -- both generate empty substitutions so get us back to
          -- exactly the same conversion problem)!
          --
          -- But is there a reason to do this comparison? The
          -- answer, it turns out, is no!
          --
          -- Suppose you had
          --    Γ ⊢ x = glue [φ → t] xb : Glue T S
          --    Γ ⊢ y = glue [φ → s] yb : Glue T S
          --    Γ ⊢ xb = yb : T
          -- Is there a need to check whether Γ φ ⊢ t = s : S? No!
          -- That's because the typing rule for glue is something like
          --   glue φ : (s : PartialP φ S) (t : T [ φ → s ]) → Glue T S
          -- where the bracket notation stands for an "implicit
          -- Sub"-type, i.e. Γ, φ ⊢ t = s (definitionally)
          --
          -- So if we have a glued element, and we have xb = yb, we
          -- can be sure that
          --   Γ , φ ⊢ t = xb = yb = s
          --
          -- But what about the general case, where we're not
          -- looking at a literal glue? Well, eta for Glue
          -- means x = glue [φ → x] (unglue x), so the logic above
          -- still applies. On φ, for the reducts to agree, it's
          -- enough for the bases to agree.

          compareTerm cmp aty (mkUnglue m) (mkUnglue n)

        Def QName
q [Elim]
es
          | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mHComp, Just (Arg Term
sl:Arg Term
s:args :: [Arg Term]
args@[Arg Term
phi,Arg Term
u,Arg Term
u0]) <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es
          , Sort (Type Level' Term
lvl) <- Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
s
          , Just Term
unglueU <- Maybe Term
mUnglueU, Just Term
subIn <- Maybe Term
mSubIn -> do
          let l :: Term
l = Level' Term -> Term
Level Level' Term
lvl
          ty <- TCMT IO Term -> TCMT IO Term -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> m (Type'' Term Term)
el' (Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Term
l) (Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0)
          let bA = Term
subIn Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Arg Term
sl,Arg Term
s,Arg Term
phi,Arg Term
u0]
          let mkUnglue Term
m = Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
unglueU ([Arg Term] -> Term) -> [Arg Term] -> Term
forall a b. (a -> b) -> a -> b
$! [Term -> Arg Term
forall e. e -> Arg e
argH Term
l] [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++! (Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map' (Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) [Arg Term
phi,Arg Term
u] [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++! [Term -> Arg Term
forall e. e -> Arg e
argH Term
bA,Term -> Arg Term
forall e. e -> Arg e
argN Term
m]
          reportSDoc "conv.hcompU" 20 $ prettyTCM (ty,mkUnglue m,mkUnglue n)
          compareTerm cmp ty (mkUnglue m) (mkUnglue n)

        Def QName
q [Elim]
es | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mSub, Just args :: [Arg Term]
args@(Arg Term
l:Arg Term
a:[Arg Term]
_) <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es -> do
          ty <- TCMT IO Term -> TCMT IO Term -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> m (Type'' Term Term)
el' (Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
l) (Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a)
          out <- primSubOut
          let mkOut Term
m = Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
out ([Arg Term] -> Term) -> [Arg Term] -> Term
forall a b. (a -> b) -> a -> b
$! (Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map' (Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) [Arg Term]
args [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++! [Term -> Arg Term
forall e. e -> Arg e
argN Term
m]
          compareTerm cmp ty (mkOut m) (mkOut n)

        Def QName
q [] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mI -> Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareInterval Comparison
cmp Type'' Term Term
a' Term
m Term
n
        Term
_ -> Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAtom Comparison
cmp (Type'' Term Term -> CompareAs
AsTermsOf Type'' Term Term
a') Term
m Term
n

compareAtomDir :: CompareDirection -> CompareAs -> Term -> Term -> TCM ()
compareAtomDir :: CompareDirection -> CompareAs -> Term -> Term -> TCMT IO ()
compareAtomDir CompareDirection
dir CompareAs
a = (Comparison -> Term -> Term -> TCMT IO ())
-> CompareDirection -> Term -> Term -> TCMT IO ()
forall a c.
(Comparison -> a -> a -> c) -> CompareDirection -> a -> a -> c
dirToCmp (Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
`compareAtom` CompareAs
a) CompareDirection
dir

-- | Compute the head type of an elimination. For projection-like functions
--   this requires inferring the type of the principal argument.
computeElimHeadType :: QName -> Elims -> Elims -> TCM Type
computeElimHeadType :: QName -> [Elim] -> [Elim] -> TCMT IO (Type'' Term Term)
computeElimHeadType QName
f [] [Elim]
es' = QName -> [Elim] -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(PureTCM m, MonadBlock m) =>
QName -> [Elim] -> m (Type'' Term Term)
computeDefType QName
f [Elim]
es'
computeElimHeadType QName
f [Elim]
es [Elim]
_   = QName -> [Elim] -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(PureTCM m, MonadBlock m) =>
QName -> [Elim] -> m (Type'' Term Term)
computeDefType QName
f [Elim]
es

-- | Compute the type of a rewrite rule head. For projection-like
--   functions, this requires inferring the type of the principal argument,
--   using the eliminations.
computeRewHeadType ::
     Int          -- Size of the "rewrite rule telescope"
  -> RewriteHead  -- Rewrite rule head we want to compute the type of
  -> Elims        -- Eliminations
  -> Elims        -- Alternative eliminations, used if the first is empty
  -> TCM Type
computeRewHeadType :: Nat
-> RewriteHead -> [Elim] -> [Elim] -> TCMT IO (Type'' Term Term)
computeRewHeadType !Nat
telSize (RewDefHead QName
f) ![Elim]
es ![Elim]
es' = QName -> [Elim] -> [Elim] -> TCMT IO (Type'' Term Term)
computeElimHeadType QName
f [Elim]
es [Elim]
es'
computeRewHeadType  Nat
telSize (RewVarHead Nat
x)  [Elim]
es  [Elim]
es' = Nat -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(MonadDebug m, MonadTCEnv m) =>
Nat -> m (Type'' Term Term)
typeOfBV (Nat -> TCMT IO (Type'' Term Term))
-> Nat -> TCMT IO (Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ Nat
x Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
telSize

-- | Syntax directed equality on atomic values
--
compareAtom :: Comparison -> CompareAs -> Term -> Term -> TCM ()
compareAtom :: Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAtom Comparison
cmp CompareAs
t Term
m Term
n =
  [Char] -> Nat -> [Char] -> TCMT IO () -> TCMT IO ()
forall a. [Char] -> Nat -> [Char] -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Nat -> [Char] -> m a -> m a
verboseBracket [Char]
"tc.conv.atom" Nat
20 [Char]
"compareAtom" (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
  -- if a PatternErr is thrown, rebuild constraint!
  (Constraint -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *).
MonadConstraint m =>
Constraint -> m () -> m ()
catchConstraint (Comparison -> CompareAs -> Term -> Term -> Constraint
ValueCmp Comparison
cmp CompareAs
t Term
m Term
n) :: TCM () -> TCM ()) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.atom.size" Nat
50 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"compareAtom term size:  " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ (Nat, Nat) -> [Char]
forall a. Show a => a -> [Char]
show (Term -> Nat
forall a. TermSize a => a -> Nat
termSize Term
m, Term -> Nat
forall a. TermSize a => a -> Nat
termSize Term
n)
    [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.atom" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
      TCMT IO Doc
"compareAtom" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
m TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Comparison -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Comparison -> m Doc
prettyTCM Comparison
cmp
                             , Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
n
                             , CompareAs -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => CompareAs -> m Doc
prettyTCM CompareAs
t
                             ]
    ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare by reduction"
    -- Are we currently defining mutual functions? Which?
    currentMutuals <-
      TCMT IO (Set QName)
-> (MutualId -> TCMT IO (Set QName))
-> Maybe MutualId
-> TCMT IO (Set QName)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Set QName -> TCMT IO (Set QName)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Set QName
forall a. Set a
Set.empty) (MutualBlock -> Set QName
mutualNames (MutualBlock -> Set QName)
-> (MutualId -> TCMT IO MutualBlock)
-> MutualId
-> TCMT IO (Set QName)
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> MutualId -> TCMT IO MutualBlock
forall (tcm :: * -> *).
ReadTCState tcm =>
MutualId -> tcm MutualBlock
lookupMutualBlock) (Maybe MutualId -> TCMT IO (Set QName))
-> TCMT IO (Maybe MutualId) -> TCMT IO (Set QName)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Lens' TCEnv (Maybe MutualId) -> TCMT IO (Maybe MutualId)
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (Maybe MutualId -> f (Maybe MutualId)) -> TCEnv -> f TCEnv
Lens' TCEnv (Maybe MutualId)
eMutualBlock

    -- Andreas: what happens if I cut out the eta expansion here?
    -- Answer: Triggers issue 245, does not resolve 348
    mb' <- etaExpandBlocked =<< reduceB m
    nb' <- etaExpandBlocked =<< reduceB n

    let blocker = Blocker -> Blocker -> Blocker
unblockOnEither (Blocked Term -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked Term
mb') (Blocked Term -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked Term
nb')
    reportSLn "tc.conv.atom.size" 50 $ "term size after reduce: " ++ show (termSize $ ignoreBlocking mb', termSize $ ignoreBlocking nb')

    -- constructorForm changes literal to constructors
    -- only needed if the other side is not a literal
    (mb'', nb'') <- expand \TCMT IO (Blocked Term, Blocked Term)
-> Result (TCMT IO (Blocked Term, Blocked Term))
ret -> case (Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
mb', Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
nb') of
      (Lit Literal
_, Lit Literal
_) -> TCMT IO (Blocked Term, Blocked Term)
-> Result (TCMT IO (Blocked Term, Blocked Term))
ret (TCMT IO (Blocked Term, Blocked Term)
 -> Result (TCMT IO (Blocked Term, Blocked Term)))
-> TCMT IO (Blocked Term, Blocked Term)
-> Result (TCMT IO (Blocked Term, Blocked Term))
forall a b. (a -> b) -> a -> b
$ (Blocked Term, Blocked Term)
-> TCMT IO (Blocked Term, Blocked Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked Term
mb', Blocked Term
nb')
      (Term, Term)
_ -> TCMT IO (Blocked Term, Blocked Term)
-> Result (TCMT IO (Blocked Term, Blocked Term))
ret (TCMT IO (Blocked Term, Blocked Term)
 -> Result (TCMT IO (Blocked Term, Blocked Term)))
-> TCMT IO (Blocked Term, Blocked Term)
-> Result (TCMT IO (Blocked Term, Blocked Term))
forall a b. (a -> b) -> a -> b
$ (,) (Blocked Term -> Blocked Term -> (Blocked Term, Blocked Term))
-> TCMT IO (Blocked Term)
-> TCMT IO (Blocked Term -> (Blocked Term, Blocked Term))
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Term -> TCMT IO Term) -> Blocked Term -> TCMT IO (Blocked Term)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Blocked' Term a -> f (Blocked' Term b)
traverse Term -> TCMT IO Term
forall (m :: * -> *). HasBuiltins m => Term -> m Term
constructorForm Blocked Term
mb'
                     TCMT IO (Blocked Term -> (Blocked Term, Blocked Term))
-> TCMT IO (Blocked Term) -> TCMT IO (Blocked Term, Blocked Term)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> (Term -> TCMT IO Term) -> Blocked Term -> TCMT IO (Blocked Term)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Blocked' Term a -> f (Blocked' Term b)
traverse Term -> TCMT IO Term
forall (m :: * -> *). HasBuiltins m => Term -> m Term
constructorForm Blocked Term
nb'

    mb <- traverse unLevel mb''
    nb <- traverse unLevel nb''

    cmpBlocked <- viewTC eCompareBlocked

    let m = Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
mb
        n = Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
nb

        checkDefinitionalEquality = TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Comparison -> CompareAs -> Term -> Term -> TCMT IO Bool
pureCompareAs Comparison
CmpEq CompareAs
t Term
m Term
n) TCMT IO ()
notEqual

        notEqual = Comparison -> Term -> Term -> CompareAs -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCError m, HasBuiltins m) =>
Comparison -> Term -> Term -> CompareAs -> m a
failConversion Comparison
cmp Term
m Term
n CompareAs
t

        dir = Comparison -> CompareDirection
fromCmp Comparison
cmp
        rid = CompareDirection -> CompareDirection
flipCmp CompareDirection
dir     -- The reverse direction.  Bad name, I know.

        assign CompareDirection
dir MetaId
x [Elim]
es Term
v = CompareDirection
-> MetaId
-> [Elim]
-> Term
-> CompareAs
-> (Term -> Term -> TCMT IO ())
-> TCMT IO ()
assignE CompareDirection
dir MetaId
x [Elim]
es Term
v CompareAs
t ((Term -> Term -> TCMT IO ()) -> TCMT IO ())
-> (Term -> Term -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ CompareDirection -> CompareAs -> Term -> Term -> TCMT IO ()
compareAsDir CompareDirection
dir CompareAs
t

    reportSDoc "tc.conv.atom" 30 $
      "compareAtom" <+> fsep [ prettyTCM mb <+> prettyTCM cmp
                             , prettyTCM nb
                             , prettyTCM t
                             , prettyTCM blocker
                             ]
    reportSDoc "tc.conv.atom" 80 $
      "compareAtom" <+> fsep [ pretty mb <+> prettyTCM cmp
                                  , pretty nb
                                  , ":" <+> pretty t ]
    expand \TCMT IO () -> Result (TCMT IO ())
ret -> case (Blocked Term
mb, Blocked Term
nb) of
      -- equate two metas x and y.  if y is the younger meta,
      -- try first y := x and then x := y
      (Blocked Term, Blocked Term)
_ | MetaV MetaId
x [Elim]
xArgs <- Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
mb,   -- Can be either Blocked or NotBlocked depending on
          MetaV MetaId
y [Elim]
yArgs <- Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
nb -> -- envCompareBlocked check above.
        TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ Comparison
-> CompareAs -> MetaId -> [Elim] -> MetaId -> [Elim] -> TCMT IO ()
compareMetas Comparison
cmp CompareAs
t MetaId
x [Elim]
xArgs MetaId
y [Elim]
yArgs

      -- one side a meta
      (Blocked Term, Blocked Term)
_ | MetaV MetaId
x [Elim]
es <- Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
mb -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ CompareDirection -> MetaId -> [Elim] -> Term -> TCMT IO ()
assign CompareDirection
dir MetaId
x [Elim]
es Term
n
      (Blocked Term, Blocked Term)
_ | MetaV MetaId
x [Elim]
es <- Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
nb -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ CompareDirection -> MetaId -> [Elim] -> Term -> TCMT IO ()
assign CompareDirection
rid MetaId
x [Elim]
es Term
m
      (Blocked{}, Blocked{}) | Bool -> Bool
not Bool
cmpBlocked  -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ TCMT IO ()
checkDefinitionalEquality
      (Blocked Blocker
b Term
_, Blocked Term
_) | Bool -> Bool
not Bool
cmpBlocked -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ CompareDirection
-> Blocker -> CompareAs -> Term -> Term -> TCMT IO ()
useInjectivity (Comparison -> CompareDirection
fromCmp Comparison
cmp) Blocker
b CompareAs
t Term
m Term
n   -- The blocked term  goes first
      (Blocked Term
_, Blocked Blocker
b Term
_) | Bool -> Bool
not Bool
cmpBlocked -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ CompareDirection
-> Blocker -> CompareAs -> Term -> Term -> TCMT IO ()
useInjectivity (CompareDirection -> CompareDirection
flipCmp (CompareDirection -> CompareDirection)
-> CompareDirection -> CompareDirection
forall a b. (a -> b) -> a -> b
$ Comparison -> CompareDirection
fromCmp Comparison
cmp) Blocker
b CompareAs
t Term
n Term
m
      (Blocked Term, Blocked Term)
bs -> TCMT IO () -> Result (TCMT IO ())
ret do
        Blocker -> TCMT IO () -> TCMT IO ()
forall a. Blocker -> TCM a -> TCM a
blockOnError Blocker
blocker (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
        -- -- Andreas, 2013-10-20 put projection-like function
        -- -- into the spine, to make compareElims work.
        -- -- 'False' means: leave (Def f []) unchanged even for
        -- -- proj-like funs.
        -- m <- elimView False m
        -- n <- elimView False n
        -- Andreas, 2015-07-01, actually, don't put them into the spine.
        -- Polarity cannot be communicated properly if projection-like
        -- functions are post-fix.
        ((TCMT IO () -> Result (TCMT IO ())) -> Result (TCMT IO ()))
-> TCMT IO ()
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \TCMT IO () -> Result (TCMT IO ())
ret -> case (Term
m, Term
n) of
          (Pi{}, Pi{}) -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ Term -> Term -> TCMT IO ()
equalFun Term
m Term
n

          (Sort Sort' Term
s1, Sort Sort' Term
s2) -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$
            TCMT IO Bool -> TCMT IO () -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (PragmaOptions -> Bool
optCumulativity (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions)
              (Comparison -> Sort' Term -> Sort' Term -> TCMT IO ()
compareSort Comparison
cmp Sort' Term
s1 Sort' Term
s2)
              (Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s1 Sort' Term
s2)

          (Lit Literal
l1, Lit Literal
l2) | Literal
l1 Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l2 -> TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          (Var Nat
i [Elim]
es, Var Nat
i' [Elim]
es') | Nat
i Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
i' -> TCMT IO () -> Result (TCMT IO ())
ret do
              a <- Nat -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(MonadDebug m, MonadTCEnv m) =>
Nat -> m (Type'' Term Term)
typeOfBV Nat
i
              -- Variables are invariant in their arguments
              compareElims [] [] a (var i) es es'

          -- The case of definition application:
          (Def QName
f [Elim]
es, Def QName
f' [Elim]
es') -> TCMT IO () -> Result (TCMT IO ())
ret do

              -- 1. All absurd lambdas are equal.
              TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (QName -> QName -> TCMT IO Bool
bothAbsurd QName
f QName
f') (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do

              -- 2. If the heads are unequal, the only chance is subtyping between SIZE and SIZELT.
              if QName
f QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
/= QName
f' then Comparison
-> CompareAs
-> Term
-> Term
-> QName
-> [Elim]
-> QName
-> [Elim]
-> TCMT IO ()
trySizeUniv Comparison
cmp CompareAs
t Term
m Term
n QName
f [Elim]
es QName
f' [Elim]
es' else do

              -- 3. If the heads are equal:
              -- 3a. If there are no arguments, we are done.
              Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless ([Elim] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Elim]
es Bool -> Bool -> Bool
&& [Elim] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Elim]
es') (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do

              -- 3b. If some cubical magic kicks in, we are done.
              TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (QName -> [Elim] -> [Elim] -> TCMT IO Bool
compareEtaPrims QName
f [Elim]
es [Elim]
es') (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do

              -- 3c. Oh no, we actually have to work and compare the eliminations!
               a <- QName -> [Elim] -> [Elim] -> TCMT IO (Type'' Term Term)
computeElimHeadType QName
f [Elim]
es [Elim]
es'
               -- The polarity vector of projection-like functions
               -- does not include the parameters.
               pol <- getPolarity' cmp f
               compareElims pol [] a (Def f []) es es'

          -- Due to eta-expansion, these constructors are fully applied.
          (Con ConHead
x ConInfo
ci [Elim]
xArgs, Con ConHead
y ConInfo
_ [Elim]
yArgs)
              | ConHead
x ConHead -> ConHead -> Bool
forall a. Eq a => a -> a -> Bool
== ConHead
y -> TCMT IO () -> Result (TCMT IO ())
ret do
                  -- Get the type of the constructor instantiated to the datatype parameters.
                  a' <- case CompareAs
t of
                    AsTermsOf Type'' Term Term
a -> ConHead -> Type'' Term Term -> TCMT IO (Type'' Term Term)
forall {m :: * -> *}.
(MonadBlock m, PureTCM m) =>
ConHead -> Type'' Term Term -> m (Type'' Term Term)
conType ConHead
x Type'' Term Term
a
                    CompareAs
AsSizes   -> TCMT IO (Type'' Term Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
                    CompareAs
AsTypes   -> TCMT IO (Type'' Term Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
                  forcedArgs <- getForcedArgs $ conName x
                  -- Constructors are covariant in their arguments
                  -- (see test/succeed/CovariantConstructors).
                  compareElims (repeat $ polFromCmp cmp) forcedArgs a' (Con x ci []) xArgs yArgs
          (Term, Term)
_ -> TCMT IO () -> Result (TCMT IO ())
ret TCMT IO ()
notEqual
    where
        -- returns True in case we handled the comparison already.
        compareEtaPrims :: QName -> Elims -> Elims -> TCM Bool
        compareEtaPrims :: QName -> [Elim] -> [Elim] -> TCMT IO Bool
compareEtaPrims QName
q [Elim]
es [Elim]
es' = do
          munglue <- PrimitiveId -> TCMT IO (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
PrimitiveId -> m (Maybe QName)
getPrimitiveName' PrimitiveId
builtin_unglue
          munglueU <- getPrimitiveName' builtin_unglueU
          msubout <- getPrimitiveName' builtinSubOut
          case () of
            ()
_ | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
munglue  -> QName -> [Elim] -> [Elim] -> TCMT IO Bool
compareUnglueApp QName
q [Elim]
es [Elim]
es'
            ()
_ | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
munglueU -> QName -> [Elim] -> [Elim] -> TCMT IO Bool
compareUnglueUApp QName
q [Elim]
es [Elim]
es'
            ()
_ | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
msubout  -> QName -> [Elim] -> [Elim] -> TCMT IO Bool
compareSubApp QName
q [Elim]
es [Elim]
es'
            ()
_                      -> Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        compareSubApp :: QName -> [Elim] -> [Elim] -> TCMT IO Bool
compareSubApp QName
q [Elim]
es [Elim]
es' = do
          let ([Elim]
as,[Elim]
bs) = Nat -> [Elim] -> ([Elim], [Elim])
forall a. Nat -> [a] -> ([a], [a])
splitAt Nat
5 [Elim]
es; ([Elim]
as',[Elim]
bs') = Nat -> [Elim] -> ([Elim], [Elim])
forall a. Nat -> [a] -> ([a], [a])
splitAt Nat
5 [Elim]
es'
          case ([Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
as, [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
as') of
            (Just [Arg Term
a,Arg Term
bA,Arg Term
phi,Arg Term
u,Arg Term
x], Just [Arg Term
a',Arg Term
bA',Arg Term
phi',Arg Term
u',Arg Term
x']) -> do
              tSub <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSub
              -- Andrea, 28-07-16:
              -- comparing the types is most probably wasteful,
              -- since b and b' should be neutral terms, but it's a
              -- precondition for the compareAtom call to make
              -- sense.
              equalType (El (tmSSort $ unArg a) $! apply tSub $! (a :) $! map' (setHiding NotHidden) [bA,phi,u])
                        (El (tmSSort $ unArg a) $! apply tSub $! (a :) $! map' (setHiding NotHidden) [bA',phi',u'])
              compareAtom cmp (AsTermsOf $ El (tmSSort $ unArg a) $! apply tSub $! (a :) $! map' (setHiding NotHidden) [bA,phi,u])
                              (unArg x) (unArg x')
              () <- compareElims [] [] (El (tmSort (unArg a)) (unArg bA)) (Def q as) bs bs'
              return True
            (Maybe [Arg Term], Maybe [Arg Term])
_  -> Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        compareUnglueApp :: QName -> [Elim] -> [Elim] -> TCMT IO Bool
compareUnglueApp QName
q [Elim]
es [Elim]
es' = do
          let ([Elim]
as,[Elim]
bs) = Nat -> [Elim] -> ([Elim], [Elim])
forall a. Nat -> [a] -> ([a], [a])
splitAt' Nat
7 [Elim]
es; ([Elim]
as',[Elim]
bs') = Nat -> [Elim] -> ([Elim], [Elim])
forall a. Nat -> [a] -> ([a], [a])
splitAt' Nat
7 [Elim]
es'
          case ([Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
as, [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
as') of
            (Just [Arg Term
la,Arg Term
lb,Arg Term
bA,Arg Term
phi,Arg Term
bT,Arg Term
e,Arg Term
b], Just [Arg Term
la',Arg Term
lb',Arg Term
bA',Arg Term
phi',Arg Term
bT',Arg Term
e',Arg Term
b']) -> do
              tGlue <- PrimitiveId -> TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
PrimitiveId -> m Term
getPrimitiveTerm PrimitiveId
builtinGlue
              -- Andrea, 28-07-16:
              -- comparing the types is most probably wasteful,
              -- since b and b' should be neutral terms, but it's a
              -- precondition for the compareAtom call to make
              -- sense.
              -- equalType (El (tmSort (unArg lb)) $ apply tGlue $ [la,lb] ++ map (setHiding NotHidden) [bA,phi,bT,e])
              --           (El (tmSort (unArg lb')) $ apply tGlue $ [la',lb'] ++ map (setHiding NotHidden) [bA',phi',bT',e'])
              compareAtom cmp (AsTermsOf $ El (tmSort (unArg lb)) $ apply tGlue $! [la,lb] ++! map' (setHiding NotHidden) [bA,phi,bT,e])
                              (unArg b) (unArg b')
              () <- compareElims [] [] (El (tmSort (unArg la)) (unArg bA)) (Def q as) bs bs'
              return True
            (Maybe [Arg Term], Maybe [Arg Term])
_  -> Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        compareUnglueUApp :: QName -> Elims -> Elims -> TCM Bool
        compareUnglueUApp :: QName -> [Elim] -> [Elim] -> TCMT IO Bool
compareUnglueUApp QName
q [Elim]
es [Elim]
es' = do
          let ([Elim]
as,[Elim]
bs) = Nat -> [Elim] -> ([Elim], [Elim])
forall a. Nat -> [a] -> ([a], [a])
splitAt' Nat
5 [Elim]
es; ([Elim]
as',[Elim]
bs') = Nat -> [Elim] -> ([Elim], [Elim])
forall a. Nat -> [a] -> ([a], [a])
splitAt' Nat
5 [Elim]
es'
          case ([Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
as, [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
as') of
            (Just [Arg Term
la,Arg Term
phi,Arg Term
bT,Arg Term
bAS,Arg Term
b], Just [Arg Term
la',Arg Term
phi',Arg Term
bT',Arg Term
bA',Arg Term
b']) -> do
              tHComp <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primHComp
              tLSuc <- primLevelSuc
              tSubOut <- primSubOut
              iz <- primIZero
              let lsuc Term
t = Term
tLSuc Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
t]
                  s = Term -> Sort' Term
tmSort (Term -> Sort' Term) -> Term -> Sort' Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
la
                  sucla = Term -> Term
lsuc (Term -> Term) -> Arg Term -> Arg Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arg Term
la
              bA <- runNamesT [] $ do
                la  <- open . unArg $ la
                phi <- open . unArg $ phi
                bT  <- open . unArg $ bT
                bAS <- open . unArg $ bAS
                (pure tSubOut <#> (pure tLSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <#> (bT <@> primIZero) <@> bAS)
              compareAtom cmp (AsTermsOf $ El (tmSort . unArg $ sucla) $ apply tHComp $ [sucla, argH (Sort s), phi] ++! [argH (unArg bT), argH bA])
                              (unArg b) (unArg b')
              () <- compareElims [] [] (El s bA) (Def q as) bs bs'
              return True
            (Maybe [Arg Term], Maybe [Arg Term])
_  -> Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        -- Andreas, 2013-05-15 due to new postponement strategy, type can now be blocked
        conType :: ConHead -> Type'' Term Term -> m (Type'' Term Term)
conType ConHead
c Type'' Term Term
t = do
          t <- Type'' Term Term -> m (Type'' Term Term)
forall (m :: * -> *) t.
(MonadReduce m, MonadBlock m, IsMeta t, Reduce t) =>
t -> m t
abortIfBlocked Type'' Term Term
t
          let impossible = do
                [Char] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"impossible" Nat
10 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$
                  TCMT IO Doc
"expected data/record type, found " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
t
                [Char] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"impossible" Nat
70 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"raw =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type'' Term Term
t
                -- __IMPOSSIBLE__
                -- Andreas, 2013-10-20:  in case termination checking fails
                -- we might get some unreduced types here.
                -- In issue 921, this happens during the final attempt
                -- to solve left-over constraints.
                -- Thus, instead of crashing, just give up gracefully.
                Blocker -> m (Type'' Term Term)
forall a. Blocker -> m a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
neverUnblock
          maybe impossible (return . snd) =<< getFullyAppliedConType c t
        equalFun :: Term -> Term -> TCMT IO ()
equalFun Term
t1 Term
t2 = ((TCMT IO () -> Result (TCMT IO ())) -> Result (TCMT IO ()))
-> TCMT IO ()
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \TCMT IO () -> Result (TCMT IO ())
ret -> case (Term
t1, Term
t2) of
          (Pi Dom' Term (Type'' Term Term)
dom1 Abs (Type'' Term Term)
b1, Pi Dom' Term (Type'' Term Term)
dom2 Abs (Type'' Term Term)
b2) -> TCMT IO () -> Result (TCMT IO ())
ret do
            [Char] -> Nat -> [Char] -> TCMT IO () -> TCMT IO ()
forall a. [Char] -> Nat -> [Char] -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Nat -> [Char] -> m a -> m a
verboseBracket [Char]
"tc.conv.fun" Nat
15 [Char]
"compare function types" (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
              [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.fun" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
                [ TCMT IO Doc
"t1 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
t1
                , TCMT IO Doc
"t2 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
t2
                ]
              Comparison
-> Dom' Term (Type'' Term Term)
-> Dom' Term (Type'' Term Term)
-> Abs (Type'' Term Term)
-> Abs (Type'' Term Term)
-> TCMT IO ()
-> TCMT IO ()
-> TCMT IO ()
compareDom Comparison
cmp Dom' Term (Type'' Term Term)
dom2 Dom' Term (Type'' Term Term)
dom1 Abs (Type'' Term Term)
b1 Abs (Type'' Term Term)
b2 (Comparison -> Term -> Term -> CompareAs -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCError m, HasBuiltins m) =>
Comparison -> Term -> Term -> CompareAs -> m a
failConversion Comparison
cmp Term
t1 Term
t2 CompareAs
AsTypes) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
                Comparison -> Type'' Term Term -> Type'' Term Term -> TCMT IO ()
compareType Comparison
cmp (Abs (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> a
absBody Abs (Type'' Term Term)
b1) (Abs (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> a
absBody Abs (Type'' Term Term)
b2)
          (Term, Term)
_ -> IO ()
Result (TCMT IO ())
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Check whether @x xArgs `cmp` y yArgs@
compareMetas :: Comparison -> CompareAs -> MetaId -> Elims -> MetaId -> Elims -> TCM ()
compareMetas :: Comparison
-> CompareAs -> MetaId -> [Elim] -> MetaId -> [Elim] -> TCMT IO ()
compareMetas Comparison
cmp CompareAs
t MetaId
x [Elim]
xArgs MetaId
y [Elim]
yArgs | MetaId
x MetaId -> MetaId -> Bool
forall a. Eq a => a -> a -> Bool
== MetaId
y = Blocker -> TCMT IO () -> TCMT IO ()
forall a. Blocker -> TCM a -> TCM a
blockOnError (MetaId -> Blocker
unblockOnMeta MetaId
x) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
  cmpBlocked <- Lens' TCEnv Bool -> TCMT IO Bool
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (Bool -> f Bool) -> TCEnv -> f TCEnv
Lens' TCEnv Bool
eCompareBlocked
  let fallback = do
        -- Fallback: check definitional equality
        a <- MetaId -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
ReadTCState m =>
MetaId -> m (Type'' Term Term)
metaType MetaId
x
        runPureConversion (compareElims [] [] a (MetaV x []) xArgs yArgs)
  if | cmpBlocked -> do
         a <- metaType x
         compareElims [] [] a (MetaV x []) xArgs yArgs
     | otherwise -> case intersectVars xArgs yArgs of
         -- all relevant arguments are variables
         Just [Bool]
kills -> do
           -- kills is a list with 'True' for each different var
           killResult <- [Bool] -> MetaId -> TCM PruneResult
killArgs [Bool]
kills MetaId
x
           case killResult of
             PruneResult
NothingToPrune   -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
             PruneResult
PrunedEverything -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
             PruneResult
PrunedNothing    -> TCMT IO ()
fallback
             PruneResult
PrunedSomething  -> TCMT IO ()
fallback
         -- not all relevant arguments are variables
         Maybe [Bool]
Nothing -> TCMT IO ()
fallback
compareMetas Comparison
cmp CompareAs
t MetaId
x [Elim]
xArgs MetaId
y [Elim]
yArgs = do
  p1 <- MetaId -> TCMT IO MetaPriority
forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m MetaPriority
getMetaPriority MetaId
x
  p2 <- getMetaPriority y
  let dir = Comparison -> CompareDirection
fromCmp Comparison
cmp
      rid = CompareDirection -> CompareDirection
flipCmp CompareDirection
dir     -- The reverse direction.  Bad name, I know.
      retry = Blocker -> TCMT IO a
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
alwaysUnblock
  -- First try the one with the highest priority. If that doesn't
  -- work, try the low priority one.
  let (solve1, solve2)
        | (p1, x) > (p2, y) = (l1, r2)
        | otherwise         = (r1, l2)
        where l1 = CompareDirection
-> MetaId
-> [Elim]
-> Term
-> CompareAs
-> (Term -> Term -> TCMT IO ())
-> TCMT IO ()
assignE CompareDirection
dir MetaId
x [Elim]
xArgs (MetaId -> [Elim] -> Term
MetaV MetaId
y [Elim]
yArgs) CompareAs
t ((Term -> Term -> TCMT IO ()) -> TCMT IO ())
-> (Term -> Term -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ Term
_ Term
_ -> TCMT IO ()
forall {a}. TCMT IO a
retry
              r1 = CompareDirection
-> MetaId
-> [Elim]
-> Term
-> CompareAs
-> (Term -> Term -> TCMT IO ())
-> TCMT IO ()
assignE CompareDirection
rid MetaId
y [Elim]
yArgs (MetaId -> [Elim] -> Term
MetaV MetaId
x [Elim]
xArgs) CompareAs
t ((Term -> Term -> TCMT IO ()) -> TCMT IO ())
-> (Term -> Term -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ Term
_ Term
_ -> TCMT IO ()
forall {a}. TCMT IO a
retry
              -- Careful: the first attempt might prune the low
              -- priority meta! (Issue #2978)
              l2 = TCMT IO Bool -> TCMT IO () -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (MetaId -> TCMT IO Bool
forall a (m :: * -> *).
(IsInstantiatedMeta a, ReadTCState m) =>
a -> m Bool
forall (m :: * -> *). ReadTCState m => MetaId -> m Bool
isInstantiatedMeta MetaId
x) TCMT IO ()
forall {a}. TCMT IO a
retry TCMT IO ()
l1
              r2 = TCMT IO Bool -> TCMT IO () -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (MetaId -> TCMT IO Bool
forall a (m :: * -> *).
(IsInstantiatedMeta a, ReadTCState m) =>
a -> m Bool
forall (m :: * -> *). ReadTCState m => MetaId -> m Bool
isInstantiatedMeta MetaId
y) TCMT IO ()
forall {a}. TCMT IO a
retry TCMT IO ()
r1

  -- Unblock on both unblockers of solve1 and solve2
  catchPatternErr (`addOrUnblocker` solve2) solve1

-- | Check whether @a1 `cmp` a2@ and continue in context extended by @a1@.
compareDom ::
     Comparison -- ^ @cmp@ The comparison direction
  -> Dom Type   -- ^ @a1@  The smaller domain.
  -> Dom Type   -- ^ @a2@  The other domain.
  -> Abs Type   -- ^ @b1@  The smaller codomain.
  -> Abs Type   -- ^ @b2@  The bigger codomain.
  -> TCM ()       -- ^ Error continuation
  -> TCM ()       -- ^ Success continuation
  -> TCM ()
compareDom :: Comparison
-> Dom' Term (Type'' Term Term)
-> Dom' Term (Type'' Term Term)
-> Abs (Type'' Term Term)
-> Abs (Type'' Term Term)
-> TCMT IO ()
-> TCMT IO ()
-> TCMT IO ()
compareDom Comparison
cmp0 dom1 :: Dom' Term (Type'' Term Term)
dom1@(Dom' Term (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> Type'' Term Term
a1) dom2 :: Dom' Term (Type'' Term Term)
dom2@(Dom' Term (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> Type'' Term Term
a2) Abs (Type'' Term Term)
b1 Abs (Type'' Term Term)
b2 TCMT IO ()
err TCMT IO ()
cont = do
  let i1 :: ArgInfo
i1 = Dom' Term (Type'' Term Term)
dom1 Dom' Term (Type'' Term Term)
-> Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
-> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo; i2 :: ArgInfo
i2 = Dom' Term (Type'' Term Term)
dom2 Dom' Term (Type'' Term Term)
-> Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
-> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo
  if | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Dom' Term (Type'' Term Term)
-> Dom' Term (Type'' Term Term) -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding Dom' Term (Type'' Term Term)
dom1 Dom' Term (Type'' Term Term)
dom2 -> TCMT IO ()
err
     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Relevance -> Relevance -> Bool
forall a. Eq a => a -> a -> Bool
(==)         (Dom' Term (Type'' Term Term) -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Dom' Term (Type'' Term Term)
dom1) (Dom' Term (Type'' Term Term) -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Dom' Term (Type'' Term Term)
dom2) -> TCMT IO ()
err
     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Quantity -> Quantity -> Bool
sameQuantity (Dom' Term (Type'' Term Term) -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity  Dom' Term (Type'' Term Term)
dom1) (Dom' Term (Type'' Term Term) -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity  Dom' Term (Type'' Term Term)
dom2) -> TCMT IO ()
err
     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Cohesion -> Cohesion -> Bool
sameCohesion (Dom' Term (Type'' Term Term) -> Cohesion
forall a. LensCohesion a => a -> Cohesion
getCohesion  Dom' Term (Type'' Term Term)
dom1) (Dom' Term (Type'' Term Term) -> Cohesion
forall a. LensCohesion a => a -> Cohesion
getCohesion  Dom' Term (Type'' Term Term)
dom2) -> TCMT IO ()
err
     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PolarityModality -> PolarityModality -> Bool
samePolarity (Dom' Term (Type'' Term Term) -> PolarityModality
forall a. LensModalPolarity a => a -> PolarityModality
getModalPolarity Dom' Term (Type'' Term Term)
dom1) (Dom' Term (Type'' Term Term) -> PolarityModality
forall a. LensModalPolarity a => a -> PolarityModality
getModalPolarity Dom' Term (Type'' Term Term)
dom2) -> TCMT IO ()
err
     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Dom' Term (Type'' Term Term) -> Bool
forall t e. Dom' t e -> Bool
domIsFinite Dom' Term (Type'' Term Term)
dom1 Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Dom' Term (Type'' Term Term) -> Bool
forall t e. Dom' t e -> Bool
domIsFinite Dom' Term (Type'' Term Term)
dom2 -> TCMT IO ()
err
     -- We compare both rewrite annotations AND the actual rewDoms to properly
     -- handle the case where we have use a rewrite annotation outside of a
     -- module telescope and continued trying to typecheck
     | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$  Dom' Term (Type'' Term Term) -> RewriteAnn
forall a. LensRewriteAnn a => a -> RewriteAnn
getRewriteAnn Dom' Term (Type'' Term Term)
dom1   RewriteAnn -> RewriteAnn -> Bool
forall a. Eq a => a -> a -> Bool
== Dom' Term (Type'' Term Term) -> RewriteAnn
forall a. LensRewriteAnn a => a -> RewriteAnn
getRewriteAnn Dom' Term (Type'' Term Term)
dom2
           Bool -> Bool -> Bool
&& Maybe (RewDom' Term) -> Bool
forall a. Maybe a -> Bool
isJust (Dom' Term (Type'' Term Term) -> Maybe (RewDom' Term)
forall t e. Dom' t e -> Maybe (RewDom' t)
rewDom Dom' Term (Type'' Term Term)
dom1) Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe (RewDom' Term) -> Bool
forall a. Maybe a -> Bool
isJust (Dom' Term (Type'' Term Term) -> Maybe (RewDom' Term)
forall t e. Dom' t e -> Maybe (RewDom' t)
rewDom Dom' Term (Type'' Term Term)
dom2) -> TCMT IO ()
err
     | Bool
otherwise -> do
      let r :: Relevance
r = Relevance -> Relevance -> Relevance
forall a. Ord a => a -> a -> a
max (Dom' Term (Type'' Term Term) -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Dom' Term (Type'' Term Term)
dom1) (Dom' Term (Type'' Term Term) -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Dom' Term (Type'' Term Term)
dom2)
              -- take "most irrelevant"
          dependent :: Bool
dependent = Bool -> Bool
not (Relevance -> Bool
forall a. LensRelevance a => a -> Bool
isIrrelevant Relevance
r) Bool -> Bool -> Bool
&& Abs (Type'' Term Term) -> Bool
forall a. Free a => Abs a -> Bool
isBinderUsed Abs (Type'' Term Term)
b2
      pid <- (ConversionZipper -> ConversionZipper)
-> TCMT IO ProblemId -> TCMT IO ProblemId
forall (m :: * -> *) a.
MonadTCError m =>
(ConversionZipper -> ConversionZipper) -> m a -> m a
addConversionContext (\ConversionZipper
r -> Dom ConversionZipper
-> Abs (Type'' Term Term)
-> Abs (Type'' Term Term)
-> ConversionZipper
ConvDom (ConversionZipper
r ConversionZipper
-> Dom' Term (Type'' Term Term) -> Dom ConversionZipper
forall a b. a -> Dom' Term b -> Dom' Term a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Dom' Term (Type'' Term Term)
dom1) Abs (Type'' Term Term)
b2 Abs (Type'' Term Term)
b1) (TCMT IO ProblemId -> TCMT IO ProblemId)
-> TCMT IO ProblemId -> TCMT IO ProblemId
forall a b. (a -> b) -> a -> b
$ TCMT IO () -> TCMT IO ProblemId
forall (m :: * -> *) a.
(MonadFresh ProblemId m, MonadConstraint m) =>
m a -> m ProblemId
newProblem_ (TCMT IO () -> TCMT IO ProblemId)
-> TCMT IO () -> TCMT IO ProblemId
forall a b. (a -> b) -> a -> b
$ Comparison -> Type'' Term Term -> Type'' Term Term -> TCMT IO ()
compareType Comparison
cmp0 Type'' Term Term
a1 Type'' Term Term
a2
      dom <- if dependent
             then (\ Type'' Term Term
a -> Dom' Term (Type'' Term Term)
dom1 {unDom = a}) <$> blockTypeOnProblem a1 pid
             else return dom1
        -- We only need to require a1 == a2 if b2 is dependent
        -- If it's non-dependent it doesn't matter what we add to the context.
      let name = [Suggestion] -> [Char]
suggests [ Abs (Type'' Term Term) -> Suggestion
forall a. Suggest a => a -> Suggestion
Suggestion Abs (Type'' Term Term)
b1 , Abs (Type'' Term Term) -> Suggestion
forall a. Suggest a => a -> Suggestion
Suggestion Abs (Type'' Term Term)
b2 ]
      addConversionContext (ConvCod dom name) $ addContext (name, dom) $ cont
      stealConstraints pid
        -- Andreas, 2013-05-15 Now, comparison of codomains is not
        -- blocked any more by getting stuck on domains.
        -- Only the domain type in context will be blocked.
        -- But see issue #1258.

-- | When comparing argument spines (in compareElims) where the first arguments
--   don't match, we keep going, substituting the anti-unification of the two
--   terms in the telescope. More precisely:
--
--  @@
--    (u = v : A)[pid]   w = antiUnify pid A u v   us = vs : Δ[w/x]
--    -------------------------------------------------------------
--                    u us = v vs : (x : A) Δ
--  @@
--
--   The simplest case of anti-unification is to return a fresh metavariable
--   (created by blockTermOnProblem), but if there's shared structure between
--   the two terms we can expose that.
--
--   This is really a crutch that lets us get away with things that otherwise
--   would require heterogenous conversion checking. See for instance issue
--   #2384.
antiUnify :: ProblemId -> Type -> Term -> Term -> TCM Term
antiUnify :: ProblemId -> Type'' Term Term -> Term -> Term -> TCMT IO Term
antiUnify ProblemId
pid Type'' Term Term
a Term
u Term
v = do
  Term
-> Term
-> (Term -> Term -> TCMT IO Term)
-> (Term -> Term -> TCMT IO Term)
-> TCMT IO Term
forall a (m :: * -> *) b.
(Instantiate a, SynEq a, MonadReduce m) =>
a -> a -> (a -> a -> m b) -> (a -> a -> m b) -> m b
SynEq.checkSyntacticEquality Term
u Term
v (\Term
u Term
_ -> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
u) ((Term -> Term -> TCMT IO Term) -> TCMT IO Term)
-> (Term -> Term -> TCMT IO Term) -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ \Term
u Term
v -> do
  (u, v) <- (Term, Term) -> TCMT IO (Term, Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Term
u, Term
v)
  reportSDoc "tc.conv.antiUnify" 30 $ vcat
    [ "antiUnify"
    , "a =" <+> prettyTCM a
    , "u =" <+> prettyTCM u
    , "v =" <+> prettyTCM v
    ]
  case (u, v) of
    (Pi Dom' Term (Type'' Term Term)
ua Abs (Type'' Term Term)
ub, Pi Dom' Term (Type'' Term Term)
va Abs (Type'' Term Term)
vb) -> do
      wa0 <- ProblemId
-> Type'' Term Term
-> Type'' Term Term
-> TCMT IO (Type'' Term Term)
antiUnifyType ProblemId
pid (Dom' Term (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom Dom' Term (Type'' Term Term)
ua) (Dom' Term (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom Dom' Term (Type'' Term Term)
va)
      let wa = Type'' Term Term
wa0 Type'' Term Term
-> Dom' Term (Type'' Term Term) -> Dom' Term (Type'' Term Term)
forall a b. a -> Dom' Term b -> Dom' Term a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Dom' Term (Type'' Term Term)
ua
      wb <- addContext wa $ antiUnifyType pid (absBody ub) (absBody vb)
      return $ Pi wa (mkAbs (absName ub) wb)
    (Lam ArgInfo
i Abs Term
u, Lam ArgInfo
_ Abs Term
v) ->
      Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
a) TCMT IO Term -> (Term -> TCMT IO Term) -> TCMT IO Term
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Pi Dom' Term (Type'' Term Term)
a Abs (Type'' Term Term)
b -> ArgInfo -> Abs Term -> Term
Lam ArgInfo
i (Abs Term -> Term) -> (Term -> Abs Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Char] -> Term -> Abs Term
forall a. (Subst a, Free a) => [Char] -> a -> Abs a
mkAbs (Abs Term -> [Char]
forall a. Abs a -> [Char]
absName Abs Term
u)) (Term -> Term) -> TCMT IO Term -> TCMT IO Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom' Term (Type'' Term Term) -> TCMT IO Term -> TCMT IO Term
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Dom' Term (Type'' Term Term) -> m a -> m a
addContext Dom' Term (Type'' Term Term)
a (ProblemId -> Type'' Term Term -> Term -> Term -> TCMT IO Term
antiUnify ProblemId
pid (Abs (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> a
absBody Abs (Type'' Term Term)
b) (Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
u) (Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
v))
        Term
_      -> TCMT IO Term
fallback
    (Var Nat
i [Elim]
us, Var Nat
j [Elim]
vs) | Nat
i Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
j -> TCMT IO Term -> TCMT IO Term
maybeGiveUp (TCMT IO Term -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ do
      a <- Nat -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(MonadDebug m, MonadTCEnv m) =>
Nat -> m (Type'' Term Term)
typeOfBV Nat
i
      antiUnifyElims pid a (var i) us vs
    -- Andreas, 2017-07-27:
    -- It seems that nothing guarantees here that the constructors are fully
    -- applied!?  Thus, @a@ could be a function type and we need the robust
    -- @getConType@ here.
    -- (Note that @patternViolation@ swallows exceptions coming from @getConType@
    -- thus, we would not see clearly if we used @getFullyAppliedConType@ instead.)
    (Con ConHead
x ConInfo
ci [Elim]
us, Con ConHead
y ConInfo
_ [Elim]
vs) | ConHead
x ConHead -> ConHead -> Bool
forall a. Eq a => a -> a -> Bool
== ConHead
y -> TCMT IO Term -> TCMT IO Term
maybeGiveUp (TCMT IO Term -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ do
      a <- TCMT IO (Type'' Term Term)
-> (((QName, Type'' Term Term, [Arg Term]), Type'' Term Term)
    -> TCMT IO (Type'' Term Term))
-> Maybe ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term)
-> TCMT IO (Type'' Term Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO (Type'' Term Term)
forall {a}. TCMT IO a
abort (Type'' Term Term -> TCMT IO (Type'' Term Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type'' Term Term -> TCMT IO (Type'' Term Term))
-> (((QName, Type'' Term Term, [Arg Term]), Type'' Term Term)
    -> Type'' Term Term)
-> ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term)
-> TCMT IO (Type'' Term Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term)
-> Type'' Term Term
forall a b. (a, b) -> b
snd) (Maybe ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term)
 -> TCMT IO (Type'' Term Term))
-> TCMT
     IO
     (Maybe ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term))
-> TCMT IO (Type'' Term Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ConHead
-> Type'' Term Term
-> TCMT
     IO
     (Maybe ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term))
forall (m :: * -> *).
(PureTCM m, MonadBlock m) =>
ConHead
-> Type'' Term Term
-> m (Maybe
        ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term))
getConType ConHead
x Type'' Term Term
a
      antiUnifyElims pid a (Con x ci []) us vs
    (Def QName
f [], Def QName
g []) | QName
f QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
g -> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> [Elim] -> Term
Def QName
f [])
    (Def QName
f [Elim]
us, Def QName
g [Elim]
vs) | QName
f QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
g, [Elim] -> Nat
forall a. [a] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [Elim]
us Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== [Elim] -> Nat
forall a. [a] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [Elim]
vs -> TCMT IO Term -> TCMT IO Term
maybeGiveUp (TCMT IO Term -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ do
      a <- QName -> [Elim] -> [Elim] -> TCMT IO (Type'' Term Term)
computeElimHeadType QName
f [Elim]
us [Elim]
vs
      antiUnifyElims pid a (Def f []) us vs
    (Term, Term)
_ -> TCMT IO Term
fallback
  where
    maybeGiveUp :: TCMT IO Term -> TCMT IO Term
maybeGiveUp = (Blocker -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term
forall a. (Blocker -> TCMT IO a) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadBlock m =>
(Blocker -> m a) -> m a -> m a
catchPatternErr ((Blocker -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term)
-> (Blocker -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ \ Blocker
_ -> TCMT IO Term
fallback
    abort :: TCMT IO a
abort = Blocker -> TCMT IO a
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
neverUnblock -- caught by maybeGiveUp
    fallback :: TCMT IO Term
fallback = Type'' Term Term -> Term -> ProblemId -> TCMT IO Term
blockTermOnProblem Type'' Term Term
a Term
u ProblemId
pid

antiUnifyArgs :: ProblemId -> Dom Type -> Arg Term -> Arg Term -> TCM (Arg Term)
antiUnifyArgs :: ProblemId
-> Dom' Term (Type'' Term Term)
-> Arg Term
-> Arg Term
-> TCMT IO (Arg Term)
antiUnifyArgs ProblemId
pid Dom' Term (Type'' Term Term)
dom Arg Term
u Arg Term
v
  | Bool -> Bool
not (Modality -> Modality -> Bool
forall a b. (LensModality a, LensModality b) => a -> b -> Bool
sameModality (Arg Term -> Modality
forall a. LensModality a => a -> Modality
getModality Arg Term
u) (Arg Term -> Modality
forall a. LensModality a => a -> Modality
getModality Arg Term
v))
              = Blocker -> TCMT IO (Arg Term)
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
neverUnblock
  | Bool
otherwise = Arg Term -> TCMT IO (Arg Term) -> TCMT IO (Arg Term)
forall (tcm :: * -> *) a m.
(MonadTCEnv tcm, ExpandCase (tcm a), LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext Arg Term
u (TCMT IO (Arg Term) -> TCMT IO (Arg Term))
-> TCMT IO (Arg Term) -> TCMT IO (Arg Term)
forall a b. (a -> b) -> a -> b
$
    TCMT IO Bool
-> TCMT IO (Arg Term) -> TCMT IO (Arg Term) -> TCMT IO (Arg Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Dom' Term (Type'' Term Term) -> TCMT IO Bool
forall a (m :: * -> *).
(LensRelevance a, LensSort a, PrettyTCM a, PureTCM m,
 MonadBlock m) =>
a -> m Bool
isIrrelevantOrPropM Dom' Term (Type'' Term Term)
dom)
    {-then-} (Arg Term -> TCMT IO (Arg Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Arg Term
u)
    {-else-} ((Term -> Arg Term -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Term
u) (Term -> Arg Term) -> TCMT IO Term -> TCMT IO (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProblemId -> Type'' Term Term -> Term -> Term -> TCMT IO Term
antiUnify ProblemId
pid (Dom' Term (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom Dom' Term (Type'' Term Term)
dom) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
v))

antiUnifyType :: ProblemId -> Type -> Type -> TCM Type
antiUnifyType :: ProblemId
-> Type'' Term Term
-> Type'' Term Term
-> TCMT IO (Type'' Term Term)
antiUnifyType ProblemId
pid (El Sort' Term
s Term
a) (El Sort' Term
_ Term
b) = TCMT IO (Type'' Term Term) -> TCMT IO (Type'' Term Term)
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
workOnTypes (TCMT IO (Type'' Term Term) -> TCMT IO (Type'' Term Term))
-> TCMT IO (Type'' Term Term) -> TCMT IO (Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Term -> Type'' Term Term
forall t a. Sort' t -> a -> Type'' t a
El Sort' Term
s (Term -> Type'' Term Term)
-> TCMT IO Term -> TCMT IO (Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProblemId -> Type'' Term Term -> Term -> Term -> TCMT IO Term
antiUnify ProblemId
pid (Sort' Term -> Type'' Term Term
sort Sort' Term
s) Term
a Term
b

antiUnifyElims :: ProblemId -> Type -> Term -> Elims -> Elims -> TCM Term
antiUnifyElims :: ProblemId
-> Type'' Term Term -> Term -> [Elim] -> [Elim] -> TCMT IO Term
antiUnifyElims ProblemId
pid Type'' Term Term
a Term
self [] [] = Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
self
antiUnifyElims ProblemId
pid Type'' Term Term
a Term
self (Proj ProjOrigin
o QName
f : [Elim]
es1) (Proj ProjOrigin
_ QName
g : [Elim]
es2) | QName
f QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
g = do
  res <- Term
-> Type'' Term Term
-> ProjOrigin
-> QName
-> TCMT
     IO (Maybe (Dom' Term (Type'' Term Term), Term, Type'' Term Term))
forall (m :: * -> *).
PureTCM m =>
Term
-> Type'' Term Term
-> ProjOrigin
-> QName
-> m (Maybe (Dom' Term (Type'' Term Term), Term, Type'' Term Term))
projectTyped Term
self Type'' Term Term
a ProjOrigin
o QName
f
  case res of
    Just (Dom' Term (Type'' Term Term)
_, Term
self, Type'' Term Term
a) -> ProblemId
-> Type'' Term Term -> Term -> [Elim] -> [Elim] -> TCMT IO Term
antiUnifyElims ProblemId
pid Type'' Term Term
a Term
self [Elim]
es1 [Elim]
es2
    Maybe (Dom' Term (Type'' Term Term), Term, Type'' Term Term)
Nothing -> Blocker -> TCMT IO Term
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
neverUnblock -- can fail for projection like
antiUnifyElims ProblemId
pid Type'' Term Term
a Term
self (Apply Arg Term
u : [Elim]
es1) (Apply Arg Term
v : [Elim]
es2) = do
  Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
a) TCMT IO Term -> (Term -> TCMT IO Term) -> TCMT IO Term
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Pi Dom' Term (Type'' Term Term)
a Abs (Type'' Term Term)
b -> do
      w <- ProblemId
-> Dom' Term (Type'' Term Term)
-> Arg Term
-> Arg Term
-> TCMT IO (Arg Term)
antiUnifyArgs ProblemId
pid Dom' Term (Type'' Term Term)
a Arg Term
u Arg Term
v
      antiUnifyElims pid (b `lazyAbsApp` unArg w) (apply self [w]) es1 es2
    Term
_ -> Blocker -> TCMT IO Term
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
neverUnblock
antiUnifyElims ProblemId
_ Type'' Term Term
_ Term
_ [Elim]
_ [Elim]
_ = Blocker -> TCMT IO Term
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
neverUnblock -- trigger maybeGiveUp in antiUnify

-- | @compareElims pols a v els1 els2@ performs type-directed equality on eliminator spines.
--   @t@ is the type of the head @v@.
--
-- Note: since TCM is lazy in return values from @(>>=)@, it is
-- important that compareElims in non-tail position be called as @() <-
-- compareElims pols a v e1 e2@ so that any internal invariants upheld
-- by returning @__IMPOSSIBLE__@ actually get checked.
compareElims :: [Polarity] -> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> TCM ()
compareElims :: [Polarity]
-> [IsForced]
-> Type'' Term Term
-> Term
-> [Elim]
-> [Elim]
-> TCMT IO ()
compareElims ![Polarity]
pols0 ![IsForced]
fors0 !Type'' Term Term
a !Term
v ![Elim]
els01 ![Elim]
els02 =
  [Char] -> Nat -> [Char] -> TCMT IO () -> TCMT IO ()
forall a. [Char] -> Nat -> [Char] -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Nat -> [Char] -> m a -> m a
verboseBracket [Char]
"tc.conv.elim" Nat
20 [Char]
"compareElims" (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
  (Constraint -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *).
MonadConstraint m =>
Constraint -> m () -> m ()
catchConstraint ([Polarity]
-> [IsForced]
-> Type'' Term Term
-> Term
-> [Elim]
-> [Elim]
-> Constraint
ElimCmp [Polarity]
pols0 [IsForced]
fors0 Type'' Term Term
a Term
v [Elim]
els01 [Elim]
els02) :: TCM () -> TCM ()) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
  let v1 :: Term
v1 = Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
applyE Term
v [Elim]
els01
      v2 :: Term
v2 = Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
applyE Term
v [Elim]
els02

      -- Andreas, issue #8126, hack: use 'AsTypes' to suppress type in error message.
      failure :: TCMT IO ()
failure = Comparison -> Term -> Term -> CompareAs -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCError m, HasBuiltins m) =>
Comparison -> Term -> Term -> CompareAs -> m a
failConversion Comparison
CmpEq Term
v1 Term
v2 (Type'' Term Term -> CompareAs
AsTermsOf Type'' Term Term
a)
        -- Andreas, 2013-03-15 since one of the spines is empty, @a@
        -- is the correct type here.
  Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless ([Elim] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Elim]
els01) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.elim" Nat
25 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"compareElims" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
$$ do
     Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ TCMT IO Doc
"a     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
a
      , TCMT IO Doc
"pols0 (truncated to 10) =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
hsep ((Polarity -> TCMT IO Doc) -> [Polarity] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map Polarity -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Polarity -> m Doc
prettyTCM ([Polarity] -> [TCMT IO Doc]) -> [Polarity] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ Nat -> [Polarity] -> [Polarity]
forall a. Nat -> [a] -> [a]
take Nat
10 [Polarity]
pols0)
      , TCMT IO Doc
"fors0 (truncated to 10) =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
hsep ((IsForced -> TCMT IO Doc) -> [IsForced] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map IsForced -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => IsForced -> m Doc
prettyTCM ([IsForced] -> [TCMT IO Doc]) -> [IsForced] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ Nat -> [IsForced] -> [IsForced]
forall a. Nat -> [a] -> [a]
take Nat
10 [IsForced]
fors0)
      , TCMT IO Doc
"v     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v
      , TCMT IO Doc
"els01 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Elim] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Elim] -> m Doc
prettyTCM [Elim]
els01
      , TCMT IO Doc
"els02 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Elim] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Elim] -> m Doc
prettyTCM [Elim]
els02
      ]
  case ([Elim]
els01, [Elim]
els02) of
    ([]         , []         ) -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    ([]         , Proj{}:[Elim]
_   ) -> TCMT IO ()
failure -- not impossible, see issue 821
    (Proj{}  : [Elim]
_, []         ) -> TCMT IO ()
failure -- could be x.p =?= x for projection p
    ([]         , Apply{} : [Elim]
_) -> TCMT IO ()
failure -- not impossible, see issue 878
    (Apply{} : [Elim]
_, []         ) -> TCMT IO ()
failure
    ([]         , IApply{} : [Elim]
_) -> TCMT IO ()
failure
    (IApply{} : [Elim]
_, []         ) -> TCMT IO ()
failure
    (Apply{} : [Elim]
_, Proj{}  : [Elim]
_) -> ()
forall a. HasCallStack => a
__IMPOSSIBLE__ () -> TCMT IO () -> TCMT IO ()
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> TCMT IO ()
forall (m :: * -> *). MonadConstraint m => Bool -> m ()
solveAwakeConstraints' Bool
True -- NB: popped up in issue 889
    (Proj{}  : [Elim]
_, Apply{} : [Elim]
_) -> ()
forall a. HasCallStack => a
__IMPOSSIBLE__ () -> TCMT IO () -> TCMT IO ()
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> TCMT IO ()
forall (m :: * -> *). MonadConstraint m => Bool -> m ()
solveAwakeConstraints' Bool
True -- but should be impossible (but again in issue 1467)
    (IApply{} : [Elim]
_, Proj{}  : [Elim]
_) -> ()
forall a. HasCallStack => a
__IMPOSSIBLE__ () -> TCMT IO () -> TCMT IO ()
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> TCMT IO ()
forall (m :: * -> *). MonadConstraint m => Bool -> m ()
solveAwakeConstraints' Bool
True
    (Proj{}  : [Elim]
_, IApply{} : [Elim]
_) -> ()
forall a. HasCallStack => a
__IMPOSSIBLE__ () -> TCMT IO () -> TCMT IO ()
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> TCMT IO ()
forall (m :: * -> *). MonadConstraint m => Bool -> m ()
solveAwakeConstraints' Bool
True

    -- Mismatched IApply/Apply is possible: Cubical.Foundations.Prelude.compPathP, Issue3601
    -- Either keep comparing as functions or as paths depending on the type of the head.
    (e :: Elim
e@(IApply Term
_ Term
_ Term
r1) : [Elim]
els1, els2 :: [Elim]
els2@(Apply Arg Term
r2:[Elim]
els2')) -> do
      a <- Type'' Term Term -> TCMT IO (Type'' Term Term)
forall (m :: * -> *) t.
(MonadReduce m, MonadBlock m, IsMeta t, Reduce t) =>
t -> m t
abortIfBlocked Type'' Term Term
a
      va <- pathView a
      case va of
        OType t :: Type'' Term Term
t@(El Sort' Term
_ Pi{}) -> [Polarity]
-> [IsForced]
-> Type'' Term Term
-> Term
-> [Elim]
-> [Elim]
-> TCMT IO ()
compareElims [Polarity]
pols0 [IsForced]
fors0 Type'' Term Term
t Term
v (Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Term -> Arg Term
forall e. e -> Arg e
defaultArg Term
r1)Elim -> [Elim] -> [Elim]
forall a. a -> [a] -> [a]
:[Elim]
els1) [Elim]
els2
        PathType Sort' Term
s QName
path Arg Term
l Arg Term
bA Arg Term
x Arg Term
y -> do
          let (Polarity
pol, [Polarity]
pols) = [Polarity] -> (Polarity, [Polarity])
nextPolarity [Polarity]
pols0
          b <- TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m (Type'' Term Term)
primIntervalType
          compareWithPol pol (flip compareTerm b) r1 (unArg r2)
          codom <- el' (pure . unArg $ l) ((pure . unArg $ bA) <@> pure r1)
          compareElims pols [] codom (applyE v [e]) els1 els2'
        PathView
_ -> ()
forall a. HasCallStack => a
__IMPOSSIBLE__ () -> TCMT IO () -> TCMT IO ()
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> TCMT IO ()
forall (m :: * -> *). MonadConstraint m => Bool -> m ()
solveAwakeConstraints' Bool
True

    (els1 :: [Elim]
els1@(Apply Arg Term
r1:[Elim]
els1'), e :: Elim
e@(IApply Term
_ Term
_ Term
r2):[Elim]
els2) -> do
      a <- Type'' Term Term -> TCMT IO (Type'' Term Term)
forall (m :: * -> *) t.
(MonadReduce m, MonadBlock m, IsMeta t, Reduce t) =>
t -> m t
abortIfBlocked Type'' Term Term
a
      va <- pathView a
      case va of
        OType t :: Type'' Term Term
t@(El Sort' Term
_ Pi{}) -> [Polarity]
-> [IsForced]
-> Type'' Term Term
-> Term
-> [Elim]
-> [Elim]
-> TCMT IO ()
compareElims [Polarity]
pols0 [IsForced]
fors0 Type'' Term Term
t Term
v [Elim]
els1 (Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Term -> Arg Term
forall e. e -> Arg e
defaultArg Term
r2)Elim -> [Elim] -> [Elim]
forall a. a -> [a] -> [a]
:[Elim]
els2)
        PathType Sort' Term
s QName
path Arg Term
l Arg Term
bA Arg Term
x Arg Term
y -> do
          let (Polarity
pol, [Polarity]
pols) = [Polarity] -> (Polarity, [Polarity])
nextPolarity [Polarity]
pols0
          b <- TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m (Type'' Term Term)
primIntervalType
          compareWithPol pol (flip compareTerm b) (unArg r1) r2
          codom <- el' (pure . unArg $ l) ((pure . unArg $ bA) <@> pure r2)
          compareElims pols [] codom (applyE v [e]) els1' els2
        PathView
_ -> ()
forall a. HasCallStack => a
__IMPOSSIBLE__ () -> TCMT IO () -> TCMT IO ()
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> TCMT IO ()
forall (m :: * -> *). MonadConstraint m => Bool -> m ()
solveAwakeConstraints' Bool
True

    (e :: Elim
e@(IApply Term
x1 Term
y1 Term
r1) : [Elim]
els1, IApply Term
x2 Term
y2 Term
r2 : [Elim]
els2) -> do
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.elim" Nat
25 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"compareElims IApply"
       -- Andrea: copying stuff from the Apply case..
      let (Polarity
pol, [Polarity]
pols) = [Polarity] -> (Polarity, [Polarity])
nextPolarity [Polarity]
pols0
      a  <- Type'' Term Term -> TCMT IO (Type'' Term Term)
forall (m :: * -> *) t.
(MonadReduce m, MonadBlock m, IsMeta t, Reduce t) =>
t -> m t
abortIfBlocked Type'' Term Term
a
      va <- pathView a
      reportSDoc "tc.conv.elim.iapply" 60 $ "compareElims IApply" $$ do
        nest 2 $ "va =" <+> text (show (isPathType va))
      case va of
        PathType Sort' Term
s QName
path Arg Term
l Arg Term
bA Arg Term
x Arg Term
y -> do
          b <- TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m (Type'' Term Term)
primIntervalType
          compareWithPol pol (flip compareTerm b)
                              r1 r2
          -- TODO: compare (x1,x2) and (y1,y2) ?
          let r = Term
r1 -- TODO Andrea:  do blocking
          codom <- el' (pure . unArg $ l) ((pure . unArg $ bA) <@> pure r)
          compareElims pols [] codom -- Path non-dependent (codom `lazyAbsApp` unArg arg)
                            (applyE v [e]) els1 els2
        -- We allow for functions (i : I) -> ... to also be heads of a IApply,
        -- because @etaContract@ can produce such terms
        OType t :: Type'' Term Term
t@(El Sort' Term
_ Pi{}) -> [Polarity]
-> [IsForced]
-> Type'' Term Term
-> Term
-> [Elim]
-> [Elim]
-> TCMT IO ()
compareElims [Polarity]
pols0 [IsForced]
fors0 Type'' Term Term
t Term
v (Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Term -> Arg Term
forall e. e -> Arg e
defaultArg Term
r1) Elim -> [Elim] -> [Elim]
forall a. a -> [a] -> [a]
: [Elim]
els1) (Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Term -> Arg Term
forall e. e -> Arg e
defaultArg Term
r2) Elim -> [Elim] -> [Elim]
forall a. a -> [a] -> [a]
: [Elim]
els2)

        OType Type'' Term Term
t -> ()
forall a. HasCallStack => a
__IMPOSSIBLE__ () -> TCMT IO () -> TCMT IO ()
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> TCMT IO ()
forall (m :: * -> *). MonadConstraint m => Bool -> m ()
solveAwakeConstraints' Bool
True

    -- András 2026-03-26: this is one of the hottest pieces of code in Agda, so it makes a lot of
    -- sense to do focused core optimization on it. We add an 'expand' to every branching to make
    -- sure that GHC doesn't compile them to closures.
    (Apply Arg Term
arg1 : [Elim]
els1, Apply Arg Term
arg2 : [Elim]
els2) ->
      ([Char] -> Nat -> [Char] -> TCMT IO () -> TCMT IO ()
forall a. [Char] -> Nat -> [Char] -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Nat -> [Char] -> m a -> m a
verboseBracket [Char]
"tc.conv.elim" Nat
20 [Char]
"compare Apply" :: TCM () -> TCM ()) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.elim" Nat
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"a    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
a
        , TCMT IO Doc
"v    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v
        , TCMT IO Doc
"arg1 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM Arg Term
arg1
        , TCMT IO Doc
"arg2 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM Arg Term
arg2
        ]
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.elim" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"raw:"
        , TCMT IO Doc
"a    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type'' Term Term
a
        , TCMT IO Doc
"v    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v
        , TCMT IO Doc
"arg1 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Arg Term
arg1
        , TCMT IO Doc
"arg2 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Arg Term
arg2
        ]
      let (Polarity
pol, [Polarity]
pols) = [Polarity] -> (Polarity, [Polarity])
nextPolarity [Polarity]
pols0
          (IsForced
for, [IsForced]
fors) = [IsForced] -> (IsForced, [IsForced])
nextIsForced [IsForced]
fors0
      a <- Type'' Term Term -> TCMT IO (Type'' Term Term)
forall (m :: * -> *) t.
(MonadReduce m, MonadBlock m, IsMeta t, Reduce t) =>
t -> m t
abortIfBlocked Type'' Term Term
a
      reportSLn "tc.conv.elim" 40 $ "type is not blocked"
      case unEl a of
        (Pi dom :: Dom' Term (Type'' Term Term)
dom@(Dom' Term (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> Type'' Term Term
b) Abs (Type'' Term Term)
codom) -> do
          let info :: ArgInfo
info = Dom' Term (Type'' Term Term)
dom Dom' Term (Type'' Term Term)
-> Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
-> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo
          [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.elim" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"type is a function type"

          dependent <- do
            -- András, 2026-04-03: skipping the freeInIgnoringSorts
            -- is faster, but it causes "cubical" to loop when lossy unification
            -- is on! TODO: figure out.
            let freeInCoDom :: Abs a -> Bool
freeInCoDom (Abs [Char]
_ a
c) = Nat
0 Nat -> a -> Bool
forall a. Free a => Nat -> a -> Bool
`freeInIgnoringSorts` a
c -- True
                freeInCoDom Abs a
_         = Bool
False

            ((TCMT IO Bool -> Result (TCMT IO Bool)) -> Result (TCMT IO Bool))
-> TCMT IO Bool
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \TCMT IO Bool -> Result (TCMT IO Bool)
ret -> if Abs (Type'' Term Term) -> Bool
forall a. Free a => Abs a -> Bool
freeInCoDom Abs (Type'' Term Term)
codom then TCMT IO Bool -> Result (TCMT IO Bool)
ret do
              mlvl <- BuiltinId -> TCMT IO (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
BuiltinLevel
              -- Level-polymorphism (x : Level) -> ... does not count as dependency here
              -- NB: we could drop the free variable test and still be sound.
              -- It is a trade-off between the administrative effort of
              -- creating a blocking and traversing a term for free variables.
              -- Apparently, it is believed that checking free vars is cheaper.
              -- Andreas, 2013-05-15
              pure $! Just (unEl b) /= mlvl
            else TCMT IO Bool -> Result (TCMT IO Bool)
ret do
              Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
False

          expand \TCMT IO () -> Result (TCMT IO ())
ret -> if Bool
dependent then TCMT IO () -> Result (TCMT IO ())
ret do

            -- compare arg1 and arg2
            pid <- (ConversionZipper -> ConversionZipper)
-> TCMT IO ProblemId -> TCMT IO ProblemId
forall (m :: * -> *) a.
MonadTCError m =>
(ConversionZipper -> ConversionZipper) -> m a -> m a
addConversionContext (\ConversionZipper
z -> Term
-> Abs (Type'' Term Term)
-> Arg ConversionZipper
-> [Elim]
-> [Elim]
-> ConversionZipper
ConvApply Term
v Abs (Type'' Term Term)
codom (ArgInfo -> ConversionZipper -> Arg ConversionZipper
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info ConversionZipper
z) [Elim]
els1 [Elim]
els2) (TCMT IO ProblemId -> TCMT IO ProblemId)
-> TCMT IO ProblemId -> TCMT IO ProblemId
forall a b. (a -> b) -> a -> b
$
              TCMT IO () -> TCMT IO ProblemId
forall (m :: * -> *) a.
(MonadFresh ProblemId m, MonadConstraint m) =>
m a -> m ProblemId
newProblemDontWake_ (TCMT IO () -> TCMT IO ProblemId)
-> TCMT IO () -> TCMT IO ProblemId
forall a b. (a -> b) -> a -> b
$ ArgInfo -> TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) a m.
(MonadTCEnv tcm, ExpandCase (tcm a), LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext ArgInfo
info (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
              ((TCMT IO () -> Result (TCMT IO ())) -> Result (TCMT IO ()))
-> TCMT IO ()
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \TCMT IO () -> Result (TCMT IO ())
ret -> if IsForced -> Bool
isForced IsForced
for then TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$
                [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.elim" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"argument is forced"
              else TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ ((TCMT IO () -> Result (TCMT IO ())) -> Result (TCMT IO ()))
-> TCMT IO ()
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \TCMT IO () -> Result (TCMT IO ())
ret -> if ArgInfo -> Bool
forall a. LensRelevance a => a -> Bool
isIrrelevant ArgInfo
info then TCMT IO () -> Result (TCMT IO ())
ret do
                [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.elim" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"argument is irrelevant"
                Type'' Term Term -> Term -> Term -> TCMT IO ()
compareIrrelevant Type'' Term Term
b (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg1) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg2)
              else TCMT IO () -> Result (TCMT IO ())
ret do
                [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.elim" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"argument has polarity " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Polarity -> [Char]
forall a. Show a => a -> [Char]
show Polarity
pol
                Polarity
-> (Comparison -> Term -> Term -> TCMT IO ())
-> Term
-> Term
-> TCMT IO ()
forall a.
Polarity
-> (Comparison -> a -> a -> TCMT IO ()) -> a -> a -> TCMT IO ()
compareWithPol Polarity
pol ((Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ())
-> Type'' Term Term -> Comparison -> Term -> Term -> TCMT IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTerm Type'' Term Term
b) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg1) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg2)

            -- if comparison got stuck, block arg
            solved <- isProblemSolved'' pid
            reportSLn "tc.conv.elim" 40 $ "solved = " ++ show solved
            arg <- expand \TCMT IO (Arg Term) -> Result (TCMT IO (Arg Term))
ret -> if Bool -> Bool
not Bool
solved then TCMT IO (Arg Term) -> Result (TCMT IO (Arg Term))
ret do
                     ArgInfo -> TCMT IO (Arg Term) -> TCMT IO (Arg Term)
forall (tcm :: * -> *) a m.
(MonadTCEnv tcm, ExpandCase (tcm a), LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext ArgInfo
info (TCMT IO (Arg Term) -> TCMT IO (Arg Term))
-> TCMT IO (Arg Term) -> TCMT IO (Arg Term)
forall a b. (a -> b) -> a -> b
$ do
                       [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.elims" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
                         [ TCMT IO Doc
"Trying antiUnify:"
                         , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"b    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
b
                         , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"arg1 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM Arg Term
arg1
                         , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"arg2 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM Arg Term
arg2
                         ]
                       arg <- (Arg Term
arg1 Arg Term -> Term -> Arg Term
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) (Term -> Arg Term) -> TCMT IO Term -> TCMT IO (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProblemId -> Type'' Term Term -> Term -> Term -> TCMT IO Term
antiUnify ProblemId
pid Type'' Term Term
b (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg1) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg2)
                       reportSDoc "tc.conv.elims" 50 $ hang "Anti-unification:" 2 (prettyTCM arg)
                       reportSDoc "tc.conv.elims" 70 $ nest 2 $ "raw:" <+> pretty arg
                       return arg
                   else TCMT IO (Arg Term) -> Result (TCMT IO (Arg Term))
ret (TCMT IO (Arg Term) -> Result (TCMT IO (Arg Term)))
-> TCMT IO (Arg Term) -> Result (TCMT IO (Arg Term))
forall a b. (a -> b) -> a -> b
$ Arg Term -> TCMT IO (Arg Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Arg Term
arg1
            -- continue, possibly with blocked instantiation
            () <- compareElims pols fors (codom `lazyAbsApp` unArg arg) (apply v [arg]) els1 els2

            expand \TCMT IO () -> Result (TCMT IO ())
ret -> if Bool -> Bool
not Bool
solved then TCMT IO () -> Result (TCMT IO ())
ret do
              -- any left over constraints of arg are associated to the comparison
              [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.elim" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"stealing constraints from problem " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ProblemId -> [Char]
forall a. Show a => a -> [Char]
show ProblemId
pid
              ProblemId -> TCMT IO ()
forall (m :: * -> *). MonadConstraint m => ProblemId -> m ()
stealConstraints ProblemId
pid
              {- Stealing solves this issue:

                 Does not create enough blocked tc-problems,
                 see test/fail/DontPrune.
                 (There are remaining problems which do not show up as yellow.)
                 Need to find a way to associate pid also to result of compareElims.
              -}
            else TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

          else TCMT IO () -> Result (TCMT IO ())
ret do
            -- compare arg1 and arg2
            (ConversionZipper -> ConversionZipper) -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCError m =>
(ConversionZipper -> ConversionZipper) -> m a -> m a
addConversionContext (\ConversionZipper
z -> Term
-> Abs (Type'' Term Term)
-> Arg ConversionZipper
-> [Elim]
-> [Elim]
-> ConversionZipper
ConvApply Term
v Abs (Type'' Term Term)
codom (ArgInfo -> ConversionZipper -> Arg ConversionZipper
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info ConversionZipper
z) [Elim]
els1 [Elim]
els2) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
              ArgInfo -> TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) a m.
(MonadTCEnv tcm, ExpandCase (tcm a), LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext ArgInfo
info (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
                ((TCMT IO () -> Result (TCMT IO ())) -> Result (TCMT IO ()))
-> TCMT IO ()
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \TCMT IO () -> Result (TCMT IO ())
ret -> if IsForced -> Bool
isForced IsForced
for then TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$
                  [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.elim" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"argument is forced"
                else TCMT IO () -> Result (TCMT IO ())
ret (TCMT IO () -> Result (TCMT IO ()))
-> TCMT IO () -> Result (TCMT IO ())
forall a b. (a -> b) -> a -> b
$ ((TCMT IO () -> Result (TCMT IO ())) -> Result (TCMT IO ()))
-> TCMT IO ()
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \TCMT IO () -> Result (TCMT IO ())
ret -> if ArgInfo -> Bool
forall a. LensRelevance a => a -> Bool
isIrrelevant ArgInfo
info then TCMT IO () -> Result (TCMT IO ())
ret do
                  [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.elim" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"argument is irrelevant"
                  Type'' Term Term -> Term -> Term -> TCMT IO ()
compareIrrelevant Type'' Term Term
b (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg1) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg2)
                else TCMT IO () -> Result (TCMT IO ())
ret do
                  [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.elim" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"argument has polarity " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Polarity -> [Char]
forall a. Show a => a -> [Char]
show Polarity
pol
                  Polarity
-> (Comparison -> Term -> Term -> TCMT IO ())
-> Term
-> Term
-> TCMT IO ()
forall a.
Polarity
-> (Comparison -> a -> a -> TCMT IO ()) -> a -> a -> TCMT IO ()
compareWithPol Polarity
pol ((Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ())
-> Type'' Term Term -> Comparison -> Term -> Term -> TCMT IO ()
forall a b c. (a -> b -> c) -> b -> a -> c
flip Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTerm Type'' Term Term
b) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg1) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg2)

            -- continue
            [Polarity]
-> [IsForced]
-> Type'' Term Term
-> Term
-> [Elim]
-> [Elim]
-> TCMT IO ()
compareElims [Polarity]
pols [IsForced]
fors (Abs (Type'' Term Term)
codom Abs (Type'' Term Term)
-> SubstArg (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
arg1) (Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
v [Arg Term
arg1]) [Elim]
els1 [Elim]
els2

        Term
a -> do
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"impossible" Nat
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
            TCMT IO Doc
"unexpected type when comparing apply eliminations " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
a
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"impossible" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"raw type:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
a
          Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation (Term -> Blocker
forall t. AllMetas t => t -> Blocker
unblockOnAnyMetaIn Term
a)
          -- Andreas, 2013-10-22
          -- in case of disabled reductions (due to failing termination check)
          -- we might get stuck, so do not crash, but fail gently.
          -- __IMPOSSIBLE__

    -- case: f == f' are projections
    (Proj ProjOrigin
o QName
f : [Elim]
els1, Proj ProjOrigin
_ QName
f' : [Elim]
els2)
      | QName
f QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
/= QName
f'   -> do
          -- Andreas, 2025-10-06, issue #8126
          -- If we are dealing with generalizable variables rather than projections,
          -- do not throw a MismatchedProjectionsError, but rather a generic f != f' error.
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.error.mismatchedProjections" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"type:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
a
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.error.mismatchedProjections" Nat
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"type:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type'' Term Term
a
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.error.mismatchedProjections" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"f = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
f
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.error.mismatchedProjections" Nat
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"f = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty QName
f
          t1 <- Term
-> Type'' Term Term
-> ProjOrigin
-> QName
-> TCMT
     IO (Maybe (Dom' Term (Type'' Term Term), Term, Type'' Term Term))
forall (m :: * -> *).
PureTCM m =>
Term
-> Type'' Term Term
-> ProjOrigin
-> QName
-> m (Maybe (Dom' Term (Type'' Term Term), Term, Type'' Term Term))
projectTyped Term
v Type'' Term Term
a ProjOrigin
o QName
f
          t2 <- projectTyped v a o f'
          case (,) <$> t1 <*> t2 of
            Just ((Dom' Term (Type'' Term Term)
_, Term
lhs, Type'' Term Term
t1), (Dom' Term (Type'' Term Term)
_, Term
rhs, Type'' Term Term
t2)) -> Type'' Term Term
-> Term
-> [Elim]
-> Type'' Term Term
-> Term
-> [Elim]
-> TCMT IO ()
forall (m :: * -> *) a.
(MonadError TCErr m, PureTCM m) =>
Type'' Term Term
-> Term -> [Elim] -> Type'' Term Term -> Term -> [Elim] -> m a
mismatchedProjections Type'' Term Term
t1 Term
lhs [Elim]
els1 Type'' Term Term
t2 Term
rhs [Elim]
els2
            Maybe
  ((Dom' Term (Type'' Term Term), Term, Type'' Term Term),
   (Dom' Term (Type'' Term Term), Term, Type'' Term Term))
Nothing -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> TypeError
MismatchedProjectionsError QName
f QName
f'
        | Bool
otherwise -> do
        a   <- Type'' Term Term -> TCMT IO (Type'' Term Term)
forall (m :: * -> *) t.
(MonadReduce m, MonadBlock m, IsMeta t, Reduce t) =>
t -> m t
abortIfBlocked Type'' Term Term
a
        res <- projectTyped v a o f -- fails only if f is proj.like but parameters cannot be retrieved
        case res of
          Just (Dom' Term (Type'' Term Term)
_, Term
u, Type'' Term Term
t) -> do
            -- Andreas, 2015-07-01:
            -- The arguments following the principal argument of a projection
            -- are invariant.  (At least as long as we have no explicit polarity
            -- annotations.)
            [Polarity]
-> [IsForced]
-> Type'' Term Term
-> Term
-> [Elim]
-> [Elim]
-> TCMT IO ()
compareElims [] [] Type'' Term Term
t Term
u [Elim]
els1 [Elim]
els2
          Maybe (Dom' Term (Type'' Term Term), Term, Type'' Term Term)
Nothing -> do
            [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.elims" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
              [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"projection " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
f
              , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"applied to value " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v
              , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"of unexpected type " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
a
              ]
            Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation (Type'' Term Term -> Blocker
forall t. AllMetas t => t -> Blocker
unblockOnAnyMetaIn Type'' Term Term
a)

{-# NOINLINE compareIrrelevant #-}
-- | "Compare" two terms in irrelevant position.  This always succeeds.
--   However, we can dig for solutions of irrelevant metas in the
--   terms we compare.
--   (Certainly not the systematic solution, that'd be proof search...)
compareIrrelevant :: Type -> Term -> Term -> TCM ()
{- 2012-04-02 DontCare no longer present
compareIrrelevant t (DontCare v) w = compareIrrelevant t v w
compareIrrelevant t v (DontCare w) = compareIrrelevant t v w
-}
compareIrrelevant :: Type'' Term Term -> Term -> Term -> TCMT IO ()
compareIrrelevant !Type'' Term Term
t !Term
v0 !Term
w0 = do
  let v :: Term
v = Term -> Term
stripDontCare Term
v0
      w :: Term
w = Term -> Term
stripDontCare Term
w0
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.irr" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"compareIrrelevant"
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"v =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"w =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
w
    ]
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.irr" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"v =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"w =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
w
    ]
  ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare irrelevant"
  Term -> Term -> TCMT IO () -> TCMT IO ()
try Term
v Term
w (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Term -> Term -> TCMT IO () -> TCMT IO ()
try Term
w Term
v (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where
    try :: Term -> Term -> TCMT IO () -> TCMT IO ()
try (MetaV MetaId
x [Elim]
es) Term
w TCMT IO ()
fallback = do
      mi <- MetaId -> TCMT IO MetaInstantiation
forall (m :: * -> *).
ReadTCState m =>
MetaId -> m MetaInstantiation
lookupMetaInstantiation MetaId
x
      mm <- lookupMetaModality x
      let rel  = Modality -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Modality
mm
          inst = case MetaInstantiation
mi of
                   InstV{} -> Bool
True
                   MetaInstantiation
_       -> Bool
False
      reportSDoc "tc.conv.irr" 20 $ vcat
        [ nest 2 $ text $ "rel  = " ++ show rel
        , nest 2 $ "inst =" <+> pretty inst
        ]
      if not (isIrrelevant rel) || inst
        then fallback
        -- Andreas, 2016-08-08, issue #2131:
        -- Mining for solutions for irrelevant metas is not definite.
        -- Thus, in case of error, leave meta unsolved.
        else assignE DirEq x es w (AsTermsOf t) (compareIrrelevant t) `catchError` \ TCErr
_ -> TCMT IO ()
fallback
        -- the value of irrelevant or unused meta does not matter
    try Term
v Term
w TCMT IO ()
fallback = TCMT IO ()
fallback

{-# INLINE compareWithPol #-}
compareWithPol :: Polarity -> (Comparison -> a -> a -> TCM ()) -> a -> a -> TCM ()
compareWithPol :: forall a.
Polarity
-> (Comparison -> a -> a -> TCMT IO ()) -> a -> a -> TCMT IO ()
compareWithPol Polarity
Invariant     Comparison -> a -> a -> TCMT IO ()
cmp a
x a
y = Comparison -> a -> a -> TCMT IO ()
cmp Comparison
CmpEq a
x a
y
compareWithPol Polarity
Covariant     Comparison -> a -> a -> TCMT IO ()
cmp a
x a
y = Comparison -> a -> a -> TCMT IO ()
cmp Comparison
CmpLeq a
x a
y
compareWithPol Polarity
Contravariant Comparison -> a -> a -> TCMT IO ()
cmp a
x a
y = Comparison -> a -> a -> TCMT IO ()
cmp Comparison
CmpLeq a
y a
x
compareWithPol Polarity
Nonvariant    Comparison -> a -> a -> TCMT IO ()
cmp a
x a
y = () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

polFromCmp :: Comparison -> Polarity
polFromCmp :: Comparison -> Polarity
polFromCmp Comparison
CmpLeq = Polarity
Covariant
polFromCmp Comparison
CmpEq  = Polarity
Invariant

-- | Type-directed equality on argument lists
--
compareArgs :: [Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> TCM ()
compareArgs :: [Polarity]
-> [IsForced]
-> Type'' Term Term
-> Term
-> [Arg Term]
-> [Arg Term]
-> TCMT IO ()
compareArgs [Polarity]
pol [IsForced]
for Type'' Term Term
a Term
v [Arg Term]
args1 [Arg Term]
args2 =
  [Polarity]
-> [IsForced]
-> Type'' Term Term
-> Term
-> [Elim]
-> [Elim]
-> TCMT IO ()
compareElims [Polarity]
pol [IsForced]
for Type'' Term Term
a Term
v ((Arg Term -> Elim) -> [Arg Term] -> [Elim]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply [Arg Term]
args1) ((Arg Term -> Elim) -> [Arg Term] -> [Elim]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply [Arg Term]
args2)

---------------------------------------------------------------------------
-- * Types
---------------------------------------------------------------------------

-- | Equality on Types
compareType :: Comparison -> Type -> Type -> TCM ()
compareType :: Comparison -> Type'' Term Term -> Type'' Term Term -> TCMT IO ()
compareType Comparison
cmp ty1 :: Type'' Term Term
ty1@(El Sort' Term
s1 Term
a1) ty2 :: Type'' Term Term
ty2@(El Sort' Term
s2 Term
a2) =
    TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
workOnTypes (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> Nat -> [Char] -> TCMT IO () -> TCMT IO ()
forall a. [Char] -> Nat -> [Char] -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Nat -> [Char] -> m a -> m a
verboseBracket [Char]
"tc.conv.type" Nat
20 [Char]
"compareType" (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.type" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"compareType" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
ty1 TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Comparison -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Comparison -> m Doc
prettyTCM Comparison
cmp
                                       , Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
ty2 ]
          , [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
hsep [ TCMT IO Doc
"   sorts:", Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s1, TCMT IO Doc
" and ", Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s2 ]
          ]
        Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAs Comparison
cmp CompareAs
AsTypes Term
a1 Term
a2

leqType :: Type -> Type -> TCM ()
leqType :: Type'' Term Term -> Type'' Term Term -> TCMT IO ()
leqType = Comparison -> Type'' Term Term -> Type'' Term Term -> TCMT IO ()
compareType Comparison
CmpLeq

-- | @coerce v a b@ coerces @v : a@ to type @b@, returning a @v' : b@
--   with maybe extra hidden applications or hidden abstractions.
--
--   In principle, this function can host coercive subtyping, but
--   currently it only tries to fix problems with hidden function types.
--
coerce :: Comparison -> Term -> Type -> Type -> TCM Term
coerce :: Comparison
-> Term -> Type'' Term Term -> Type'' Term Term -> TCMT IO Term
coerce !Comparison
cmp !Term
v !Type'' Term Term
t1 !Type'' Term Term
t2 = TCMT IO Term -> TCMT IO Term
forall (m :: * -> *) a.
(MonadPretty m, MonadError TCErr m) =>
m a -> m a
cutConversionErrors (TCMT IO Term -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Type'' Term Term -> TCMT IO Term -> TCMT IO Term
blockTerm Type'' Term Term
t2 (TCMT IO Term -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ do
  [Char] -> Nat -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => [Char] -> Nat -> m () -> m ()
verboseS [Char]
"tc.conv.coerce" Nat
10 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    (a1,a2) <- (Type'' Term Term, Type'' Term Term)
-> TCMT IO (ReifiesTo (Type'' Term Term, Type'' Term Term))
forall i (m :: * -> *).
(Reify i, MonadReify m) =>
i -> m (ReifiesTo i)
forall (m :: * -> *).
MonadReify m =>
(Type'' Term Term, Type'' Term Term)
-> m (ReifiesTo (Type'' Term Term, Type'' Term Term))
reify (Type'' Term Term
t1,Type'' Term Term
t2)
    let dbglvl = Nat
30
    reportSDoc "tc.conv.coerce" dbglvl $
      "coerce" <+> vcat
        [ "term      v  =" <+> prettyTCM v
        , "from type t1 =" <+> prettyTCM a1
        , "to type   t2 =" <+> prettyTCM a2
        , "comparison   =" <+> prettyTCM cmp
        ]
    reportSDoc "tc.conv.coerce" 70 $
      "coerce" <+> vcat
        [ "term      v  =" <+> pretty v
        , "from type t1 =" <+> pretty t1
        , "to type   t2 =" <+> pretty t2
        , "comparison   =" <+> pretty cmp
        ]
  -- v <$ do workOnTypes $ leqType t1 t2
  -- take off hidden/instance domains from t1 and t2
  TelV tel1 b1 <- Nat
-> (Dom' Term (Type'' Term Term) -> Bool)
-> Type'' Term Term
-> TCMT IO (TelV (Type'' Term Term))
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Nat
-> (Dom' Term (Type'' Term Term) -> Bool)
-> Type'' Term Term
-> m (TelV (Type'' Term Term))
telViewUpTo' (-Nat
1) Dom' Term (Type'' Term Term) -> Bool
forall a. LensHiding a => a -> Bool
notVisible Type'' Term Term
t1
  TelV tel2 b2 <- telViewUpTo' (-1) notVisible t2
  let n = Tele (Dom' Term (Type'' Term Term)) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom' Term (Type'' Term Term))
tel1 Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom' Term (Type'' Term Term)) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom' Term (Type'' Term Term))
tel2
  -- the crude solution would be
  --   v' = λ {tel2} → v {tel1}
  -- however, that may introduce unneccessary many function types
  -- If n  > 0 and b2 is not blocked, it is safe to
  -- insert n many hidden args
  if n <= 0 then fallback else do
    ifBlocked b2 (\ Blocker
_ Type'' Term Term
_ -> TCMT IO Term
fallback) $ \ NotBlocked
_ Type'' Term Term
_ -> do
      (args, t1') <- Nat
-> (Hiding -> Bool)
-> Type'' Term Term
-> TCM ([Arg Term], Type'' Term Term)
implicitArgs Nat
n Hiding -> Bool
forall a. LensHiding a => a -> Bool
notVisible Type'' Term Term
t1
      let v' = Term
v Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Arg Term]
args
      v' <$ coerceSize cmp v' t1' t2
  where
    fallback :: TCMT IO Term
fallback = Term
v Term -> TCMT IO () -> TCMT IO Term
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Comparison
-> Term -> Type'' Term Term -> Type'' Term Term -> TCMT IO ()
coerceSize Comparison
cmp Term
v Type'' Term Term
t1 Type'' Term Term
t2

-- | Account for situations like @k : (Size< j) <= (Size< k + 1)@
--
--   Actually, the semantics is
--   @(Size<= k) ∩ (Size< j) ⊆ rhs@
--   which gives a disjunctive constraint.  Mmmh, looks like stuff
--   TODO.
--
--   For now, we do a cheap heuristics.
--
coerceSize :: Comparison -> Term -> Type -> Type -> TCM ()
coerceSize :: Comparison
-> Term -> Type'' Term Term -> Type'' Term Term -> TCMT IO ()
coerceSize !Comparison
cmp !Term
v !Type'' Term Term
t1 !Type'' Term Term
t2 = [Char] -> Nat -> [Char] -> TCMT IO () -> TCMT IO ()
forall a. [Char] -> Nat -> [Char] -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Nat -> [Char] -> m a -> m a
verboseBracket [Char]
"tc.conv.size.coerce" Nat
45 [Char]
"coerceSize" (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
  TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
workOnTypes (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.size.coerce" Nat
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
      TCMT IO Doc
"coerceSize" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"term      v  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v
        , TCMT IO Doc
"from type t1 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type'' Term Term
t1
        , TCMT IO Doc
"to type   t2 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type'' Term Term
t2
        ]
    let fallback :: TCMT IO ()
fallback = Comparison -> Type'' Term Term -> Type'' Term Term -> TCMT IO ()
compareType Comparison
cmp Type'' Term Term
t1 Type'' Term Term
t2
        done :: TCMT IO ()
done = TCMT IO (Maybe BoundedSize)
-> TCMT IO () -> (BoundedSize -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Type'' Term Term -> TCMT IO (Maybe BoundedSize)
forall a (m :: * -> *).
(IsSizeType a, HasOptions m, HasBuiltins m) =>
a -> m (Maybe BoundedSize)
forall (m :: * -> *).
(HasOptions m, HasBuiltins m) =>
Type'' Term Term -> m (Maybe BoundedSize)
isSizeType (Type'' Term Term -> TCMT IO (Maybe BoundedSize))
-> TCMT IO (Type'' Term Term) -> TCMT IO (Maybe BoundedSize)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type'' Term Term -> TCMT IO (Type'' Term Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Type'' Term Term
t1) TCMT IO ()
fallback ((BoundedSize -> TCMT IO ()) -> TCMT IO ())
-> (BoundedSize -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ BoundedSize
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    -- Andreas, 2015-07-22, Issue 1615:
    -- If t1 is a meta and t2 a type like Size< v2, we need to make sure we do not miss
    -- the constraint v < v2!
    TCMT IO (Maybe BoundedSize)
-> TCMT IO () -> (BoundedSize -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Type'' Term Term -> TCMT IO (Maybe BoundedSize)
forall a (m :: * -> *).
(IsSizeType a, HasOptions m, HasBuiltins m) =>
a -> m (Maybe BoundedSize)
forall (m :: * -> *).
(HasOptions m, HasBuiltins m) =>
Type'' Term Term -> m (Maybe BoundedSize)
isSizeType (Type'' Term Term -> TCMT IO (Maybe BoundedSize))
-> TCMT IO (Type'' Term Term) -> TCMT IO (Maybe BoundedSize)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type'' Term Term -> TCMT IO (Type'' Term Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Type'' Term Term
t2) TCMT IO ()
fallback ((BoundedSize -> TCMT IO ()) -> TCMT IO ())
-> (BoundedSize -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ BoundedSize
b2 -> do
      -- Andreas, 2017-01-20, issue #2329:
      -- If v is not a size suitable for the solver, like a neutral term,
      -- we can only rely on the type.
      mv <- Term -> TCMT IO SizeMaxView
forall (m :: * -> *). PureTCM m => Term -> m SizeMaxView
sizeMaxView Term
v
      if any (\case{ DOtherSize{} -> Bool
True; DeepSizeView
_ -> Bool
False }) mv then fallback else do
      -- Andreas, 2015-02-11 do not instantiate metas here (triggers issue 1203).
      unlessM (tryConversion $ dontAssignMetas $ compareType cmp t1 t2) $ do
        -- A (most probably weaker) alternative is to just check syn.eq.
        -- ifM (snd <$> checkSyntacticEquality t1 t2) (return v) $ {- else -} do
        reportSDoc "tc.conv.size.coerce" 20 $ "coercing to a size type"
        case b2 of
          -- @t2 = Size@.  We are done!
          BoundedSize
BoundedNo -> TCMT IO ()
done
          -- @t2 = Size< v2@
          BoundedLt Term
v2 -> do
            sv2 <- Term -> TCMT IO SizeView
forall (m :: * -> *). HasBuiltins m => Term -> m SizeView
sizeView Term
v2
            case sv2 of
              SizeView
SizeInf     -> TCMT IO ()
done
              OtherSize{} -> do
                -- Andreas, 2014-06-16:
                -- Issue 1203: For now, just treat v < v2 as suc v <= v2
                -- TODO: Need proper < comparison
                vinc <- Nat -> Term -> TCMT IO Term
forall (m :: * -> *). HasBuiltins m => Nat -> Term -> m Term
sizeSuc Nat
1 Term
v
                compareSizes CmpLeq vinc v2
                done
              -- @v2 = a2 + 1@: In this case, we can try @v <= a2@
              SizeSuc Term
a2 -> do
                Comparison -> Term -> Term -> TCMT IO ()
compareSizes Comparison
CmpLeq Term
v Term
a2
                TCMT IO ()
done  -- to pass Issue 1136

---------------------------------------------------------------------------
-- * Sorts and levels
---------------------------------------------------------------------------

compareLevel :: Comparison -> Level -> Level -> TCM ()
compareLevel :: Comparison -> Level' Term -> Level' Term -> TCMT IO ()
compareLevel Comparison
CmpLeq Level' Term
u Level' Term
v = Level' Term -> Level' Term -> TCMT IO ()
leqLevel Level' Term
u Level' Term
v
compareLevel Comparison
CmpEq  Level' Term
u Level' Term
v = Level' Term -> Level' Term -> TCMT IO ()
equalLevel Level' Term
u Level' Term
v

compareSort :: Comparison -> Sort -> Sort -> TCM ()
compareSort :: Comparison -> Sort' Term -> Sort' Term -> TCMT IO ()
compareSort Comparison
CmpEq  = Sort' Term -> Sort' Term -> TCMT IO ()
equalSort
compareSort Comparison
CmpLeq = Sort' Term -> Sort' Term -> TCMT IO ()
leqSort

-- | Check that the first sort is less or equal to the second.
--
--   We can put @SizeUniv@ below @Inf@, but otherwise, it is
--   unrelated to the other universes.
--
leqSort :: Sort -> Sort -> TCM ()
leqSort :: Sort' Term -> Sort' Term -> TCMT IO ()
leqSort Sort' Term
s1 Sort' Term
s2 = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"leqSort"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s1 TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=<"
                        , Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s2 ]
        ]
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
60 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"leqSort"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ Sort' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Sort' Term
s1 TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=<"
                        , Sort' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Sort' Term
s2 ]
        ]
  ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare sorts"

  Sort' Term
-> Sort' Term
-> (Sort' Term -> Sort' Term -> TCMT IO ())
-> (Sort' Term -> Sort' Term -> TCMT IO ())
-> TCMT IO ()
forall a (m :: * -> *) b.
(Instantiate a, SynEq a, MonadReduce m) =>
a -> a -> (a -> a -> m b) -> (a -> a -> m b) -> m b
SynEq.checkSyntacticEquality Sort' Term
s1 Sort' Term
s2 (\Sort' Term
_ Sort' Term
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Sort' Term -> Sort' Term -> TCMT IO ()) -> TCMT IO ())
-> (Sort' Term -> Sort' Term -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \Sort' Term
s1 Sort' Term
s2 -> do

    s1b <- Sort' Term -> TCMT IO (Blocked (Sort' Term))
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Sort' Term
s1
    s2b <- reduceB s2

    let (s1,s2) = (ignoreBlocking s1b , ignoreBlocking s2b)
        blocker = Blocker -> Blocker -> Blocker
unblockOnEither (Blocked (Sort' Term) -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked (Sort' Term)
s1b) (Blocked (Sort' Term) -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked (Sort' Term)
s2b)
        postpone = Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
blocker

    let postponeIfBlocked = (Blocker -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a. (Blocker -> TCMT IO a) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadBlock m =>
(Blocker -> m a) -> m a -> m a
catchPatternErr ((Blocker -> TCMT IO ()) -> TCMT IO () -> TCMT IO ())
-> (Blocker -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \Blocker
blocker -> do
          if | Blocker
blocker Blocker -> Blocker -> Bool
forall a. Eq a => a -> a -> Bool
== Blocker
neverUnblock -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Sort' Term -> TypeError
NotLeqSort Sort' Term
s1 Sort' Term
s2
             | Bool
otherwise -> do
                 [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
                   [ TCMT IO Doc
"Postponing constraint"
                   , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s1 TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=<"
                                   , Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s2 ]
                   ]
                 [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
60 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
                   [ TCMT IO Doc
"Postponing constraint"
                   , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ Sort' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Sort' Term
s1 TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=<"
                                   , Sort' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Sort' Term
s2 ]
                   ]
                 blocker <- Blocker -> TCMT IO Blocker
forall (m :: * -> *). PureTCM m => Blocker -> m Blocker
updateBlocker Blocker
blocker
                 addConstraint blocker $ SortCmp CmpLeq s1 s2

    propEnabled <- isPropEnabled
    typeInTypeEnabled <- typeInType
    omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions
    let infInInf = Bool
typeInTypeEnabled Bool -> Bool -> Bool
|| Bool
omegaInOmegaEnabled

    let fvsRHS = (Nat -> VarSet -> Bool
`VarSet.member` Sort' Term -> VarSet
forall t. Free t => t -> VarSet
freeVarSet Sort' Term
s2)
    badRigid <- s1 `rigidVarsNotContainedIn` fvsRHS

    postponeIfBlocked $ case (s1, s2) of
      -- Andreas, 2018-09-03: crash on dummy sort
      (DummyS [Char]
s, Sort' Term
_) -> [Char] -> TCMT IO ()
forall {m :: * -> *} {a} {b}.
(ReportS [a], MonadDebug m, IsString a) =>
a -> m b
impossibleSort [Char]
s
      (Sort' Term
_, DummyS [Char]
s) -> [Char] -> TCMT IO ()
forall {m :: * -> *} {a} {b}.
(ReportS [a], MonadDebug m, IsString a) =>
a -> m b
impossibleSort [Char]
s

      -- The most basic rule: @Set l =< Set l'@ iff @l =< l'@
      -- Likewise for @Prop@
      -- Likewise for @SSet@
      -- @Prop l@ is below @Set l@
      -- @Set l@ is below @SSet l@
      -- @Prop l@ is below @SSet l@
      (Univ Univ
u Level' Term
a, Univ Univ
u' Level' Term
b) -> if Univ
u Univ -> Univ -> Bool
forall a. Ord a => a -> a -> Bool
<= Univ
u' then Level' Term -> Level' Term -> TCMT IO ()
leqLevel Level' Term
a Level' Term
b else TCMT IO ()
forall {a}. TCMT IO a
no

      -- @Setωᵢ@ is above all small sorts
      (Inf Univ
u Integer
m , Inf Univ
u' Integer
n) -> Bool -> TCMT IO ()
answer (Bool -> TCMT IO ()) -> Bool -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Univ
u Univ -> Univ -> Bool
forall a. Ord a => a -> a -> Bool
<= Univ
u' Bool -> Bool -> Bool
&& (Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n Bool -> Bool -> Bool
|| Bool
infInInf)
      (Univ Univ
u Level' Term
_, Inf Univ
u' Integer
_) -> Bool -> TCMT IO ()
answer (Bool -> TCMT IO ()) -> Bool -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Univ
u Univ -> Univ -> Bool
forall a. Ord a => a -> a -> Bool
<= Univ
u'
      (Inf Univ
u Integer
_, Univ Univ
u' Level' Term
_) -> Bool -> TCMT IO ()
answer (Bool -> TCMT IO ()) -> Bool -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
== Univ
u' Bool -> Bool -> Bool
&& Bool
typeInTypeEnabled

      -- @LockUniv@, @LevelUniv@, @IntervalUniv@, @SizeUniv@, and @Prop0@ are bottom sorts.
      -- So is @Set0@ if @Prop@ is not enabled.
      (Sort' Term
_       , Sort' Term
LockUniv) -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s1 Sort' Term
s2
      (Sort' Term
_       , Sort' Term
LevelUniv) -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s1 Sort' Term
s2
      (Sort' Term
_       , Sort' Term
IntervalUniv) -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s1 Sort' Term
s2
      (Sort' Term
_       , Sort' Term
SizeUniv) -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s1 Sort' Term
s2
      (Sort' Term
_       , Prop (ClosedLevel Integer
0)) -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s1 Sort' Term
s2
      (Sort' Term
_       , Type (ClosedLevel Integer
0))
        | Bool -> Bool
not Bool
propEnabled  -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s1 Sort' Term
s2

      -- @SizeUniv@, @LockUniv@ and @LevelUniv@ are unrelated to any @Set l@ or @Prop l@
      (Sort' Term
SizeUniv, Univ{}  ) -> TCMT IO ()
forall {a}. TCMT IO a
no
      (Sort' Term
SizeUniv , Inf{}  ) -> TCMT IO ()
forall {a}. TCMT IO a
no
      (Sort' Term
LockUniv, Univ{}  ) -> TCMT IO ()
forall {a}. TCMT IO a
no
      (Sort' Term
LockUniv , Inf{}  ) -> TCMT IO ()
forall {a}. TCMT IO a
no
      (Sort' Term
LevelUniv, Univ{}  ) -> TCMT IO ()
forall {a}. TCMT IO a
no
      (Sort' Term
LevelUniv , Inf{}  ) -> TCMT IO ()
forall {a}. TCMT IO a
no

      -- @IntervalUniv@ is below @SSet l@, but not @Set l@ or @Prop l@
      (Sort' Term
IntervalUniv, Type{}) -> TCMT IO ()
forall {a}. TCMT IO a
no
      (Sort' Term
IntervalUniv, Prop{}) -> TCMT IO ()
forall {a}. TCMT IO a
no
      (Sort' Term
IntervalUniv , Inf Univ
u Integer
_) -> Bool -> TCMT IO ()
answer (Bool -> TCMT IO ()) -> Bool -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Univ -> IsFibrant
univFibrancy Univ
u IsFibrant -> IsFibrant -> Bool
forall a. Eq a => a -> a -> Bool
== IsFibrant
IsStrict
      (Sort' Term
IntervalUniv , SSet Level' Term
b) -> Level' Term -> Level' Term -> TCMT IO ()
leqLevel (Integer -> Level' Term
ClosedLevel Integer
0) Level' Term
b

      -- If the first sort is a small sort that rigidly depends on a
      -- variable and the second sort does not mention this variable,
      -- the second sort must be at least @Setω@.
      (Sort' Term
_       , Sort' Term
_       ) | Right (SmallSort Univ
f) <- Sort' Term -> Either Blocker SizeOfSort
sizeOfSort Sort' Term
s1 , Bool
badRigid -> Sort' Term -> Sort' Term -> TCMT IO ()
leqSort (Univ -> Integer -> Sort' Term
forall t. Univ -> Integer -> Sort' t
Inf Univ
f Integer
0) Sort' Term
s2

      -- PiSort, FunSort, UnivSort and MetaS might reduce once we instantiate
      -- more metas, so we postpone.
      (PiSort{}, Sort' Term
_       ) -> TCMT IO ()
postpone
      (Sort' Term
_       , PiSort{}) -> TCMT IO ()
postpone
      (FunSort{}, Sort' Term
_      ) -> TCMT IO ()
postpone
      (Sort' Term
_      , FunSort{}) -> TCMT IO ()
postpone
      (UnivSort{}, Sort' Term
_     ) -> TCMT IO ()
postpone
      (Sort' Term
_     , UnivSort{}) -> TCMT IO ()
postpone
      (MetaS{} , Sort' Term
_       ) -> TCMT IO ()
postpone
      (Sort' Term
_       , MetaS{} ) -> TCMT IO ()
postpone

      -- DefS are postulated sorts, so they do not reduce.
      (DefS{} , Sort' Term
_     ) -> TCMT IO ()
forall {a}. TCMT IO a
no
      (Sort' Term
_      , DefS{}) -> TCMT IO ()
forall {a}. TCMT IO a
no

  where
  no :: TCMT IO a
no  = Blocker -> TCMT IO a
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
neverUnblock
  yes :: TCMT IO ()
yes = () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  answer :: Bool -> TCMT IO ()
answer = \case
    Bool
True -> TCMT IO ()
yes
    Bool
False -> TCMT IO ()
forall {a}. TCMT IO a
no
  impossibleSort :: a -> m b
impossibleSort a
s = do
    [Char] -> Nat -> [a] -> m ()
forall a (m :: * -> *).
(ReportS a, MonadDebug m) =>
[Char] -> Nat -> a -> m ()
forall (m :: * -> *). MonadDebug m => [Char] -> Nat -> [a] -> m ()
reportS [Char]
"impossible" Nat
10
      [ a
"leqSort: found dummy sort with description:"
      , a
s
      ]
    m b
forall a. HasCallStack => a
__IMPOSSIBLE__

leqLevel :: Level -> Level -> TCM ()
leqLevel :: Level' Term -> Level' Term -> TCMT IO ()
leqLevel Level' Term
a Level' Term
b = Constraint -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *).
MonadConstraint m =>
Constraint -> m () -> m ()
catchConstraint (Comparison -> Level' Term -> Level' Term -> Constraint
LevelCmp Comparison
CmpLeq Level' Term
a Level' Term
b) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"compareLevel" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>
          [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ Level' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Level' Term -> m Doc
prettyTCM Level' Term
a TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=<"
              , Level' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Level' Term -> m Doc
prettyTCM Level' Term
b ]
      ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare levels"

      (a, b) <- (Level' Term, Level' Term) -> TCMT IO (Level' Term, Level' Term)
forall a (m :: * -> *). (Normalise a, MonadReduce m) => a -> m a
normalise (Level' Term
a, Level' Term
b)
      SynEq.checkSyntacticEquality' a b
        (\Level' Term
_ Level' Term
_ ->
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
60
            TCMT IO Doc
"checkSyntacticEquality returns True") $ \Level' Term
a Level' Term
b -> do
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
60
        TCMT IO Doc
"checkSyntacticEquality returns False"

      let notok :: TCMT IO ()
notok    = TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM TCMT IO Bool
forall (m :: * -> *). HasOptions m => m Bool
typeInType (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Sort' Term -> TypeError
NotLeqSort (Level' Term -> Sort' Term
forall t. Level' t -> Sort' t
Type Level' Term
a) (Level' Term -> Sort' Term
forall t. Level' t -> Sort' t
Type Level' Term
b)
          postpone :: TCMT IO ()
postpone = Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation ((Level' Term, Level' Term) -> Blocker
forall t. AllMetas t => t -> Blocker
unblockOnAnyMetaIn (Level' Term
a, Level' Term
b))

          wrap :: TCMT IO () -> TCMT IO ()
wrap TCMT IO ()
m = TCMT IO ()
m TCMT IO () -> (TCErr -> TCMT IO ()) -> TCMT IO ()
forall a. TCMT IO a -> (TCErr -> TCMT IO a) -> TCMT IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \case
            TypeError{} -> TCMT IO ()
notok
            TCErr
err         -> TCErr -> TCMT IO ()
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err

      cumulativity <- PragmaOptions -> Bool
optCumulativity (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
      areWeComputingOverlap <- viewTC eConflComputingOverlap
      reportSDoc "tc.conv.level" 40 $
        "compareLevelView" <+>
          sep [ prettyList_ $ fmap (pretty . unSingleLevel) $ levelMaxView a
              , "=<"
              , prettyList_ $ fmap (pretty . unSingleLevel) $ levelMaxView b
              ]

      -- Extra reduce on level atoms, but should be cheap since they are already reduced.
      aB <- mapM reduceB a
      bB <- mapM reduceB b

      wrap $ case (levelMaxView aB, levelMaxView bB) of

        -- 0 ≤ any
        (SingleClosed Integer
0 :| [] , NonEmpty (SingleLevel' (Blocked Term))
_) -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- any ≤ 0
        (NonEmpty (SingleLevel' (Blocked Term))
as , SingleClosed Integer
0 :| []) ->
          NonEmpty (SingleLevel' (Blocked Term))
-> (SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (SingleLevel' (Blocked Term))
as ((SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ())
-> (SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ SingleLevel' (Blocked Term)
a' -> Level' Term -> Level' Term -> TCMT IO ()
equalLevel (SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel (SingleLevel' Term -> Level' Term)
-> SingleLevel' Term -> Level' Term
forall a b. (a -> b) -> a -> b
$ (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall a b. (a -> b) -> SingleLevel' a -> SingleLevel' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking SingleLevel' (Blocked Term)
a') (Integer -> Level' Term
ClosedLevel Integer
0)

        -- closed ≤ closed
        (SingleClosed Integer
m :| [], SingleClosed Integer
n :| []) -> Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Integer
n) TCMT IO ()
notok

        -- closed ≤ b
        (SingleClosed Integer
m :| [] , NonEmpty (SingleLevel' (Blocked Term))
_)
          | Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
<= Level' Term -> Integer
levelLowerBound Level' Term
b -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

        -- as ≤ neutral/closed
        (NonEmpty (SingleLevel' (Blocked Term))
as, NonEmpty (SingleLevel' (Blocked Term))
bs)
          | (SingleLevel' (Blocked Term) -> Bool)
-> NonEmpty (SingleLevel' (Blocked Term)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all SingleLevel' (Blocked Term) -> Bool
forall {t} {a}. SingleLevel' (Blocked' t a) -> Bool
neutralOrClosed NonEmpty (SingleLevel' (Blocked Term))
bs , Level' Term -> Integer
levelLowerBound Level' Term
a Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Level' Term -> Integer
levelLowerBound Level' Term
b -> TCMT IO ()
notok

        -- ⊔ as ≤ single
        (as :: NonEmpty (SingleLevel' (Blocked Term))
as@(SingleLevel' (Blocked Term)
_ :| SingleLevel' (Blocked Term)
_ : [SingleLevel' (Blocked Term)]
_), SingleLevel' (Blocked Term)
b :| []) ->
          NonEmpty (SingleLevel' (Blocked Term))
-> (SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (SingleLevel' (Blocked Term))
as ((SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ())
-> (SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ SingleLevel' (Blocked Term)
a' -> Level' Term -> Level' Term -> TCMT IO ()
leqLevel (SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel (SingleLevel' Term -> Level' Term)
-> SingleLevel' Term -> Level' Term
forall a b. (a -> b) -> a -> b
$ Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingleLevel' (Blocked Term)
a')
                                      (SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel (SingleLevel' Term -> Level' Term)
-> SingleLevel' Term -> Level' Term
forall a b. (a -> b) -> a -> b
$ Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingleLevel' (Blocked Term)
b)

        -- reduce constants
        (NonEmpty (SingleLevel' (Blocked Term))
as, NonEmpty (SingleLevel' (Blocked Term))
bs)
          | let minN :: Integer
minN = Integer -> Integer -> Integer
forall a. Ord a => a -> a -> a
min ((Integer, Level' Term) -> Integer
forall a b. (a, b) -> a
fst ((Integer, Level' Term) -> Integer)
-> (Integer, Level' Term) -> Integer
forall a b. (a -> b) -> a -> b
$ Level' Term -> (Integer, Level' Term)
levelPlusView Level' Term
a) ((Integer, Level' Term) -> Integer
forall a b. (a, b) -> a
fst ((Integer, Level' Term) -> Integer)
-> (Integer, Level' Term) -> Integer
forall a b. (a -> b) -> a -> b
$ Level' Term -> (Integer, Level' Term)
levelPlusView Level' Term
b)
                a' :: Level' Term
a'   = Level' Term -> Maybe (Level' Term) -> Level' Term
forall a. a -> Maybe a -> a
fromMaybe Level' Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Level' Term) -> Level' Term)
-> Maybe (Level' Term) -> Level' Term
forall a b. (a -> b) -> a -> b
$ Integer -> Level' Term -> Maybe (Level' Term)
subLevel Integer
minN Level' Term
a
                b' :: Level' Term
b'   = Level' Term -> Maybe (Level' Term) -> Level' Term
forall a. a -> Maybe a -> a
fromMaybe Level' Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Level' Term) -> Level' Term)
-> Maybe (Level' Term) -> Level' Term
forall a b. (a -> b) -> a -> b
$ Integer -> Level' Term -> Maybe (Level' Term)
subLevel Integer
minN Level' Term
b
          , Integer
minN Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0 -> Level' Term -> Level' Term -> TCMT IO ()
leqLevel Level' Term
a' Level' Term
b'

        -- remove subsumed
        -- Andreas, 2014-04-07: This is ok if we do not go back to equalLevel
        (NonEmpty (SingleLevel' (Blocked Term))
as, NonEmpty (SingleLevel' (Blocked Term))
bs)
          | (subsumed :: [SingleLevel' (Blocked Term)]
subsumed@(SingleLevel' (Blocked Term)
_:[SingleLevel' (Blocked Term)]
_) , [SingleLevel' (Blocked Term)]
as') <- (SingleLevel' (Blocked Term) -> Bool)
-> NonEmpty (SingleLevel' (Blocked Term))
-> ([SingleLevel' (Blocked Term)], [SingleLevel' (Blocked Term)])
forall a. (a -> Bool) -> NonEmpty a -> ([a], [a])
List1.partition (SingleLevel' Term -> Bool
isSubsumed (SingleLevel' Term -> Bool)
-> (SingleLevel' (Blocked Term) -> SingleLevel' Term)
-> SingleLevel' (Blocked Term)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall a b. (a -> b) -> SingleLevel' a -> SingleLevel' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking) NonEmpty (SingleLevel' (Blocked Term))
as
          -> Level' Term -> Level' Term -> TCMT IO ()
leqLevel ([SingleLevel' Term] -> Level' Term
unSingleLevels ([SingleLevel' Term] -> Level' Term)
-> [SingleLevel' Term] -> Level' Term
forall a b. (a -> b) -> a -> b
$ ((SingleLevel' (Blocked Term) -> SingleLevel' Term)
-> [SingleLevel' (Blocked Term)] -> [SingleLevel' Term]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SingleLevel' (Blocked Term) -> SingleLevel' Term)
 -> [SingleLevel' (Blocked Term)] -> [SingleLevel' Term])
-> ((Blocked Term -> Term)
    -> SingleLevel' (Blocked Term) -> SingleLevel' Term)
-> (Blocked Term -> Term)
-> [SingleLevel' (Blocked Term)]
-> [SingleLevel' Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall a b. (a -> b) -> SingleLevel' a -> SingleLevel' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking [SingleLevel' (Blocked Term)]
as') Level' Term
b
          where
            isSubsumed :: SingleLevel' Term -> Bool
isSubsumed SingleLevel' Term
a = (SingleLevel' Term -> Bool) -> NonEmpty (SingleLevel' Term) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (SingleLevel' Term -> SingleLevel' Term -> Bool
`subsumes` SingleLevel' Term
a) (NonEmpty (SingleLevel' Term) -> Bool)
-> NonEmpty (SingleLevel' Term) -> Bool
forall a b. (a -> b) -> a -> b
$ ((SingleLevel' (Blocked Term) -> SingleLevel' Term)
-> NonEmpty (SingleLevel' (Blocked Term))
-> NonEmpty (SingleLevel' Term)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SingleLevel' (Blocked Term) -> SingleLevel' Term)
 -> NonEmpty (SingleLevel' (Blocked Term))
 -> NonEmpty (SingleLevel' Term))
-> ((Blocked Term -> Term)
    -> SingleLevel' (Blocked Term) -> SingleLevel' Term)
-> (Blocked Term -> Term)
-> NonEmpty (SingleLevel' (Blocked Term))
-> NonEmpty (SingleLevel' Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall a b. (a -> b) -> SingleLevel' a -> SingleLevel' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking NonEmpty (SingleLevel' (Blocked Term))
bs

            subsumes :: SingleLevel -> SingleLevel -> Bool
            subsumes :: SingleLevel' Term -> SingleLevel' Term -> Bool
subsumes (SingleClosed Integer
m)        (SingleClosed Integer
n)        = Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
n
            subsumes (SinglePlus (Plus Integer
m Term
_)) (SingleClosed Integer
n)        = Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
n
            subsumes (SinglePlus (Plus Integer
m Term
a)) (SinglePlus (Plus Integer
n Term
b)) = Term
a Term -> Term -> Bool
forall a. Eq a => a -> a -> Bool
== Term
b Bool -> Bool -> Bool
&& Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
>= Integer
n
            subsumes SingleLevel' Term
_ SingleLevel' Term
_ = Bool
False

        -- as ≤ _l x₁ .. xₙ ⊔ bs
        -- We can solve _l := λ x₁ .. xₙ -> as ⊔ (_l' x₁ .. xₙ)
        -- (where _l' is a new metavariable)
        (NonEmpty (SingleLevel' (Blocked Term))
as , NonEmpty (SingleLevel' (Blocked Term))
bs)
          | Bool
cumulativity
          , Bool -> Bool
not Bool
areWeComputingOverlap
          , Just (mb :: Term
mb@(MetaV MetaId
x [Elim]
es) , [SingleLevel' Term]
bs') <- [SingleLevel' Term] -> Maybe (Term, [SingleLevel' Term])
singleMetaView ([SingleLevel' Term] -> Maybe (Term, [SingleLevel' Term]))
-> [SingleLevel' Term] -> Maybe (Term, [SingleLevel' Term])
forall a b. (a -> b) -> a -> b
$ ((SingleLevel' (Blocked Term) -> SingleLevel' Term)
-> [SingleLevel' (Blocked Term)] -> [SingleLevel' Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((SingleLevel' (Blocked Term) -> SingleLevel' Term)
 -> [SingleLevel' (Blocked Term)] -> [SingleLevel' Term])
-> ((Blocked Term -> Term)
    -> SingleLevel' (Blocked Term) -> SingleLevel' Term)
-> (Blocked Term -> Term)
-> [SingleLevel' (Blocked Term)]
-> [SingleLevel' Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall a b. (a -> b) -> SingleLevel' a -> SingleLevel' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking (NonEmpty (SingleLevel' (Blocked Term))
-> [Item (NonEmpty (SingleLevel' (Blocked Term)))]
forall l. IsList l => l -> [Item l]
List1.toList NonEmpty (SingleLevel' (Blocked Term))
bs)
          , [SingleLevel' Term] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [SingleLevel' Term]
bs' Bool -> Bool -> Bool
|| (Term, Level' Term) -> Bool
forall a. AllMetas a => a -> Bool
noMetas (Level' Term -> Term
Level Level' Term
a , [SingleLevel' Term] -> Level' Term
unSingleLevels [SingleLevel' Term]
bs') -> do
            mv <- MetaId -> TCMT IO MetaVariable
forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m MetaVariable
lookupLocalMeta MetaId
x
            -- Jesper, 2019-10-13: abort if this is an interaction
            -- meta or a generalizable meta
            abort <- (isJust <$> isInteractionMeta x) `or2M`
                     ((== YesGeneralizeVar) <$> isGeneralizableMeta x)
            if | abort -> postpone
               | otherwise -> do
                  x' <- case mvJudgement mv of
                    IsSort{} -> TCMT IO MetaId
forall a. HasCallStack => a
__IMPOSSIBLE__
                    HasType MetaId
_ Comparison
cmp Type'' Term Term
t -> do
                      TelV tel t' <- Type'' Term Term -> TCMT IO (TelV (Type'' Term Term))
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type'' Term Term -> m (TelV (Type'' Term Term))
telView Type'' Term Term
t
                      newMeta Instantiable (mvInfo mv) normalMetaPriority (idP $ size tel) $ HasType () cmp t
                  reportSDoc "tc.conv.level" 20 $ fsep
                    [ "attempting to solve" , prettyTCM (MetaV x es) , "to the maximum of"
                    , prettyTCM (Level a) , "and the fresh meta" , prettyTCM (MetaV x' es)
                    ]
                  equalLevel (atomicLevel mb) $ levelLub a (atomicLevel $ MetaV x' es)


        -- Andreas, 2016-09-28: This simplification loses the solution lzero.
        -- Thus, it is invalid.
        -- See test/Succeed/LevelMetaLeqNeutralLevel.agda.
        -- -- [a] ≤ [neutral]
        -- ([a@(Plus n _)], [b@(Plus m NeutralLevel{})])
        --   | m == n -> equalLevel' (Max [a]) (Max [b])
        --   -- Andreas, 2014-04-07: This call to equalLevel is ok even if we removed
        --   -- subsumed terms from the lhs.

        -- anything else
        (NonEmpty (SingleLevel' (Blocked Term)),
 NonEmpty (SingleLevel' (Blocked Term)))
_ | (Level' Term, Level' Term) -> Bool
forall a. AllMetas a => a -> Bool
noMetas (Level' Term
a, Level' Term
b) -> TCMT IO ()
notok
          | Bool
otherwise      -> TCMT IO ()
postpone
      where
        neutralOrClosed :: SingleLevel' (Blocked' t a) -> Bool
neutralOrClosed (SingleClosed Integer
_)                   = Bool
True
        neutralOrClosed (SinglePlus (Plus Integer
_ NotBlocked{})) = Bool
True
        neutralOrClosed SingleLevel' (Blocked' t a)
_                                  = Bool
False

        -- Is there exactly one @MetaV@ in the list of single levels?
        singleMetaView :: [SingleLevel] -> Maybe (Term, [SingleLevel])
        singleMetaView :: [SingleLevel' Term] -> Maybe (Term, [SingleLevel' Term])
singleMetaView (SinglePlus (Plus Integer
0 l :: Term
l@(MetaV MetaId
m [Elim]
es)) : [SingleLevel' Term]
ls)
          | (SingleLevel' Term -> Bool) -> [SingleLevel' Term] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Bool -> Bool
not (Bool -> Bool)
-> (SingleLevel' Term -> Bool) -> SingleLevel' Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleLevel' Term -> Bool
isMetaLevel) [SingleLevel' Term]
ls = (Term, [SingleLevel' Term]) -> Maybe (Term, [SingleLevel' Term])
forall a. a -> Maybe a
Just (Term
l,[SingleLevel' Term]
ls)
        singleMetaView (SingleLevel' Term
l : [SingleLevel' Term]
ls)
          | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ SingleLevel' Term -> Bool
isMetaLevel SingleLevel' Term
l = ([SingleLevel' Term] -> [SingleLevel' Term])
-> (Term, [SingleLevel' Term]) -> (Term, [SingleLevel' Term])
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (SingleLevel' Term
lSingleLevel' Term -> [SingleLevel' Term] -> [SingleLevel' Term]
forall a. a -> [a] -> [a]
:) ((Term, [SingleLevel' Term]) -> (Term, [SingleLevel' Term]))
-> Maybe (Term, [SingleLevel' Term])
-> Maybe (Term, [SingleLevel' Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SingleLevel' Term] -> Maybe (Term, [SingleLevel' Term])
singleMetaView [SingleLevel' Term]
ls
        singleMetaView [SingleLevel' Term]
_ = Maybe (Term, [SingleLevel' Term])
forall a. Maybe a
Nothing

        isMetaLevel :: SingleLevel -> Bool
        isMetaLevel :: SingleLevel' Term -> Bool
isMetaLevel (SinglePlus (Plus Integer
_ MetaV{})) = Bool
True
        isMetaLevel SingleLevel' Term
_                             = Bool
False

equalLevel :: Level -> Level -> TCM ()
equalLevel :: Level' Term -> Level' Term -> TCMT IO ()
equalLevel Level' Term
a Level' Term
b = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"equalLevel", Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
parens (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Level' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Level' Term
a, Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
parens (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Level' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Level' Term
b ]
  ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare levels"
  lvl <- TCMT IO (Type'' Term Term)
forall (m :: * -> *). HasBuiltins m => m (Type'' Term Term)
levelType'
  -- Andreas, 2013-10-31 remove common terms (that don't contain metas!)
  -- THAT's actually UNSOUND when metas are instantiated, because
  --     max a b == max a c  does not imply  b == c
  -- as <- return $ Set.fromList $ closed0 as
  -- bs <- return $ Set.fromList $ closed0 bs
  -- let cs = Set.filter (not . hasMeta) $ Set.intersection as bs
  -- as <- return $ Set.toList $ as Set.\\ cs
  -- bs <- return $ Set.toList $ bs Set.\\ cs

  reportSDoc "tc.conv.level" 40 $
    sep [ "equalLevel"
        , vcat [ nest 2 $ sep [ prettyTCM a <+> "=="
                              , prettyTCM b
                              ]
               ]
        ]
  reportSDoc "tc.conv.level" 80 $ sep [ "equalLevel", nest 2 $ parens $ pretty a, nest 2 $ parens $ pretty b ]

  (a, b) <- normalise (a, b)

  -- Jesper, 2014-02-02 remove terms that certainly do not contribute
  -- to the maximum
  let (a', b') = removeSubsumed a b

  SynEq.checkSyntacticEquality' a' b'
    (\Level' Term
_ Level' Term
_ ->
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
60
        TCMT IO Doc
"checkSyntacticEquality returns True") $ \Level' Term
a Level' Term
b -> do

  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
60 TCMT IO Doc
"checkSyntacticEquality returns False"

  let notok :: TCMT IO ()
notok    = TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM TCMT IO Bool
forall (m :: * -> *). HasOptions m => m Bool
typeInType TCMT IO ()
notOk
      notOk :: TCMT IO ()
notOk    = Comparison -> Term -> Term -> CompareAs -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCError m, HasBuiltins m) =>
Comparison -> Term -> Term -> CompareAs -> m a
failConversion Comparison
CmpEq (Level' Term -> Term
Level Level' Term
a') (Level' Term -> Term
Level Level' Term
b') (Type'' Term Term -> CompareAs
AsTermsOf Type'' Term Term
lvl)
      postpone :: TCMT IO ()
postpone = do
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *).
Applicative m =>
m Doc -> Nat -> m Doc -> m Doc
hang TCMT IO Doc
"postponing:" Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *).
Applicative m =>
m Doc -> Nat -> m Doc -> m Doc
hang (Level' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Level' Term
a' TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"==") Nat
0 (Level' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Level' Term
b')
        blocker <- (Level' Term, Level' Term) -> Blocker
forall t. AllMetas t => t -> Blocker
unblockOnAnyMetaIn ((Level' Term, Level' Term) -> Blocker)
-> TCMT IO (Level' Term, Level' Term) -> TCMT IO Blocker
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Level' Term, Level' Term) -> TCMT IO (Level' Term, Level' Term)
forall a (m :: * -> *).
(InstantiateFull a, MonadReduce m) =>
a -> m a
instantiateFull (Level' Term
a', Level' Term
b')
        patternViolation blocker

  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"equalLevel (w/o subsumed)"
        , [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat [ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ Level' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Level' Term -> m Doc
prettyTCM Level' Term
a' TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=="
                              , Level' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Level' Term -> m Doc
prettyTCM Level' Term
b'
                              ]
               ]
        ]

  let as :: NonEmpty (SingleLevel' Term)
as  = Level' Term -> NonEmpty (SingleLevel' Term)
forall t. Level' t -> List1 (SingleLevel' t)
levelMaxView Level' Term
a'
      bs :: NonEmpty (SingleLevel' Term)
bs  = Level' Term -> NonEmpty (SingleLevel' Term)
forall t. Level' t -> List1 (SingleLevel' t)
levelMaxView Level' Term
b'
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"equalLevel"
        , [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat [ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ NonEmpty (TCMT IO Doc) -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList_ (NonEmpty (TCMT IO Doc) -> TCMT IO Doc)
-> NonEmpty (TCMT IO Doc) -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (SingleLevel' Term -> TCMT IO Doc)
-> NonEmpty (SingleLevel' Term) -> NonEmpty (TCMT IO Doc)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Level' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Level' Term -> m Doc
prettyTCM (Level' Term -> TCMT IO Doc)
-> (SingleLevel' Term -> Level' Term)
-> SingleLevel' Term
-> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel) NonEmpty (SingleLevel' Term)
as
                              , TCMT IO Doc
"=="
                              , NonEmpty (TCMT IO Doc) -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList_ (NonEmpty (TCMT IO Doc) -> TCMT IO Doc)
-> NonEmpty (TCMT IO Doc) -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (SingleLevel' Term -> TCMT IO Doc)
-> NonEmpty (SingleLevel' Term) -> NonEmpty (TCMT IO Doc)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Level' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Level' Term -> m Doc
prettyTCM (Level' Term -> TCMT IO Doc)
-> (SingleLevel' Term -> Level' Term)
-> SingleLevel' Term
-> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel) NonEmpty (SingleLevel' Term)
bs
                              ]
               ]
        ]

  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.level" Nat
80 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"equalLevel"
        , [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat [ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ NonEmpty (TCMT IO Doc) -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList_ (NonEmpty (TCMT IO Doc) -> TCMT IO Doc)
-> NonEmpty (TCMT IO Doc) -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (SingleLevel' Term -> TCMT IO Doc)
-> NonEmpty (SingleLevel' Term) -> NonEmpty (TCMT IO Doc)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Level' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Level' Term -> TCMT IO Doc)
-> (SingleLevel' Term -> Level' Term)
-> SingleLevel' Term
-> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel) NonEmpty (SingleLevel' Term)
as
                              , TCMT IO Doc
"=="
                              , NonEmpty (TCMT IO Doc) -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList_ (NonEmpty (TCMT IO Doc) -> TCMT IO Doc)
-> NonEmpty (TCMT IO Doc) -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (SingleLevel' Term -> TCMT IO Doc)
-> NonEmpty (SingleLevel' Term) -> NonEmpty (TCMT IO Doc)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Level' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Level' Term -> TCMT IO Doc)
-> (SingleLevel' Term -> Level' Term)
-> SingleLevel' Term
-> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel) NonEmpty (SingleLevel' Term)
bs
                              ]
               ]
        ]

  -- Extra reduce on level atoms, but should be cheap since they are already reduced.
  as <- ((SingleLevel' Term -> TCMT IO (SingleLevel' (Blocked Term)))
-> NonEmpty (SingleLevel' Term)
-> TCMT IO (NonEmpty (SingleLevel' (Blocked Term)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM ((SingleLevel' Term -> TCMT IO (SingleLevel' (Blocked Term)))
 -> NonEmpty (SingleLevel' Term)
 -> TCMT IO (NonEmpty (SingleLevel' (Blocked Term))))
-> ((Term -> TCMT IO (Blocked Term))
    -> SingleLevel' Term -> TCMT IO (SingleLevel' (Blocked Term)))
-> (Term -> TCMT IO (Blocked Term))
-> NonEmpty (SingleLevel' Term)
-> TCMT IO (NonEmpty (SingleLevel' (Blocked Term)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> TCMT IO (Blocked Term))
-> SingleLevel' Term -> TCMT IO (SingleLevel' (Blocked Term))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> SingleLevel' a -> m (SingleLevel' b)
mapM) Term -> TCMT IO (Blocked Term)
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB NonEmpty (SingleLevel' Term)
as
  bs <- (mapM . mapM) reduceB bs

  catchConstraint (LevelCmp CmpEq a b) $ case (as, bs) of

        -- closed == closed
        (SingleClosed Integer
m :| [], SingleClosed Integer
n :| [])
          | Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
n    -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          | Bool
otherwise -> TCMT IO ()
notok

        -- closed == neutral
        (SingleClosed Integer
m :| [] , NonEmpty (SingleLevel' (Blocked Term))
bs) | (SingleLevel' (Blocked Term) -> Bool)
-> NonEmpty (SingleLevel' (Blocked Term)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SingleLevel' (Blocked Term) -> Bool
forall {t} {a}. SingleLevel' (Blocked' t a) -> Bool
isNeutral NonEmpty (SingleLevel' (Blocked Term))
bs -> TCMT IO ()
notok
        (NonEmpty (SingleLevel' (Blocked Term))
as , SingleClosed Integer
n :| []) | (SingleLevel' (Blocked Term) -> Bool)
-> NonEmpty (SingleLevel' (Blocked Term)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SingleLevel' (Blocked Term) -> Bool
forall {t} {a}. SingleLevel' (Blocked' t a) -> Bool
isNeutral NonEmpty (SingleLevel' (Blocked Term))
as -> TCMT IO ()
notok

        -- closed == b
        (SingleClosed Integer
m :| [] , NonEmpty (SingleLevel' (Blocked Term))
_) | Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Level' Term -> Integer
levelLowerBound Level' Term
b -> TCMT IO ()
notok
        (NonEmpty (SingleLevel' (Blocked Term))
_ , SingleClosed Integer
n :| []) | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Level' Term -> Integer
levelLowerBound Level' Term
a -> TCMT IO ()
notok

        -- 0 == a ⊔ b
        (SingleClosed Integer
0 :| [] , bs :: NonEmpty (SingleLevel' (Blocked Term))
bs@(SingleLevel' (Blocked Term)
_ :| SingleLevel' (Blocked Term)
_ : [SingleLevel' (Blocked Term)]
_)) ->
          NonEmpty (SingleLevel' (Blocked Term))
-> (SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (SingleLevel' (Blocked Term))
bs ((SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ())
-> (SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ SingleLevel' (Blocked Term)
b' ->  Level' Term -> Level' Term -> TCMT IO ()
equalLevel (Integer -> Level' Term
ClosedLevel Integer
0) (SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel (SingleLevel' Term -> Level' Term)
-> SingleLevel' Term -> Level' Term
forall a b. (a -> b) -> a -> b
$ Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingleLevel' (Blocked Term)
b')
        (as :: NonEmpty (SingleLevel' (Blocked Term))
as@(SingleLevel' (Blocked Term)
_ :| SingleLevel' (Blocked Term)
_ : [SingleLevel' (Blocked Term)]
_) , SingleClosed Integer
0 :| []) ->
          NonEmpty (SingleLevel' (Blocked Term))
-> (SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty (SingleLevel' (Blocked Term))
as ((SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ())
-> (SingleLevel' (Blocked Term) -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ SingleLevel' (Blocked Term)
a' -> Level' Term -> Level' Term -> TCMT IO ()
equalLevel (SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel (SingleLevel' Term -> Level' Term)
-> SingleLevel' Term -> Level' Term
forall a b. (a -> b) -> a -> b
$ Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> SingleLevel' (Blocked Term)
a') (Integer -> Level' Term
ClosedLevel Integer
0)

        -- meta == any
        (SinglePlus (Plus Integer
k Blocked Term
a) :| [] , SinglePlus (Plus Integer
l Blocked Term
b) :| [])
          -- there is only a potential choice when k == l
          | MetaV MetaId
x [Elim]
as' <- Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
a
          , MetaV MetaId
y [Elim]
bs' <- Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
b
          , Integer
k Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
l -> do
              Comparison
-> CompareAs -> MetaId -> [Elim] -> MetaId -> [Elim] -> TCMT IO ()
compareMetas Comparison
CmpEq (Type'' Term Term -> CompareAs
AsTermsOf Type'' Term Term
lvl) MetaId
x [Elim]
as' MetaId
y [Elim]
bs'
        (SinglePlus (Plus Integer
k Blocked Term
a) :| [] , NonEmpty (SingleLevel' (Blocked Term))
_)
          | MetaV MetaId
x [Elim]
as' <- Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
a
          , Just Level' Term
b' <- Integer -> Level' Term -> Maybe (Level' Term)
subLevel Integer
k Level' Term
b -> MetaId -> [Elim] -> Level' Term -> TCMT IO ()
meta MetaId
x [Elim]
as' Level' Term
b'
        (NonEmpty (SingleLevel' (Blocked Term))
_ , SinglePlus (Plus Integer
l Blocked Term
b) :| [])
          | MetaV MetaId
y [Elim]
bs' <- Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
b
          , Just Level' Term
a' <- Integer -> Level' Term -> Maybe (Level' Term)
subLevel Integer
l Level' Term
a -> MetaId -> [Elim] -> Level' Term -> TCMT IO ()
meta MetaId
y [Elim]
bs' Level' Term
a'

        -- a' ⊔ b == b
        (NonEmpty (SingleLevel' (Blocked Term)),
 NonEmpty (SingleLevel' (Blocked Term)))
_ | Just Level' Term
a' <- Level' Term -> Level' Term -> Maybe (Level' Term)
levelMaxDiff Level' Term
a Level' Term
b
          , Level' Term
b Level' Term -> Level' Term -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Level' Term
ClosedLevel Integer
0 -> Level' Term -> Level' Term -> TCMT IO ()
leqLevel Level' Term
a' Level' Term
b

        -- a == b' ⊔ a
        (NonEmpty (SingleLevel' (Blocked Term)),
 NonEmpty (SingleLevel' (Blocked Term)))
_ | Just Level' Term
b' <- Level' Term -> Level' Term -> Maybe (Level' Term)
levelMaxDiff Level' Term
b Level' Term
a
          , Level' Term
a Level' Term -> Level' Term -> Bool
forall a. Eq a => a -> a -> Bool
/= Integer -> Level' Term
ClosedLevel Integer
0 -> Level' Term -> Level' Term -> TCMT IO ()
leqLevel Level' Term
b' Level' Term
a

        -- neutral/closed == neutral/closed
        (NonEmpty (SingleLevel' (Blocked Term))
as , NonEmpty (SingleLevel' (Blocked Term))
bs)
          | (SingleLevel' (Blocked Term) -> Bool)
-> NonEmpty (SingleLevel' (Blocked Term)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all SingleLevel' (Blocked Term) -> Bool
forall {t} {a}. SingleLevel' (Blocked' t a) -> Bool
isNeutralOrClosed (NonEmpty (SingleLevel' (Blocked Term))
as NonEmpty (SingleLevel' (Blocked Term))
-> NonEmpty (SingleLevel' (Blocked Term))
-> NonEmpty (SingleLevel' (Blocked Term))
forall a. Semigroup a => a -> a -> a
<> NonEmpty (SingleLevel' (Blocked Term))
bs)
          -- Andreas, 2013-10-31: There could be metas in neutral levels (see Issue 930).
          -- Should not we postpone there as well?  Yes!
          , Bool -> Bool
not ((SingleLevel' (Blocked Term) -> Bool)
-> NonEmpty (SingleLevel' (Blocked Term)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any SingleLevel' (Blocked Term) -> Bool
forall {a} {t}. AllMetas a => SingleLevel' (Blocked' t a) -> Bool
hasMeta (NonEmpty (SingleLevel' (Blocked Term))
as NonEmpty (SingleLevel' (Blocked Term))
-> NonEmpty (SingleLevel' (Blocked Term))
-> NonEmpty (SingleLevel' (Blocked Term))
forall a. Semigroup a => a -> a -> a
<> NonEmpty (SingleLevel' (Blocked Term))
bs))
          , NonEmpty (SingleLevel' (Blocked Term)) -> Nat
forall a. NonEmpty a -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length NonEmpty (SingleLevel' (Blocked Term))
as Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== NonEmpty (SingleLevel' (Blocked Term)) -> Nat
forall a. NonEmpty a -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length NonEmpty (SingleLevel' (Blocked Term))
bs -> do
              [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.conv.level" Nat
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"equalLevel: all are neutral or closed"
              (SingleLevel' (Blocked Term)
 -> SingleLevel' (Blocked Term) -> TCMT IO ())
-> NonEmpty (SingleLevel' (Blocked Term))
-> NonEmpty (SingleLevel' (Blocked Term))
-> TCMT IO ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> List1 a -> List1 b -> m ()
List1.zipWithM_ (Term -> Term -> TCMT IO ()
(===) (Term -> Term -> TCMT IO ())
-> (SingleLevel' (Blocked Term) -> Term)
-> SingleLevel' (Blocked Term)
-> SingleLevel' (Blocked Term)
-> TCMT IO ()
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Level' Term -> Term
levelTm (Level' Term -> Term)
-> (SingleLevel' (Blocked Term) -> Level' Term)
-> SingleLevel' (Blocked Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SingleLevel' Term -> Level' Term
forall t. SingleLevel' t -> Level' t
unSingleLevel (SingleLevel' Term -> Level' Term)
-> (SingleLevel' (Blocked Term) -> SingleLevel' Term)
-> SingleLevel' (Blocked Term)
-> Level' Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Blocked Term -> Term)
-> SingleLevel' (Blocked Term) -> SingleLevel' Term
forall a b. (a -> b) -> SingleLevel' a -> SingleLevel' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking) NonEmpty (SingleLevel' (Blocked Term))
as NonEmpty (SingleLevel' (Blocked Term))
bs

        -- more cases?
        (NonEmpty (SingleLevel' (Blocked Term)),
 NonEmpty (SingleLevel' (Blocked Term)))
_ | (Level' Term, Level' Term) -> Bool
forall a. AllMetas a => a -> Bool
noMetas (Level' Term
a , Level' Term
b) -> TCMT IO ()
notok
          | Bool
otherwise       -> TCMT IO ()
postpone

      where
        Term
a === :: Term -> Term -> TCMT IO ()
=== Term
b = TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM TCMT IO Bool
forall (m :: * -> *). HasOptions m => m Bool
typeInType (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
          lvl <- TCMT IO (Type'' Term Term)
forall (m :: * -> *). HasBuiltins m => m (Type'' Term Term)
levelType'
          equalAtom (AsTermsOf lvl) a b

        -- perform assignment (MetaV x as) := b
        meta :: MetaId -> [Elim] -> Level' Term -> TCMT IO ()
meta MetaId
x [Elim]
as Level' Term
b = do
          [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.level" Nat
30 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Assigning meta level"
          [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.level" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"meta" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [[TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
prettyList ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (Elim -> TCMT IO Doc) -> [Elim] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map' Elim -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [Elim]
as, Level' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Level' Term
b]
          lvl <- TCMT IO (Type'' Term Term)
forall (m :: * -> *). HasBuiltins m => m (Type'' Term Term)
levelType'
          assignE DirEq x as (levelTm b) (AsTermsOf lvl) (===) -- fallback: check equality as atoms

        isNeutral :: SingleLevel' (Blocked' t a) -> Bool
isNeutral (SinglePlus (Plus Integer
_ NotBlocked{})) = Bool
True
        isNeutral SingleLevel' (Blocked' t a)
_                                  = Bool
False

        isNeutralOrClosed :: SingleLevel' (Blocked' t a) -> Bool
isNeutralOrClosed (SingleClosed Integer
_)                   = Bool
True
        isNeutralOrClosed (SinglePlus (Plus Integer
_ NotBlocked{})) = Bool
True
        isNeutralOrClosed SingleLevel' (Blocked' t a)
_                                  = Bool
False

        hasMeta :: SingleLevel' (Blocked' t a) -> Bool
hasMeta (SinglePlus (Plus Integer
_ Blocked{})) = Bool
True
        hasMeta (SinglePlus (Plus Integer
_ Blocked' t a
a))         = Maybe MetaId -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MetaId -> Bool) -> Maybe MetaId -> Bool
forall a b. (a -> b) -> a -> b
$ a -> Maybe MetaId
forall a. AllMetas a => a -> Maybe MetaId
firstMeta (a -> Maybe MetaId) -> a -> Maybe MetaId
forall a b. (a -> b) -> a -> b
$ Blocked' t a -> a
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' t a
a
        hasMeta (SingleClosed Integer
_)                = Bool
False

        removeSubsumed :: Level' Term -> Level' Term -> (Level' Term, Level' Term)
removeSubsumed Level' Term
a Level' Term
b =
          let as :: [Item (NonEmpty (SingleLevel' Term))]
as = NonEmpty (SingleLevel' Term)
-> [Item (NonEmpty (SingleLevel' Term))]
forall l. IsList l => l -> [Item l]
List1.toList (NonEmpty (SingleLevel' Term)
 -> [Item (NonEmpty (SingleLevel' Term))])
-> NonEmpty (SingleLevel' Term)
-> [Item (NonEmpty (SingleLevel' Term))]
forall a b. (a -> b) -> a -> b
$ Level' Term -> NonEmpty (SingleLevel' Term)
forall t. Level' t -> List1 (SingleLevel' t)
levelMaxView Level' Term
a
              bs :: [Item (NonEmpty (SingleLevel' Term))]
bs = NonEmpty (SingleLevel' Term)
-> [Item (NonEmpty (SingleLevel' Term))]
forall l. IsList l => l -> [Item l]
List1.toList (NonEmpty (SingleLevel' Term)
 -> [Item (NonEmpty (SingleLevel' Term))])
-> NonEmpty (SingleLevel' Term)
-> [Item (NonEmpty (SingleLevel' Term))]
forall a b. (a -> b) -> a -> b
$ Level' Term -> NonEmpty (SingleLevel' Term)
forall t. Level' t -> List1 (SingleLevel' t)
levelMaxView Level' Term
b
              a' :: Level' Term
a' = [SingleLevel' Term] -> Level' Term
unSingleLevels ([SingleLevel' Term] -> Level' Term)
-> [SingleLevel' Term] -> Level' Term
forall a b. (a -> b) -> a -> b
$ (SingleLevel' Term -> Bool)
-> [SingleLevel' Term] -> [SingleLevel' Term]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (SingleLevel' Term -> Bool) -> SingleLevel' Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SingleLevel' Term -> [SingleLevel' Term] -> Bool
forall {t :: * -> *} {a}.
(Foldable t, Eq a) =>
SingleLevel' a -> t (SingleLevel' a) -> Bool
`isStrictlySubsumedBy` [Item (NonEmpty (SingleLevel' Term))]
[SingleLevel' Term]
bs)) [Item (NonEmpty (SingleLevel' Term))]
[SingleLevel' Term]
as
              b' :: Level' Term
b' = [SingleLevel' Term] -> Level' Term
unSingleLevels ([SingleLevel' Term] -> Level' Term)
-> [SingleLevel' Term] -> Level' Term
forall a b. (a -> b) -> a -> b
$ (SingleLevel' Term -> Bool)
-> [SingleLevel' Term] -> [SingleLevel' Term]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> (SingleLevel' Term -> Bool) -> SingleLevel' Term -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SingleLevel' Term -> [SingleLevel' Term] -> Bool
forall {t :: * -> *} {a}.
(Foldable t, Eq a) =>
SingleLevel' a -> t (SingleLevel' a) -> Bool
`isStrictlySubsumedBy` [Item (NonEmpty (SingleLevel' Term))]
[SingleLevel' Term]
as)) [Item (NonEmpty (SingleLevel' Term))]
[SingleLevel' Term]
bs
          in (Level' Term
a',Level' Term
b')

        SingleLevel' a
x isStrictlySubsumedBy :: SingleLevel' a -> t (SingleLevel' a) -> Bool
`isStrictlySubsumedBy` t (SingleLevel' a)
ys = (SingleLevel' a -> Bool) -> t (SingleLevel' a) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (SingleLevel' a -> SingleLevel' a -> Bool
forall {a}. Eq a => SingleLevel' a -> SingleLevel' a -> Bool
`strictlySubsumes` SingleLevel' a
x) t (SingleLevel' a)
ys

        SingleClosed Integer
m        strictlySubsumes :: SingleLevel' a -> SingleLevel' a -> Bool
`strictlySubsumes` SingleClosed Integer
n        = Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
n
        SinglePlus (Plus Integer
m a
a) `strictlySubsumes` SingleClosed Integer
n        = Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
n
        SinglePlus (Plus Integer
m a
a) `strictlySubsumes` SinglePlus (Plus Integer
n a
b) = a
a a -> a -> Bool
forall a. Eq a => a -> a -> Bool
== a
b Bool -> Bool -> Bool
&& Integer
m Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
n
        SingleLevel' a
_                     `strictlySubsumes` SingleLevel' a
_                     = Bool
False


-- | Check that the first sort equal to the second.
equalSort :: Sort -> Sort -> TCM ()
equalSort :: Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s1 Sort' Term
s2 = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
    [ TCMT IO Doc
"equalSort"
    , [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat [ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s1 TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=="
                           , Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s2 ]
           ]
    ]
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
60 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
    [ TCMT IO Doc
"equalSort"
    , [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat [ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ Sort' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Sort' Term
s1 TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=="
                           , Sort' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Sort' Term
s2 ]
           ]
    ]
  ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare sorts"

  Sort' Term -> Sort' Term -> [Char] -> TCMT IO () -> TCMT IO ()
forall a. a -> a -> [Char] -> TCMT IO () -> TCMT IO ()
guardPointerEquality Sort' Term
s1 Sort' Term
s2 [Char]
"pointer equality: sorts" (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    Sort' Term
-> Sort' Term
-> (Sort' Term -> Sort' Term -> TCMT IO ())
-> (Sort' Term -> Sort' Term -> TCMT IO ())
-> TCMT IO ()
forall a (m :: * -> *) b.
(Instantiate a, SynEq a, MonadReduce m) =>
a -> a -> (a -> a -> m b) -> (a -> a -> m b) -> m b
SynEq.checkSyntacticEquality Sort' Term
s1 Sort' Term
s2 (\Sort' Term
_ Sort' Term
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) ((Sort' Term -> Sort' Term -> TCMT IO ()) -> TCMT IO ())
-> (Sort' Term -> Sort' Term -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \Sort' Term
s1 Sort' Term
s2 -> do

    s1b <- Sort' Term -> TCMT IO (Blocked (Sort' Term))
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Sort' Term
s1
    s2b <- reduceB s2

    let (s1,s2) = (ignoreBlocking s1b, ignoreBlocking s2b)
        blocker = Blocker -> Blocker -> Blocker
unblockOnEither (Blocked (Sort' Term) -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked (Sort' Term)
s1b) (Blocked (Sort' Term) -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked (Sort' Term)
s2b)

    let postponeIfBlocked = (Blocker -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a. (Blocker -> TCMT IO a) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadBlock m =>
(Blocker -> m a) -> m a -> m a
catchPatternErr ((Blocker -> TCMT IO ()) -> TCMT IO () -> TCMT IO ())
-> (Blocker -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \Blocker
blocker -> do
          if | Blocker
blocker Blocker -> Blocker -> Bool
forall a. Eq a => a -> a -> Bool
== Blocker
neverUnblock -> Comparison -> Term -> Term -> CompareAs -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCError m, HasBuiltins m) =>
Comparison -> Term -> Term -> CompareAs -> m a
failConversion Comparison
CmpEq (Sort' Term -> Term
Sort Sort' Term
s1) (Sort' Term -> Term
Sort Sort' Term
s2) CompareAs
AsTypes
             | Bool
otherwise -> do
                 [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
                   [ TCMT IO Doc
"Postponing constraint"
                   , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [ Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s1 TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=="
                                   , Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s2 ]
                   ]
                 -- Andreas, 2023-12-21, recomputing the blocker fixes issue #7034.
                 blocker <- Blocker -> TCMT IO Blocker
forall (m :: * -> *). PureTCM m => Blocker -> m Blocker
updateBlocker Blocker
blocker
                 addConstraint blocker $ SortCmp CmpEq s1 s2

    propEnabled <- isPropEnabled
    typeInTypeEnabled <- typeInType
    omegaInOmegaEnabled <- optOmegaInOmega <$> pragmaOptions
    let infInInf = Bool
typeInTypeEnabled Bool -> Bool -> Bool
|| Bool
omegaInOmegaEnabled

    postponeIfBlocked $ case (s1, s2) of

            -- Andreas, 2018-09-03: crash on dummy sort
            (DummyS [Char]
s, Sort' Term
_) -> [Char] -> TCMT IO ()
forall {m :: * -> *} {a} {b}.
(ReportS [a], MonadDebug m, IsString a) =>
a -> m b
impossibleSort [Char]
s
            (Sort' Term
_, DummyS [Char]
s) -> [Char] -> TCMT IO ()
forall {m :: * -> *} {a} {b}.
(ReportS [a], MonadDebug m, IsString a) =>
a -> m b
impossibleSort [Char]
s

            -- one side is a meta sort: try to instantiate
            -- In case both sides are meta sorts, instantiate the
            -- bigger (i.e. more recent) one.
            (MetaS MetaId
x [Elim]
es , MetaS MetaId
y [Elim]
es') -> Comparison
-> CompareAs -> MetaId -> [Elim] -> MetaId -> [Elim] -> TCMT IO ()
compareMetas Comparison
CmpEq CompareAs
AsTypes MetaId
x [Elim]
es MetaId
y [Elim]
es'
            (MetaS MetaId
x [Elim]
es , Sort' Term
_          ) -> MetaId -> [Elim] -> Sort' Term -> TCMT IO ()
meta MetaId
x [Elim]
es Sort' Term
s2
            (Sort' Term
_          , MetaS MetaId
x [Elim]
es ) -> MetaId -> [Elim] -> Sort' Term -> TCMT IO ()
meta MetaId
x [Elim]
es Sort' Term
s1

            -- diagonal cases for rigid sorts
            (Univ Univ
u Level' Term
a   , Univ Univ
u' Level' Term
b  ) | Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
== Univ
u' -> Level' Term -> Level' Term -> TCMT IO ()
equalLevel Level' Term
a Level' Term
b TCMT IO () -> TCMT IO () -> TCMT IO ()
forall {m :: * -> *} {a}. MonadError TCErr m => m a -> m a -> m a
`catchInequalLevel` TCMT IO ()
forall {a}. TCMT IO a
no
            (Sort' Term
SizeUniv   , Sort' Term
SizeUniv   ) -> TCMT IO ()
yes
            (Sort' Term
LockUniv   , Sort' Term
LockUniv   ) -> TCMT IO ()
yes
            (Sort' Term
LevelUniv  , Sort' Term
LevelUniv  ) -> TCMT IO ()
yes
            (Sort' Term
IntervalUniv , Sort' Term
IntervalUniv) -> TCMT IO ()
yes
            (Inf Univ
u Integer
m    , Inf Univ
u' Integer
n   ) ->
              if Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
== Univ
u' Bool -> Bool -> Bool
&& (Integer
m Integer -> Integer -> Bool
forall a. Eq a => a -> a -> Bool
== Integer
n Bool -> Bool -> Bool
|| Bool
infInInf) then TCMT IO ()
yes else TCMT IO ()
forall {a}. TCMT IO a
no

            -- if --type-in-type is enabled, Setωᵢ is equal to any Set ℓ (see #3439)
            (Univ Univ
u Level' Term
_   , Inf  Univ
u' Integer
_  ) -> Bool -> TCMT IO ()
answer (Bool -> TCMT IO ()) -> Bool -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
== Univ
u' Bool -> Bool -> Bool
&& Bool
typeInTypeEnabled
            (Inf  Univ
u Integer
_   , Univ Univ
u' Level' Term
_  ) -> Bool -> TCMT IO ()
answer (Bool -> TCMT IO ()) -> Bool -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
== Univ
u' Bool -> Bool -> Bool
&& Bool
typeInTypeEnabled

            -- equating @PiSort a b@ to another sort
            (Sort' Term
s1 , PiSort Dom' Term Term
a Sort' Term
b Abs (Sort' Term)
c) -> Bool
-> Sort' Term
-> Dom' Term Term
-> Sort' Term
-> Abs (Sort' Term)
-> Blocker
-> TCMT IO ()
piSortEquals Bool
propEnabled Sort' Term
s1 Dom' Term Term
a Sort' Term
b Abs (Sort' Term)
c Blocker
blocker
            (PiSort Dom' Term Term
a Sort' Term
b Abs (Sort' Term)
c , Sort' Term
s2) -> Bool
-> Sort' Term
-> Dom' Term Term
-> Sort' Term
-> Abs (Sort' Term)
-> Blocker
-> TCMT IO ()
piSortEquals Bool
propEnabled Sort' Term
s2 Dom' Term Term
a Sort' Term
b Abs (Sort' Term)
c Blocker
blocker

            -- equating @FunSort a b@ to another sort
            (Sort' Term
s1 , FunSort Sort' Term
a Sort' Term
b) -> Bool
-> Sort' Term -> Sort' Term -> Sort' Term -> Blocker -> TCMT IO ()
funSortEquals Bool
propEnabled Sort' Term
s1 Sort' Term
a Sort' Term
b Blocker
blocker
            (FunSort Sort' Term
a Sort' Term
b , Sort' Term
s2) -> Bool
-> Sort' Term -> Sort' Term -> Sort' Term -> Blocker -> TCMT IO ()
funSortEquals Bool
propEnabled Sort' Term
s2 Sort' Term
a Sort' Term
b Blocker
blocker

            -- equating @UnivSort s@ to another sort
            (Sort' Term
s1          , UnivSort Sort' Term
s2) -> Bool -> Bool -> Sort' Term -> Sort' Term -> Blocker -> TCMT IO ()
univSortEquals Bool
propEnabled Bool
infInInf Sort' Term
s1 Sort' Term
s2 Blocker
blocker
            (UnivSort Sort' Term
s1 , Sort' Term
s2         ) -> Bool -> Bool -> Sort' Term -> Sort' Term -> Blocker -> TCMT IO ()
univSortEquals Bool
propEnabled Bool
infInInf Sort' Term
s2 Sort' Term
s1 Blocker
blocker

            -- postulated sorts can only be equal if they have the same head
            (DefS QName
d [Elim]
es  , DefS QName
d' [Elim]
es')
              | QName
d QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
d'                -> do
                  pol <- Comparison -> QName -> TCMT IO [Polarity]
forall (m :: * -> *).
(HasCallStack, HasConstInfo m) =>
Comparison -> QName -> m [Polarity]
getPolarity' Comparison
CmpEq QName
d
                  a <- computeElimHeadType d es es'
                  compareElims pol [] a (Def d []) es es'
              | Bool
otherwise              -> TCMT IO ()
forall {a}. TCMT IO a
no

            -- any other combinations of sorts are not equal
            (Sort' Term
_          , Sort' Term
_          ) -> TCMT IO ()
forall {a}. TCMT IO a
no

    where
      yes :: TCMT IO ()
yes = () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      no :: TCMT IO a
no  = Blocker -> TCMT IO a
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
neverUnblock
      answer :: Bool -> TCMT IO ()
answer = \case
        Bool
True -> TCMT IO ()
yes
        Bool
False -> TCMT IO ()
forall {a}. TCMT IO a
no

      -- perform assignment (MetaS x es) := s
      meta :: MetaId -> [Elim' Term] -> Sort -> TCM ()
      meta :: MetaId -> [Elim] -> Sort' Term -> TCMT IO ()
meta MetaId
x [Elim]
es Sort' Term
s = do
        [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.meta.sort" Nat
30 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Assigning meta sort"
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.meta.sort" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"meta" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [MetaId -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty MetaId
x, [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
prettyList ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (Elim -> TCMT IO Doc) -> [Elim] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map' Elim -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [Elim]
es, Sort' Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Sort' Term
s]
        CompareDirection
-> MetaId
-> [Elim]
-> Term
-> CompareAs
-> (Term -> Term -> TCMT IO ())
-> TCMT IO ()
assignE CompareDirection
DirEq MetaId
x [Elim]
es (Sort' Term -> Term
Sort Sort' Term
s) CompareAs
AsTypes Term -> Term -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__

       -- Sorts that contain exactly one other kind of sorts.
      invertibleSort :: Bool -> Univ -> Bool
      invertibleSort :: Bool -> Univ -> Bool
invertibleSort Bool
propEnabled = \case
        -- @SSetω(n+1)@ is the successor sort of exactly @SSetω(n)@.
        Univ
USSet -> Bool
True
        -- @Setω(n+1)@ is the successor sort of exactly @Setω(n)@ if we do not have @Prop@.
        Univ
UType -> Bool -> Bool
not Bool
propEnabled
        -- @Prop@ sorts are not successor sorts.
        Univ
UProp -> Bool
False

      -- Equate a sort @s1@ to @univSort s2@
      -- Precondition: @s1@ and @univSort s2@ are already reduced.
      univSortEquals :: Bool -> Bool -> Sort -> Sort -> Blocker -> TCM ()
      univSortEquals :: Bool -> Bool -> Sort' Term -> Sort' Term -> Blocker -> TCMT IO ()
univSortEquals Bool
propEnabled Bool
infInInf Sort' Term
s1 Sort' Term
s2 Blocker
blocker = do
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
35 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"univSortEquals"
          , TCMT IO Doc
"  s1 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s1
          , TCMT IO Doc
"  s2 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s2
          ]
        let postpone :: TCMT IO ()
postpone = Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
blocker
        case Sort' Term
s1 of
          -- @Prop l@, @SizeUniv@ and @LevelUniv@ are not successor sorts.
          Prop{}      -> TCMT IO ()
forall {a}. TCMT IO a
no
          Inf Univ
UProp Integer
_ -> TCMT IO ()
forall {a}. TCMT IO a
no
          SizeUniv{}  -> TCMT IO ()
forall {a}. TCMT IO a
no
          LevelUniv{} -> TCMT IO ()
forall {a}. TCMT IO a
no
          -- Neither are @LockUniv@ or @IntervalUniv@.
          LockUniv{}     -> TCMT IO ()
forall {a}. TCMT IO a
no
          IntervalUniv{} -> TCMT IO ()
forall {a}. TCMT IO a
no

          -- @Set l1@ is the successor sort of either @Set l2@ or
          -- @Prop l2@ where @l1 == lsuc l2@.
          Type Level' Term
l1 -> do
            levelUnivEnabled <- PragmaOptions -> Bool
optLevelUniverse (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
            guardedEnabled   <- optGuarded       <$> pragmaOptions
               -- @s2@ is definitely not @Inf n@ or @SizeUniv@
            if | Inf _ _n <- s2 -> __IMPOSSIBLE__
               | SizeUniv <- s2 -> __IMPOSSIBLE__
               -- The predecessor @s2@ is can also not be @SSet _@ or @IntervalUniv@
               | Univ USSet _ <- s2 -> __IMPOSSIBLE__
               | IntervalUniv <- s2 -> __IMPOSSIBLE__
               -- If @Prop@ is not used, then @s2@ must be of the form @Set l2@,
               -- except when l1 == 1, then it could also be @LockUniv@ or @LevelUniv@.
               | not (propEnabled || guardedEnabled || levelUnivEnabled) -> do
                   l2 <- case subLevel 1 l1 of
                     Just Level' Term
l2 -> Level' Term -> TCMT IO (Level' Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Level' Term
l2
                     Maybe (Level' Term)
Nothing -> do
                       l2 <- TCMT IO (Level' Term)
newLevelMeta
                       equalLevel l1 (levelSuc l2)
                       return l2
                   equalSort (Type l2) s2
               -- Otherwise we postpone
               | otherwise -> postpone
          -- @SSetω(n+1)@ is the successor sort of exactly @SSetω(n)@.
          -- @SSetω@ is the successor sort of exactly @SSetω@ if
          -- --type-in-type or --omega-in-omega is enabled.
          -- The same is only true for @Setω(n+1)@ if @Propω...@ are disabled.
          -- @Setω@ is the successor sort of @Setω@ (type:type) or @SizeUniv@ (--sized-types).
          Inf Univ
u Integer
0 -> do
              -- Compute the predecessor(s) of (S)Setω and return it if it is unique.
              sizedTypesEnabled <- TCMT IO Bool
forall (m :: * -> *). HasOptions m => m Bool
sizedTypesOption
              -- guardedEnabled <- optGuarded <$> pragmaOptions
              case concat
                [ [ s1       | u /= UProp, infInInf ]
                , [ dummy    | u == UType, infInInf, propEnabled, let dummy = Univ -> Integer -> Sort' t
forall t. Univ -> Integer -> Sort' t
Inf Univ
UProp Integer
0 ]
                    -- We enter a dummy into the solution set if --prop makes predecessor ambiguous.
                , [ SizeUniv | u == UType, sizedTypesEnabled ]
                -- , [ LockUniv | guardedEnabled ]  -- LockUniv is actually in Set₁, not Setω
                ]
                of
                [ Sort' Term
s ] -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s Sort' Term
s2
                []    -> TCMT IO ()
forall {a}. TCMT IO a
no
                [Sort' Term]
_     -> TCMT IO ()
postpone
          Inf Univ
u Integer
n | Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0, Bool -> Univ -> Bool
invertibleSort Bool
propEnabled Univ
u ->
            Sort' Term -> Sort' Term -> TCMT IO ()
equalSort (Univ -> Integer -> Sort' Term
forall t. Univ -> Integer -> Sort' t
Inf Univ
u (Integer -> Sort' Term) -> Integer -> Sort' Term
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
- Integer
1) Sort' Term
s2

          -- Anything else: postpone
          Sort' Term
_ -> TCMT IO ()
postpone


      -- Equate a sort @s@ to @piSort a s1 s2@
      -- Precondition: @s@ and @piSort a s1 s2@ are already reduced.
      piSortEquals :: Bool -> Sort -> Dom Term -> Sort -> Abs Sort -> Blocker -> TCM ()
      piSortEquals :: Bool
-> Sort' Term
-> Dom' Term Term
-> Sort' Term
-> Abs (Sort' Term)
-> Blocker
-> TCMT IO ()
piSortEquals Bool
propEnabled Sort' Term
s Dom' Term Term
a Sort' Term
s1 NoAbs{} Blocker
blocker = TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      piSortEquals Bool
propEnabled Sort' Term
s Dom' Term Term
a Sort' Term
s1 s2Abs :: Abs (Sort' Term)
s2Abs@(Abs [Char]
x Sort' Term
s2) Blocker
blocker = do
        let adom :: Dom' Term (Type'' Term Term)
adom = Sort' Term -> Term -> Type'' Term Term
forall t a. Sort' t -> a -> Type'' t a
El Sort' Term
s1 (Term -> Type'' Term Term)
-> Dom' Term Term -> Dom' Term (Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom' Term Term
a
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
35 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"piSortEquals"
          , TCMT IO Doc
"  s  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s
          , TCMT IO Doc
"  a  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom' Term (Type'' Term Term) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Dom' Term (Type'' Term Term) -> m Doc
prettyTCM Dom' Term (Type'' Term Term)
adom
          , TCMT IO Doc
"  s1 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s1
          , TCMT IO Doc
"  s2 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ([Char], Dom' Term (Type'' Term Term))
-> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
([Char], Dom' Term (Type'' Term Term)) -> m a -> m a
addContext ([Char]
x,Dom' Term (Type'' Term Term)
adom) (Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s2)
          ]
        let postpone :: TCMT IO ()
postpone = Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
blocker
           -- If @s2@ is dependent, then @piSort a s1 s2@ computes to
           -- @Setωi@. Hence, if @s@ is small, then @s2@
           -- cannot be dependent.
        if | Sort' Term -> Bool
isSmallSort Sort' Term
s -> do
               -- We force @s2@ to be non-dependent by unifying it with
               -- a fresh meta that does not depend on @x : a@
               s2' <- TCM (Sort' Term)
newSortMeta
               addContext (x , adom) $ equalSort s2 (raise 1 s2')
               funSortEquals propEnabled s s1 s2' blocker
           -- Otherwise: postpone
           | Bool
otherwise -> TCMT IO ()
postpone

      -- Equate a sort @s@ to @funSort s1 s2@
      -- Precondition: @s@ and @funSort s1 s2@ are already reduced
      funSortEquals :: Bool -> Sort -> Sort -> Sort -> Blocker -> TCM ()
      funSortEquals :: Bool
-> Sort' Term -> Sort' Term -> Sort' Term -> Blocker -> TCMT IO ()
funSortEquals Bool
propEnabled Sort' Term
s0 Sort' Term
s1 Sort' Term
s2 Blocker
blocker = do
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.sort" Nat
35 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"funSortEquals"
          , TCMT IO Doc
"  s0 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s0
          , TCMT IO Doc
"  s1 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s1
          , TCMT IO Doc
"  s2 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM Sort' Term
s2
          ]
        sizedTypesEnabled <- TCMT IO Bool
forall (m :: * -> *). HasOptions m => m Bool
sizedTypesOption
        cubicalEnabled <- isJust <$> cubicalOption
        levelUnivEnabled <- optLevelUniverse <$> pragmaOptions
        let postpone = Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
blocker
            err :: TCM ()
            err = Comparison -> Term -> Term -> CompareAs -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCError m, HasBuiltins m) =>
Comparison -> Term -> Term -> CompareAs -> m a
failConversion Comparison
CmpEq (Sort' Term -> Term
Sort Sort' Term
s0) (Sort' Term -> Term
Sort (Sort' Term -> Sort' Term -> Sort' Term
forall t. Sort' t -> Sort' t -> Sort' t
FunSort Sort' Term
s1 Sort' Term
s2)) CompareAs
AsTypes
        case s0 of
          -- If @Setωᵢ == funSort s1 s2@, then either @s1@ or @s2@ must
          -- be @Setωᵢ@.

          Inf Univ
u Integer
n ->
            case (Sort' Term -> Either Blocker SizeOfSort
sizeOfSort Sort' Term
s1, Sort' Term -> Either Blocker SizeOfSort
sizeOfSort Sort' Term
s2) of

              -- Both sorts have to be <= n in size, and their fibrancy <= u
              (Right (SizeOfSort Univ
u' Integer
n'), Either Blocker SizeOfSort
_)
                | Integer
n' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
n                           -> TCMT IO ()
err
                | Univ -> IsFibrant
univFibrancy Univ
u' IsFibrant -> IsFibrant -> Bool
forall a. Ord a => a -> a -> Bool
> Univ -> IsFibrant
univFibrancy Univ
u -> TCMT IO ()
err
              (Either Blocker SizeOfSort
_, Right (SizeOfSort Univ
u' Integer
n'))
                | Integer
n' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
n                           -> TCMT IO ()
err
                | Univ -> IsFibrant
univFibrancy Univ
u' IsFibrant -> IsFibrant -> Bool
forall a. Ord a => a -> a -> Bool
> Univ -> IsFibrant
univFibrancy Univ
u -> TCMT IO ()
err
              -- Unless SSet, the kind of the funSort is the kind of the codomain
                | Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
/= Univ
USSet, Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
/= Univ
u'              -> TCMT IO ()
err

              -- One sort has to be at least the same size as n
              (Right (SizeOfSort Univ
u1 Integer
n1), Right (SizeOfSort Univ
u2 Integer
n2))
                | Integer
n1 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
n, Integer
n2 Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
n                   -> TCMT IO ()
err
                | Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
/= Univ -> Univ -> Univ
funUniv Univ
u1 Univ
u2               -> TCMT IO ()
err

              -- If have the domain sort only
              (Right (SizeOfSort Univ
u' Integer
n'), Either Blocker SizeOfSort
_)
                | Univ
u' Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
/= Univ
USSet, Integer
n' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
n              -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s0 Sort' Term
s2
                | Bool
otherwise                        -> TCMT IO ()
postpone

              -- If we just have the codomain sort
              (Either Blocker SizeOfSort
_, Right (SizeOfSort Univ
USSet Integer
n'))     -> TCMT IO ()
postpone
              (Either Blocker SizeOfSort
_, Right (SizeOfSort Univ
_     Integer
n'))
                | Integer
n' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
n, Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
== Univ
USSet               -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
s1 Sort' Term
s2
                | Integer
n' Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
< Integer
n, Bool -> Bool
not Bool
propEnabled,
                  -- issue #6648: with --level-universe we have PTS rule (LevelUniv,Set,Setω)
                  Bool -> Bool
not Bool
levelUnivEnabled Bool -> Bool -> Bool
|| Integer
n Integer -> Integer -> Bool
forall a. Ord a => a -> a -> Bool
> Integer
0    -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort (Univ -> Integer -> Sort' Term
forall t. Univ -> Integer -> Sort' t
Inf Univ
UType Integer
n) Sort' Term
s1
                | Bool
otherwise                        -> TCMT IO ()
postpone

              (Either Blocker SizeOfSort, Either Blocker SizeOfSort)
_ -> TCMT IO ()
postpone

          -- If @Set l == funSort s1 s2@, then @s2@ must be of the
          -- form @Set l2@. @s1@ can be one of @Set l1@, @Prop l1@,
          -- @SizeUniv@, or @IUniv@.
          Type Level' Term
l -> do
            l2 <- Univ -> Sort' Term -> TCMT IO (Level' Term)
forceUniv Univ
UType Sort' Term
s2
            -- We must have @l2 =< l@, this might help us to solve
            -- more constraints (in particular when @l == 0@).
            leqLevel l2 l
            -- Jesper, 2022-10-22, #6211: the operations `forceUniv`
            -- and `leqLevel` above might have instantiated some
            -- metas, so we need to reduce s1 again to get an
            -- up-to-date Blocker.
            s1b <- reduceB s1
            let s1 = Blocked (Sort' Term) -> Sort' Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Sort' Term)
s1b
                blocker = Blocked (Sort' Term) -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked (Sort' Term)
s1b
            -- Jesper, 2019-12-27: SizeUniv is disabled at the moment.
            if | {- sizedTypesEnabled || -} propEnabled || cubicalEnabled -> do
                funSortM' s1 (Type l2) >>= \case
                   -- If the work we did makes the @funSort@ compute,
                   -- continue working.
                   Right Sort' Term
s -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort (Level' Term -> Sort' Term
forall t. Level' t -> Sort' t
Type Level' Term
l) Sort' Term
s
                   -- Otherwise: postpone
                   Left{}  -> Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
blocker
               -- If both Prop and sized types are disabled, only the
               -- case @s1 == Set l1@ remains.
               | otherwise -> do
                   l1 <- forceUniv UType s1
                   equalLevel l (levelLub l1 l2)

          -- If @Prop l == funSort s1 s2@, then @s2@ must be of the
          -- form @Prop l2@, and @s1@ can be one of @Set l1@, Prop
          -- l1@, or @SizeUniv@.
          Prop Level' Term
l -> do
            l2 <- Univ -> Sort' Term -> TCMT IO (Level' Term)
forceUniv Univ
UProp Sort' Term
s2
            leqLevel l2 l
            s1b <- reduceB s1
            let s1 = Blocked (Sort' Term) -> Sort' Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Sort' Term)
s1b
                blocker = Blocked (Sort' Term) -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked (Sort' Term)
s1b
            funSortM' s1 (Prop l2) >>= \case
                   -- If the work we did makes the @funSort@ compute,
                   -- continue working.
                   Right Sort' Term
s -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort (Level' Term -> Sort' Term
forall t. Level' t -> Sort' t
Prop Level' Term
l) Sort' Term
s
                   -- Otherwise: postpone
                   Left Blocker
b  -> Blocker -> TCMT IO ()
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation (Blocker -> Blocker -> Blocker
unblockOnEither Blocker
blocker Blocker
b)

          -- TODO: SSet l

          -- We have @SizeUniv == funSort s1 s2@ iff @s2 == SizeUniv@
          Sort' Term
SizeUniv -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
forall {t}. Sort' t
SizeUniv Sort' Term
s2
          Sort' Term
LevelUniv -> Sort' Term -> Sort' Term -> TCMT IO ()
equalSort Sort' Term
forall {t}. Sort' t
LevelUniv Sort' Term
s2
          -- Anything else: postpone
          Sort' Term
_        -> TCMT IO ()
postpone

      forceUniv :: Univ -> Sort -> TCM Level
      forceUniv :: Univ -> Sort' Term -> TCMT IO (Level' Term)
forceUniv Univ
u = \case
        Univ Univ
u' Level' Term
l | Univ
u Univ -> Univ -> Bool
forall a. Eq a => a -> a -> Bool
== Univ
u' -> Level' Term -> TCMT IO (Level' Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Level' Term
l
        Sort' Term
s -> do
          l <- TCMT IO (Level' Term)
newLevelMeta
          equalSort s (Univ u l)
          return l

      impossibleSort :: a -> m b
impossibleSort a
s = do
        [Char] -> Nat -> [a] -> m ()
forall a (m :: * -> *).
(ReportS a, MonadDebug m) =>
[Char] -> Nat -> a -> m ()
forall (m :: * -> *). MonadDebug m => [Char] -> Nat -> [a] -> m ()
reportS [Char]
"impossible" Nat
10
          [ a
"equalSort: found dummy sort with description:"
          , a
s
          ]
        m b
forall a. HasCallStack => a
__IMPOSSIBLE__

      catchInequalLevel :: m a -> m a -> m a
catchInequalLevel m a
m m a
fail = m a
m m a -> (TCErr -> m a) -> m a
forall a. m a -> (TCErr -> m a) -> m a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \case
        TypeError{} -> m a
fail
        TCErr
err         -> TCErr -> m a
forall a. TCErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err


forallFaceMaps :: Term -> (IntMap Bool -> Blocker -> Term -> TCM a)
               -> (IntMap Bool -> Substitution -> TCM a)
               -> TCM [a]
forallFaceMaps :: forall a.
Term
-> (IntMap Bool -> Blocker -> Term -> TCM a)
-> (IntMap Bool -> Substitution -> TCM a)
-> TCM [a]
forallFaceMaps Term
t IntMap Bool -> Blocker -> Term -> TCM a
kb IntMap Bool -> Substitution -> TCM a
k = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"conv.forall" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
      [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [TCMT IO Doc
"forallFaceMaps"
           , Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
t
           ]
  as <- Term -> TCMT IO [(IntMap Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(IntMap Bool, [Term])]
decomposeInterval Term
t
  boolToI <- do
    io <- primIOne
    iz <- primIZero
    return (\Bool
b -> if Bool
b then Term
io else Term
iz)
  forM as $ \ (IntMap Bool
ms,[Term]
ts) -> do
   [Term]
-> (Blocker -> Term -> TCM a)
-> (NotBlocked -> Term -> TCM a)
-> TCM a
forall {m :: * -> *} {t :: * -> *} {b}.
(HasBuiltins m, MonadError TCErr m, Foldable t, MonadReduce m) =>
t Term
-> (Blocker -> Term -> m b) -> (NotBlocked -> Term -> m b) -> m b
ifBlockeds [Term]
ts (IntMap Bool -> Blocker -> Term -> TCM a
kb IntMap Bool
ms) ((NotBlocked -> Term -> TCM a) -> TCM a)
-> (NotBlocked -> Term -> TCM a) -> TCM a
forall a b. (a -> b) -> a -> b
$ \ NotBlocked
_ Term
_ -> do
    let xs :: [(Nat, Term)]
xs = ((Nat, Bool) -> (Nat, Term)) -> [(Nat, Bool)] -> [(Nat, Term)]
forall a b. (a -> b) -> [a] -> [b]
map' ((Bool -> Term) -> (Nat, Bool) -> (Nat, Term)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second Bool -> Term
boolToI) ([(Nat, Bool)] -> [(Nat, Term)]) -> [(Nat, Bool)] -> [(Nat, Term)]
forall a b. (a -> b) -> a -> b
$ IntMap Bool -> [(Nat, Bool)]
forall a. IntMap a -> [(Nat, a)]
IntMap.toAscList IntMap Bool
ms
    cxt <- TCMT IO (Context' ContextEntry)
forall (m :: * -> *). MonadTCEnv m => m (Context' ContextEntry)
getContext
    reportSDoc "conv.forall" 20 $
      fsep ["substContextN"
           , prettyTCM cxt
           , prettyTCM xs
           ]
    (cxt',sigma) <- substContextN cxt xs
    resolved <- forM xs (\ (Nat
i,Term
t) -> (,) (ContextEntry -> Term -> (ContextEntry, Term))
-> TCMT IO ContextEntry -> TCMT IO (Term -> (ContextEntry, Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Nat -> TCMT IO ContextEntry
forall (m :: * -> *).
(MonadDebug m, MonadTCEnv m) =>
Nat -> m ContextEntry
lookupBV Nat
i TCMT IO (Term -> (ContextEntry, Term))
-> TCMT IO Term -> TCMT IO (ContextEntry, Term)
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg Term)
sigma Term
t))
    updateContext sigma (const cxt') $
      addBindings resolved $ do
        cl <- buildClosure ()
        tel <- getContextTelescope
        m <- currentModule
        sub <- getModuleParameterSub m
        reportSDoc "conv.forall" 30 $ vcat
          [ text (replicate 10 '-')
          , prettyTCM (view eCurrentModule $ clEnv cl)
          -- , prettyTCM (envLetBindings $ clEnv cl)
          , prettyTCM tel -- (toTelescope $ envContext $ clEnv cl)
          , prettyTCM sigma
          , prettyTCM m
          , prettyTCM sub
          ]
        cutConversionErrors $ k ms sigma
  where
    -- TODO Andrea: inefficient because we try to reduce the ts which we know are in whnf
    ifBlockeds :: t Term
-> (Blocker -> Term -> m b) -> (NotBlocked -> Term -> m b) -> m b
ifBlockeds t Term
ts Blocker -> Term -> m b
blocked NotBlocked -> Term -> m b
unblocked = do
      and <- PrimitiveId -> m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
PrimitiveId -> m Term
getPrimitiveTerm PrimitiveId
PrimIMin
      io  <- primIOne
      let t = (Term -> Term -> Term) -> Term -> t Term -> Term
forall a b. (a -> b -> b) -> b -> t a -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Term
x Term
r -> Term
and Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
x,Term -> Arg Term
forall e. e -> Arg e
argN Term
r]) Term
io t Term
ts
      ifBlocked t blocked unblocked
    addBindings :: [(ContextEntry, Term)] -> m a -> m a
addBindings [] m a
m = m a
m
    addBindings ((CtxVar Name
nm dom :: Dom' Term (Type'' Term Term)
dom@(Dom' Term (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> Type'' Term Term
ty),Term
t):[(ContextEntry, Term)]
bs) m a
m =
      ArgInfo -> Origin -> Name -> Term -> Type'' Term Term -> m a -> m a
forall (m :: * -> *) a.
MonadWarning m =>
ArgInfo -> Origin -> Name -> Term -> Type'' Term Term -> m a -> m a
addLetBinding (Dom' Term (Type'' Term Term)
dom Dom' Term (Type'' Term Term)
-> Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
-> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom' Term (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo) Origin
Inserted Name
nm Term
t Type'' Term Term
ty ([(ContextEntry, Term)] -> m a -> m a
addBindings [(ContextEntry, Term)]
bs m a
m)

    substContextN :: Context -> [(Int,Term)] -> TCM (Context , Substitution)
    substContextN :: Context' ContextEntry
-> [(Nat, Term)] -> TCM (Context' ContextEntry, Substitution)
substContextN Context' ContextEntry
c [] = (Context' ContextEntry, Substitution)
-> TCM (Context' ContextEntry, Substitution)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context' ContextEntry
c, Substitution
forall a. Substitution' a
idS)
    substContextN Context' ContextEntry
c ((Nat
i,Term
t):[(Nat, Term)]
xs) = do
      (c', sigma) <- Nat
-> Term
-> Context' ContextEntry
-> TCM (Context' ContextEntry, Substitution)
substContext Nat
i Term
t Context' ContextEntry
c
      (c'', sigma')  <- substContextN c' (map' (subtract 1 *** applySubst sigma) xs)
      return (c'', applySubst sigma' sigma)


    -- assumes the term can be typed in the shorter telescope
    -- the terms we get from toFaceMaps are closed.
    substContext :: Int -> Term -> Context -> TCM (Context , Substitution)
    substContext :: Nat
-> Term
-> Context' ContextEntry
-> TCM (Context' ContextEntry, Substitution)
substContext Nat
i Term
t Context' ContextEntry
CxEmpty = TCM (Context' ContextEntry, Substitution)
forall a. HasCallStack => a
__IMPOSSIBLE__
    substContext Nat
i Term
t (CxExtend ContextEntry
x Context' ContextEntry
xs) | Nat
i Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0 = (Context' ContextEntry, Substitution)
-> TCM (Context' ContextEntry, Substitution)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Context' ContextEntry, Substitution)
 -> TCM (Context' ContextEntry, Substitution))
-> (Context' ContextEntry, Substitution)
-> TCM (Context' ContextEntry, Substitution)
forall a b. (a -> b) -> a -> b
$ (Context' ContextEntry
xs , Nat -> Term -> Substitution
forall a. DeBruijn a => Nat -> a -> Substitution' a
singletonS Nat
0 Term
t)
    substContext Nat
i Term
t (CxExtend ContextEntry
x Context' ContextEntry
xs) | Nat
i Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
0 = do
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"conv.forall" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep [TCMT IO Doc
"substContext"
            , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text (Nat -> [Char]
forall a. Show a => a -> [Char]
show (Nat
iNat -> Nat -> Nat
forall a. Num a => a -> a -> a
-Nat
1))
            , Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
t
            , Context' ContextEntry -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Context' ContextEntry -> m Doc
prettyTCM Context' ContextEntry
xs
            ]
      (c,sigma) <- Nat
-> Term
-> Context' ContextEntry
-> TCM (Context' ContextEntry, Substitution)
substContext (Nat
iNat -> Nat -> Nat
forall a. Num a => a -> a -> a
-Nat
1) Term
t Context' ContextEntry
xs
      let e = Substitution' (SubstArg ContextEntry)
-> ContextEntry -> ContextEntry
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg ContextEntry)
sigma ContextEntry
x
      return (CxExtend e c, liftS 1 sigma)
    substContext Nat
i Term
t (CxExtend ContextEntry
x Context' ContextEntry
xs) = TCM (Context' ContextEntry, Substitution)
forall a. HasCallStack => a
__IMPOSSIBLE__

compareInterval :: Comparison -> Type -> Term -> Term -> TCM ()
compareInterval :: Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareInterval Comparison
cmp Type'' Term Term
i Term
t Term
u = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.interval" Nat
15 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"{ compareInterval" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
t TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"=" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
u ]
  ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare at interval type"
  tb <- Term -> TCMT IO (Blocked Term)
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Term
t
  ub <- reduceB u
  let t = Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
tb
      u = Blocked Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Term
ub
  it <- decomposeInterval' t
  iu <- decomposeInterval' u
  case () of
    ()
_ | Blocked Term -> Bool
forall {t} {a}. Blocked' t a -> Bool
isBlocked Blocked Term
tb Bool -> Bool -> Bool
|| Blocked Term -> Bool
forall {t} {a}. Blocked' t a -> Bool
isBlocked Blocked Term
ub -> do
      -- in case of metas we wouldn't be able to make progress by how we deal with de morgan laws.
      -- (because the constraints generated by decomposition are sufficient but not necessary).
      -- but we could still prune/solve some metas by comparing the terms as atoms.
      -- also if blocked we won't find the terms conclusively unequal(?) so compareAtom
      -- won't report type errors when we should accept.
      interval <- TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m (Type'' Term Term)
primIntervalType
      compareAtom CmpEq (AsTermsOf interval) t u
    ()
_ | Bool
otherwise -> do
      x <- [(IntMap BoolSet, [Term])]
-> [(IntMap BoolSet, [Term])] -> TCMT IO Bool
leqInterval [(IntMap BoolSet, [Term])]
it [(IntMap BoolSet, [Term])]
iu
      y <- leqInterval iu it
      let final = [(IntMap BoolSet, [Term])] -> Bool
isCanonical [(IntMap BoolSet, [Term])]
it Bool -> Bool -> Bool
&& [(IntMap BoolSet, [Term])] -> Bool
isCanonical [(IntMap BoolSet, [Term])]
iu
      if x && y then reportSDoc "tc.conv.interval" 15 $ "Ok! }" else
        if final then failConversion cmp t u (AsTermsOf i)
                 else do
                   reportSDoc "tc.conv.interval" 15 $ "Giving up! }"
                   patternViolation (unblockOnAnyMetaIn (t, u))
 where
   isBlocked :: Blocked' t a -> Bool
isBlocked Blocked{}    = Bool
True
   isBlocked NotBlocked{} = Bool
False


type Conj = (IntMap BoolSet, [Term])

isCanonical :: [Conj] -> Bool
isCanonical :: [(IntMap BoolSet, [Term])] -> Bool
isCanonical = ((IntMap BoolSet, [Term]) -> Bool)
-> [(IntMap BoolSet, [Term])] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ([Term] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null ([Term] -> Bool)
-> ((IntMap BoolSet, [Term]) -> [Term])
-> (IntMap BoolSet, [Term])
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (IntMap BoolSet, [Term]) -> [Term]
forall a b. (a, b) -> b
snd)

-- | leqInterval r q = r ≤ q in the I lattice.
-- (∨ r_i) ≤ (∨ q_j)  iff  ∀ i. ∃ j. r_i ≤ q_j
leqInterval :: [Conj] -> [Conj] -> TCM Bool
leqInterval :: [(IntMap BoolSet, [Term])]
-> [(IntMap BoolSet, [Term])] -> TCMT IO Bool
leqInterval [(IntMap BoolSet, [Term])]
r [(IntMap BoolSet, [Term])]
q =
  [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> TCMT IO [Bool] -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(IntMap BoolSet, [Term])]
-> ((IntMap BoolSet, [Term]) -> TCMT IO Bool) -> TCMT IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(IntMap BoolSet, [Term])]
r (\ (IntMap BoolSet, [Term])
r_i ->
   [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> TCMT IO [Bool] -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [(IntMap BoolSet, [Term])]
-> ((IntMap BoolSet, [Term]) -> TCMT IO Bool) -> TCMT IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(IntMap BoolSet, [Term])]
q (\ (IntMap BoolSet, [Term])
q_j -> (IntMap BoolSet, [Term])
-> (IntMap BoolSet, [Term]) -> TCMT IO Bool
leqConj (IntMap BoolSet, [Term])
r_i (IntMap BoolSet, [Term])
q_j))  -- TODO shortcut

-- | leqConj r q = r ≤ q in the I lattice, when r and q are conjuctions.
-- ' (∧ r_i)   ≤ (∧ q_j)               iff
-- ' (∧ r_i)   ∧ (∧ q_j)   = (∧ r_i)   iff
-- ' {r_i | i} ∪ {q_j | j} = {r_i | i} iff
-- ' {q_j | j} ⊆ {r_i | i}
leqConj :: Conj -> Conj -> TCM Bool
leqConj :: (IntMap BoolSet, [Term])
-> (IntMap BoolSet, [Term]) -> TCMT IO Bool
leqConj (IntMap BoolSet
rs, [Term]
rst) (IntMap BoolSet
qs, [Term]
qst) = do
  if (BoolSet -> BoolSet -> Bool)
-> IntMap BoolSet -> IntMap BoolSet -> Bool
forall a b. (a -> b -> Bool) -> IntMap a -> IntMap b -> Bool
IntMap.isSubmapOfBy BoolSet -> BoolSet -> Bool
BoolSet.isSubsetOf IntMap BoolSet
qs IntMap BoolSet
rs
    then do
      interval <-
        Sort' Term -> Term -> Type'' Term Term
forall t a. Sort' t -> a -> Type'' t a
El Sort' Term
forall {t}. Sort' t
IntervalUniv (Term -> Type'' Term Term)
-> (Maybe Term -> Term) -> Maybe Term -> Type'' Term Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Type'' Term Term)
-> TCMT IO (Maybe Term) -> TCMT IO (Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuiltinId -> TCMT IO (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
builtinInterval
      -- we don't want to generate new constraints here because
      -- 1. in some situations the same constraint would get generated twice.
      -- 2. unless things are completely accepted we are going to
      --    throw patternViolation in compareInterval.
      let eqT Term
t Term
u = TCMT IO () -> TCMT IO Bool
tryConversion (Comparison -> CompareAs -> Term -> Term -> TCMT IO ()
compareAtom Comparison
CmpEq (Type'' Term Term -> CompareAs
AsTermsOf Type'' Term Term
interval) Term
t Term
u)
      let listSubset [Term]
ts [Term]
us =
            [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and ([Bool] -> Bool) -> TCMT IO [Bool] -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term] -> (Term -> TCMT IO Bool) -> TCMT IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Term]
ts (\Term
t -> [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or ([Bool] -> Bool) -> TCMT IO [Bool] -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Term] -> (Term -> TCMT IO Bool) -> TCMT IO [Bool]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Term]
us (\Term
u -> Term -> Term -> TCMT IO Bool
eqT Term
t Term
u)) -- TODO shortcut
      listSubset qst rst
    else
      Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | equalTermOnFace φ A u v = _ , φ ⊢ u = v : A
equalTermOnFace :: Term -> Type -> Term -> Term -> TCM ()
equalTermOnFace :: Term -> Type'' Term Term -> Term -> Term -> TCMT IO ()
equalTermOnFace = Comparison
-> Term -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTermOnFace Comparison
CmpEq

compareTermOnFace :: Comparison -> Term -> Type -> Term -> Term -> TCM ()
compareTermOnFace :: Comparison
-> Term -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTermOnFace = (Substitution
 -> Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ())
-> Comparison
-> Term
-> Type'' Term Term
-> Term
-> Term
-> TCMT IO ()
compareTermOnFace' ((Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ())
-> Substitution
-> Comparison
-> Type'' Term Term
-> Term
-> Term
-> TCMT IO ()
forall a b. a -> b -> a
const Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
compareTerm)

compareTermOnFace' ::
     (Substitution -> Comparison -> Type -> Term -> Term -> TCM ())
  -> Comparison -> Term -> Type -> Term -> Term -> TCM ()
compareTermOnFace' :: (Substitution
 -> Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ())
-> Comparison
-> Term
-> Type'' Term Term
-> Term
-> Term
-> TCMT IO ()
compareTermOnFace' Substitution
-> Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
k Comparison
cmp Term
phi Type'' Term Term
ty Term
u Term
v = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.conv.face" Nat
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"compareTermOnFace:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
phi TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"|-" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
u TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"==" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
":" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type'' Term Term
ty
  ProfileOption -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => ProfileOption -> m () -> m ()
whenProfile ProfileOption
Profile.Conversion (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO ()
forall (m :: * -> *). MonadStatistics m => [Char] -> m ()
tick [Char]
"compare at face type"

  phi <- Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
phi
  _ <- forallFaceMaps phi postponed $ \ IntMap Bool
faces Substitution
alpha ->
    Substitution
-> Comparison -> Type'' Term Term -> Term -> Term -> TCMT IO ()
k Substitution
alpha Comparison
cmp (Substitution' (SubstArg (Type'' Term Term))
-> Type'' Term Term -> Type'' Term Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg (Type'' Term Term))
alpha Type'' Term Term
ty) (Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg Term)
alpha Term
u) (Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg Term)
alpha Term
v)
  return ()
 where
  postponed :: IntMap Bool -> Blocker -> Term -> TCMT IO ()
postponed IntMap Bool
ms Blocker
blocker Term
psi = do
    phi <- [[Char]] -> NamesT (TCMT IO) Term -> TCMT IO Term
forall (m :: * -> *) a. [[Char]] -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Term -> TCMT IO Term)
-> NamesT (TCMT IO) Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ do
             imin <- TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl (TCMT IO Term -> NamesT (TCMT IO) Term)
-> TCMT IO Term -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ PrimitiveId -> TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
PrimitiveId -> m Term
getPrimitiveTerm PrimitiveId
PrimIMin
             ineg <- cl $ getPrimitiveTerm PrimINeg
             psi <- open psi
             let phi = ((Nat, Bool) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term -> [(Nat, Bool)] -> NamesT (TCMT IO) Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ (Nat
i,Bool
b) NamesT (TCMT IO) Term
r -> do i <- Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Nat -> Term
var Nat
i); pure imin <@> (if b then i else pure ineg <@> i) <@> r)
                          NamesT (TCMT IO) Term
psi (IntMap Bool -> [(Nat, Bool)]
forall a. IntMap a -> [(Nat, a)]
IntMap.toList IntMap Bool
ms) -- TODO Andrea: make a view?
             phi
    addConstraint blocker (ValueCmpOnFace cmp phi ty u v)

---------------------------------------------------------------------------
-- * Definitions
---------------------------------------------------------------------------

bothAbsurd :: QName -> QName -> TCM Bool
bothAbsurd :: QName -> QName -> TCMT IO Bool
bothAbsurd QName
f QName
f'
  | QName -> Bool
isAbsurdLambdaName QName
f, QName -> Bool
isAbsurdLambdaName QName
f' = do
      -- Double check we are really dealing with absurd lambdas:
      -- Their functions should not have bodies.
      def  <- QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
f
      def' <- getConstInfo f'
      case (theDef def, theDef def') of
        (Function{ funClauses :: Defn -> [Clause]
funClauses = [Clause{ clauseBody :: Clause -> Maybe Term
clauseBody = Maybe Term
Nothing }] },
         Function{ funClauses :: Defn -> [Clause]
funClauses = [Clause{ clauseBody :: Clause -> Maybe Term
clauseBody = Maybe Term
Nothing }] }) -> Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
        (Defn, Defn)
_ -> Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
  | Bool
otherwise = Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False