{-# LANGUAGE NondecreasingIndentation #-}

-- | Solving size constraints under hypotheses.
--
-- The size solver proceeds as follows:
--
-- 1. Get size constraints, cluster into connected components.
--
--    All size constraints that mention the same metas go into the same
--    cluster.  Each cluster can be solved by itself.
--
--    Constraints that do not fit our format are ignored.
--    We check whether our computed solution fulfills them as well
--    in the last step.
--
-- 2. Find a joint context for each cluster.
--
--    Each constraint comes with its own typing context, which
--    contains size hypotheses @j : Size< i@.  We need to find a
--    common super context in which all constraints of a cluster live,
--    and raise all constraints to this context.
--
--    There might not be a common super context.  Then we are screwed,
--    since our solver is not ready to deal with such a situation.  We
--    will blatantly refuse to solve this cluster and blame it on the
--    user.
--
-- 3. Convert the joint context into a hypothesis graph.
--
--    This is straightforward.  Each de Bruijn index becomes a
--    rigid variable, each typing assumption @j : Size< i@ becomes an
--    arc.
--
-- 4. Convert the constraints into a constraint graph.
--
--    Here we need to convert @MetaV@s into flexible variables.
--
-- 5. Run the solver
--
-- 6. Convert the solution into meta instantiations.
--
-- 7. Double-check whether the constraints are solved.

-- Opportunities for optimization:
--
-- - NamedRigids has some cost to retrieve variable names
--   just for the sake of debug printing.

module Agda.TypeChecking.SizedTypes.Solve where

import Prelude hiding (null)

import Control.Monad hiding (forM, forM_)
import Control.Monad.Except
import Control.Monad.Trans.Maybe

import Data.Either
import Data.Foldable (forM_)
import qualified Data.Foldable as Fold
import Data.Function
import qualified Data.IntSet as IntSet
import qualified Data.List as List
import Data.Monoid
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Traversable (forM)

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

import Agda.TypeChecking.Monad as TCM hiding (Offset)
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Free
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Constraints as C

import qualified Agda.TypeChecking.SizedTypes as S
import Agda.TypeChecking.SizedTypes.Syntax as Size
import Agda.TypeChecking.SizedTypes.Utils
import Agda.TypeChecking.SizedTypes.WarshallSolver as Size

import Agda.Utils.Cluster
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List1 (List1, pattern (:|), nonEmpty, (<|))
import qualified Agda.Utils.List as List
import qualified Agda.Utils.List1 as List1
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Pretty (Pretty, prettyShow)
import qualified Agda.Utils.Pretty as P
import Agda.Utils.Singleton
import Agda.Utils.Size
import qualified Agda.Utils.VarSet as VarSet

import Agda.Utils.Impossible

type CC = ProblemConstraint

-- | Flag to control the behavior of size solver.
data DefaultToInfty
  = DefaultToInfty      -- ^ Instantiate all unconstrained size variables to ∞.
  | DontDefaultToInfty  -- ^ Leave unconstrained size variables unsolved.
  deriving (DefaultToInfty -> DefaultToInfty -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: DefaultToInfty -> DefaultToInfty -> Bool
$c/= :: DefaultToInfty -> DefaultToInfty -> Bool
== :: DefaultToInfty -> DefaultToInfty -> Bool
$c== :: DefaultToInfty -> DefaultToInfty -> Bool
Eq, Eq DefaultToInfty
DefaultToInfty -> DefaultToInfty -> Bool
DefaultToInfty -> DefaultToInfty -> Ordering
DefaultToInfty -> DefaultToInfty -> DefaultToInfty
forall a.
Eq a
-> (a -> a -> Ordering)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> Bool)
-> (a -> a -> a)
-> (a -> a -> a)
-> Ord a
min :: DefaultToInfty -> DefaultToInfty -> DefaultToInfty
$cmin :: DefaultToInfty -> DefaultToInfty -> DefaultToInfty
max :: DefaultToInfty -> DefaultToInfty -> DefaultToInfty
$cmax :: DefaultToInfty -> DefaultToInfty -> DefaultToInfty
>= :: DefaultToInfty -> DefaultToInfty -> Bool
$c>= :: DefaultToInfty -> DefaultToInfty -> Bool
> :: DefaultToInfty -> DefaultToInfty -> Bool
$c> :: DefaultToInfty -> DefaultToInfty -> Bool
<= :: DefaultToInfty -> DefaultToInfty -> Bool
$c<= :: DefaultToInfty -> DefaultToInfty -> Bool
< :: DefaultToInfty -> DefaultToInfty -> Bool
$c< :: DefaultToInfty -> DefaultToInfty -> Bool
compare :: DefaultToInfty -> DefaultToInfty -> Ordering
$ccompare :: DefaultToInfty -> DefaultToInfty -> Ordering
Ord, Int -> DefaultToInfty -> ShowS
[DefaultToInfty] -> ShowS
DefaultToInfty -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [DefaultToInfty] -> ShowS
$cshowList :: [DefaultToInfty] -> ShowS
show :: DefaultToInfty -> String
$cshow :: DefaultToInfty -> String
showsPrec :: Int -> DefaultToInfty -> ShowS
$cshowsPrec :: Int -> DefaultToInfty -> ShowS
Show)

-- | Solve size constraints involving hypotheses.

solveSizeConstraints :: DefaultToInfty -> TCM ()
solveSizeConstraints :: DefaultToInfty -> TCM ()
solveSizeConstraints DefaultToInfty
flag =  do

  -- 1. Take out the size constraints normalised.

  let norm :: ProblemConstraint -> m ProblemConstraint
norm ProblemConstraint
c = forall (m :: * -> *) a b.
(MonadTCEnv m, ReadTCState m) =>
(a -> m b) -> Closure a -> m (Closure b)
mapClosure forall a (m :: * -> *). (Normalise a, MonadReduce m) => a -> m a
normalise (ProblemConstraint -> Closure Constraint
theConstraint ProblemConstraint
c) forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> \ Closure Constraint
cl -> ProblemConstraint
c { theConstraint :: Closure Constraint
theConstraint = Closure Constraint
cl }
  [ProblemConstraint]
cs0 <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *}.
MonadReduce m =>
ProblemConstraint -> m ProblemConstraint
norm forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Comparison -> Bool) -> TCMT IO [ProblemConstraint]
S.takeSizeConstraints (forall a. Eq a => a -> a -> Bool
== Comparison
CmpLeq)
    -- NOTE: this deletes the size constraints from the constraint set!
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Null a => a -> Bool
null [ProblemConstraint]
cs0) forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
40 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *). Applicative m => String -> m Doc
text ( String
"Solving constraints (" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show DefaultToInfty
flag forall a. [a] -> [a] -> [a]
++ String
")" ) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [ProblemConstraint]
cs0
  let -- Error for giving up
      cannotSolve :: TCM a -- Defined, but not currently used
      cannotSolve :: forall a. TCM a
cannotSolve = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat (TCMT IO Doc
"Cannot solve size constraints" forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [ProblemConstraint]
cs0)

  -- 2. Cluster the constraints by common size metas.

  -- Get all size metas.
  Set MetaId
sizeMetaSet <- forall a. Ord a => [a] -> Set a
Set.fromList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (\ (MetaId
x, Type
_t, Tele (Dom Type)
_tel) -> MetaId
x) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> TCM [(MetaId, Type, Tele (Dom Type))]
S.getSizeMetas Bool
True

  -- Pair each constraint with its list of size metas occurring in it.
  [(ProblemConstraint, [MetaId])]
cms <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ProblemConstraint]
cs0 forall a b. (a -> b) -> a -> b
$ \ ProblemConstraint
cl -> forall (m :: * -> *) a c b.
(MonadTCEnv m, ReadTCState m, LensClosure a c) =>
c -> (a -> m b) -> m b
enterClosure (ProblemConstraint -> Closure Constraint
theConstraint ProblemConstraint
cl) forall a b. (a -> b) -> a -> b
$ \ Constraint
c -> do

    -- @allMetas@ does not reduce or instantiate;
    -- this is why we require the size constraints to be normalised.
    forall (m :: * -> *) a. Monad m => a -> m a
return (ProblemConstraint
cl, forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$
      Set MetaId
sizeMetaSet forall a. Ord a => Set a -> Set a -> Set a
`Set.intersection` forall t m. (AllMetas t, Monoid m) => (MetaId -> m) -> t -> m
allMetas forall el coll. Singleton el coll => el -> coll
singleton Constraint
c)

  -- Now, some constraints may have no metas (clcs), the others have at least one (othercs).
  let classify :: (a, [b]) -> Either a (a, List1 b)
      classify :: forall a b. (a, [b]) -> Either a (a, List1 b)
classify (a
cl, [])     = forall a b. a -> Either a b
Left  a
cl
      classify (a
cl, (b
x:[b]
xs)) = forall a b. b -> Either a b
Right (a
cl, b
x forall a. a -> [a] -> NonEmpty a
:| [b]
xs)
  let ([ProblemConstraint]
clcs, [(ProblemConstraint, List1 MetaId)]
othercs) = forall a b. [Either a b] -> ([a], [b])
partitionEithers forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, [b]) -> Either a (a, List1 b)
classify [(ProblemConstraint, [MetaId])]
cms

  -- We cluster the constraints by their metas.
  let ccs :: [NonEmpty ProblemConstraint]
ccs = forall c a. Ord c => [(a, NonEmpty c)] -> [NonEmpty a]
cluster' [(ProblemConstraint, List1 MetaId)]
othercs

  -- 3. Solve each cluster

  -- Solve the closed constraints, one by one.

  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProblemConstraint]
clcs forall a b. (a -> b) -> a -> b
$ \ ProblemConstraint
c -> () forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ DefaultToInfty -> [ProblemConstraint] -> TCMT IO (Set MetaId)
solveSizeConstraints_ DefaultToInfty
flag [ProblemConstraint
c]

  -- Solve the clusters.

  Set MetaId
constrainedMetas <- forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM  ([NonEmpty ProblemConstraint]
ccs) forall a b. (a -> b) -> a -> b
$ \ (NonEmpty ProblemConstraint
cs :: List1 CC) -> do

      forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
60 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"size constraint cluster:" forall a. a -> NonEmpty a -> NonEmpty a
<| forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (m :: * -> *). Applicative m => String -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> String
show) NonEmpty ProblemConstraint
cs

      -- Convert each constraint in the cluster to the largest context.
      -- (Keep fingers crossed).

      forall (m :: * -> *) a c b.
(MonadTCEnv m, ReadTCState m, LensClosure a c) =>
c -> (a -> m b) -> m b
enterClosure (forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
Fold.maximumBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCEnv -> Context
envContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Closure a -> TCEnv
clEnv)) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ProblemConstraint -> Closure Constraint
theConstraint NonEmpty ProblemConstraint
cs) forall a b. (a -> b) -> a -> b
$ \ Constraint
_ -> do
        -- Get all constraints that can be cast to the longest context.
        [ProblemConstraint]
cs' :: [ProblemConstraint] <- forall a. List1 (Maybe a) -> [a]
List1.catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProblemConstraint -> MaybeT (TCMT IO) ProblemConstraint
castConstraintToCurrentContext) NonEmpty ProblemConstraint
cs

        forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
          ( TCMT IO Doc
"converted size constraints to context: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do
              Tele (Dom Type)
tel <- forall (m :: * -> *).
(Applicative m, MonadTCEnv m) =>
m (Tele (Dom Type))
getContextTelescope
              forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Tele (Dom Type)
tel
          ) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM) [ProblemConstraint]
cs'

        -- Solve the converted constraints.
        DefaultToInfty -> [ProblemConstraint] -> TCMT IO (Set MetaId)
solveSizeConstraints_ DefaultToInfty
flag [ProblemConstraint]
cs'

  -- 4. Possibly set remaining metas to infinity.

  -- Andreas, issue 1862: do not default to ∞ always, could be too early.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (DefaultToInfty
flag forall a. Eq a => a -> a -> Bool
== DefaultToInfty
DefaultToInfty) forall a b. (a -> b) -> a -> b
$ do

    -- let constrainedMetas = Set.fromList $ concat $
    --       for cs0 $ \ Closure{ clValue = ValueCmp _ _ u v } ->
    --         allMetas u ++ allMetas v

    -- Set the unconstrained, open size metas to ∞.
    [(MetaId, Type, Tele (Dom Type))]
ms <- Bool -> TCM [(MetaId, Type, Tele (Dom Type))]
S.getSizeMetas Bool
False -- do not get interaction metas
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Null a => a -> Bool
null [(MetaId, Type, Tele (Dom Type))]
ms) forall a b. (a -> b) -> a -> b
$ do
      Term
inf <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSizeInf
      forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [(MetaId, Type, Tele (Dom Type))]
ms forall a b. (a -> b) -> a -> b
$ \ (MetaId
m, Type
t, Tele (Dom Type)
tel) -> do
        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (MetaId
m forall a. Ord a => a -> Set a -> Bool
`Set.member` Set MetaId
constrainedMetas) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m Bool
isFrozen MetaId
m) forall a b. (a -> b) -> a -> b
$ do
        forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
20 forall a b. (a -> b) -> a -> b
$
          TCMT IO Doc
"solution " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (MetaId -> Elims -> Term
MetaV MetaId
m []) forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>
          TCMT IO Doc
" := "      forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
inf
        Int -> MetaId -> Type -> [Int] -> Term -> TCM ()
assignMeta Int
0 MetaId
m Type
t (forall a. Integral a => a -> [a]
List.downFrom forall a b. (a -> b) -> a -> b
$ forall a. Sized a => a -> Int
size Tele (Dom Type)
tel) Term
inf

  -- -- Double check.
  -- unless (null cs0 && null ms) $ do
  --   flip catchError (const cannotSolve) $
  --     noConstraints $
  --       forM_ cs0 $ \ cl -> enterClosure cl solveConstraint

  -- 5. Make sure we did not lose any constraints.

  -- This is necessary since we have removed the size constraints.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProblemConstraint]
cs0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadConstraint m =>
(Constraint -> m a) -> ProblemConstraint -> m a
withConstraint forall (m :: * -> *). MonadConstraint m => Constraint -> m ()
solveConstraint


-- | TODO: this does not actually work!
--
--   We would like to use a constraint @c@ created in context @Δ@ from module @N@
--   in the current context @Γ@ and current module @M@.
--
--   @Δ@ is module tel @Δ₁@ of @N@ extended by some local bindings @Δ₂@.
--   @Γ@ is the current context.
--   The module parameter substitution from current @M@ to @N@ be
--   @Γ ⊢ σ : Δ₁@.
--
--   If @M == N@, we do not need the parameter substitution.  We try raising.
--
--   We first strengthen @Δ ⊢ c@ to live in @Δ₁@ and obtain @c₁ = strengthen Δ₂ c@.
--   We then transport @c₁@ to @Γ@ and obtain @c₂ = applySubst σ c₁@.
--
--   This works for different modules, but if @M == N@ we should not strengthen
--   and then weaken, because strengthening is a partial operation.
--   We should rather lift the substitution @σ@ by @Δ₂@ and then
--   raise by @Γ₂ - Δ₂@.
--   This "raising" might be a strengthening if @Γ₂@ is shorter than @Δ₂@.
--
--   (TODO: If the module substitution does not exist, because @N@ is not
--   a parent of @M@, we cannot use the constraint, as it has been created
--   in an unrelated context.)

castConstraintToCurrentContext' :: Closure TCM.Constraint -> MaybeT TCM TCM.Constraint
castConstraintToCurrentContext' :: Closure Constraint -> MaybeT (TCMT IO) Constraint
castConstraintToCurrentContext' Closure Constraint
cl = do
  let modN :: ModuleName
modN  = TCEnv -> ModuleName
envCurrentModule forall a b. (a -> b) -> a -> b
$ forall a. Closure a -> TCEnv
clEnv Closure Constraint
cl
      delta :: Context
delta = TCEnv -> Context
envContext forall a b. (a -> b) -> a -> b
$ forall a. Closure a -> TCEnv
clEnv Closure Constraint
cl
  -- The module telescope of the constraint.
  -- The constraint could come from the module telescope of the top level module.
  -- In this case, it does not live in any module!
  -- Thus, getSection can return Nothing.
  Tele (Dom Type)
delta1 <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Null a => a
empty (forall o i. o -> Lens' i o -> i
^. Lens' (Tele (Dom Type)) Section
secTelescope) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(Functor m, ReadTCState m) =>
ModuleName -> m (Maybe Section)
getSection ModuleName
modN
  -- The number of locals of the constraint.
  let delta2 :: Int
delta2 = forall a. Sized a => a -> Int
size Context
delta forall a. Num a => a -> a -> a
- forall a. Sized a => a -> Int
size Tele (Dom Type)
delta1
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
delta2 forall a. Ord a => a -> a -> Bool
>= Int
0) forall a. HasCallStack => a
__IMPOSSIBLE__

  -- The current module M and context Γ.
  ModuleName
modM  <- forall (m :: * -> *). MonadTCEnv m => m ModuleName
currentModule
  Int
gamma <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Int
getContextSize
  -- The current module telescope.
  -- Could also be empty, if we are in the front matter or telescope of the top-level module.
  Tele (Dom Type)
gamma1 <-forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. Null a => a
empty (forall o i. o -> Lens' i o -> i
^. Lens' (Tele (Dom Type)) Section
secTelescope) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(Functor m, ReadTCState m) =>
ModuleName -> m (Maybe Section)
getSection ModuleName
modM
  -- The current locals.
  let gamma2 :: Int
gamma2 = Int
gamma forall a. Num a => a -> a -> a
- forall a. Sized a => a -> Int
size Tele (Dom Type)
gamma1

  -- Γ ⊢ σ : Δ₁
  Substitution' Term
sigma <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. Substitution' a
idS forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadTCEnv m, ReadTCState m) =>
ModuleName -> m (Maybe (Substitution' Term))
getModuleParameterSub ModuleName
modN

  -- Debug printing.
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.constr.cast" Int
40 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"casting constraint" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
$$ do
    Tele (Dom Type)
tel <- forall (m :: * -> *).
(Applicative m, MonadTCEnv m) =>
m (Tele (Dom Type))
getContextTelescope
    forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
      [ TCMT IO Doc
"current module                = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ModuleName
modM
      , TCMT IO Doc
"current module telescope      = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Tele (Dom Type)
gamma1
      , TCMT IO Doc
"current context               = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Tele (Dom Type)
tel
      , TCMT IO Doc
"constraint module             = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ModuleName
modN
      , TCMT IO Doc
"constraint module telescope   = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Tele (Dom Type)
delta1
      , TCMT IO Doc
"constraint context            = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a c b.
(MonadTCEnv m, ReadTCState m, LensClosure a c) =>
c -> (a -> m b) -> m b
enterClosure Closure Constraint
cl (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(Applicative m, MonadTCEnv m) =>
m (Tele (Dom Type))
getContextTelescope))
      , TCMT IO Doc
"constraint                    = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a c b.
(MonadTCEnv m, ReadTCState m, LensClosure a c) =>
c -> (a -> m b) -> m b
enterClosure Closure Constraint
cl forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM
      , TCMT IO Doc
"module parameter substitution = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Substitution' Term
sigma
      ]

  -- If gamma2 < 0, we must be in the wrong context.
  -- E.g. we could have switched to the empty context even though
  -- we are still inside a module with parameters.
  -- In this case, we cannot safely convert the constraint,
  -- since the module parameter substitution may be wrong.
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard (Int
gamma2 forall a. Ord a => a -> a -> Bool
>= Int
0)

  -- Shortcut for modN == modM:
  -- Raise constraint from Δ to Γ, if possible.
  -- This might save us some strengthening.
  if ModuleName
modN forall a. Eq a => a -> a -> Bool
== ModuleName
modM then forall {m :: * -> *} {b}.
(Monad m, Alternative m, Free b, Subst b) =>
Int -> b -> m b
raiseMaybe (Int
gamma forall a. Num a => a -> a -> a
- forall a. Sized a => a -> Int
size Context
delta) forall a b. (a -> b) -> a -> b
$ forall a. Closure a -> a
clValue Closure Constraint
cl else do

  -- Strengthen constraint to Δ₁ ⊢ c
  Constraint
c <- forall {m :: * -> *} {b}.
(Monad m, Alternative m, Free b, Subst b) =>
Int -> b -> m b
raiseMaybe (-Int
delta2) forall a b. (a -> b) -> a -> b
$ forall a. Closure a -> a
clValue Closure Constraint
cl

  -- Ulf, 2016-11-09: I don't understand what this function does when M and N
  -- are not related. Certainly things can go terribly wrong (see
  -- test/Succeed/Issue2223b.agda)
  Int
fv <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(Functor m, Applicative m, MonadTCEnv m, ReadTCState m) =>
ModuleName -> m Int
getModuleFreeVars ModuleName
modN
  forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ Int
fv forall a. Eq a => a -> a -> Bool
== forall a. Sized a => a -> Int
size Tele (Dom Type)
delta1

  -- Γ ⊢ c[σ]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' Term
sigma Constraint
c
  where
    raiseMaybe :: Int -> b -> m b
raiseMaybe Int
n b
c = do
      -- Fine if we have to weaken or strengthening is safe.
      forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$
        Int
n forall a. Ord a => a -> a -> Bool
>= Int
0 Bool -> Bool -> Bool
||
        -- Are all free variables at least -n?
        IntSet -> Bool
IntSet.null (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Int -> IntSet -> (IntSet, IntSet)
IntSet.split (-Int
n) forall a b. (a -> b) -> a -> b
$ forall t. Free t => t -> IntSet
allFreeVars b
c)
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Int -> a -> a
raise Int
n b
c


-- | A hazardous hack, may the Gods have mercy on us.
--
--   To cast to the current context, we match the context of the
--   given constraint by 'CtxId', and as fallback, by variable name (douh!).
--
--   This hack lets issue 2046 go through.

castConstraintToCurrentContext :: ProblemConstraint -> MaybeT TCM ProblemConstraint
castConstraintToCurrentContext :: ProblemConstraint -> MaybeT (TCMT IO) ProblemConstraint
castConstraintToCurrentContext ProblemConstraint
c = do
  -- The checkpoint of the contraint
  let cl :: Closure Constraint
cl = ProblemConstraint -> Closure Constraint
theConstraint ProblemConstraint
c
      cp :: CheckpointId
cp = TCEnv -> CheckpointId
envCurrentCheckpoint forall a b. (a -> b) -> a -> b
$ forall a. Closure a -> TCEnv
clEnv Closure Constraint
cl
  Substitution' Term
sigma <- forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (forall (m :: * -> *) a. MonadTCEnv m => Lens' a TCEnv -> m a
viewTC forall a b. (a -> b) -> a -> b
$ Lens' (Map CheckpointId (Substitution' Term)) TCEnv
eCheckpoints forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k v. Ord k => k -> Lens' (Maybe v) (Map k v)
key CheckpointId
cp)
          (do
            -- We are not in a descendant of the constraint checkpoint.
            -- Here be dragons!!
            Context
gamma <- forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Context
envContext -- The target context
            let findInGamma :: Dom' Term (Name, Type) -> Maybe Int
findInGamma (Dom {unDom :: forall t e. Dom' t e -> e
unDom = (Name
x, Type
t)}) =
                  -- match by name (hazardous)
                  -- This is one of the seven deadly sins (not respecting alpha).
                  forall a. (a -> Bool) -> [a] -> Maybe Int
List.findIndex ((Name
x forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom) Context
gamma
            let delta :: Context
delta = TCEnv -> Context
envContext forall a b. (a -> b) -> a -> b
$ forall a. Closure a -> TCEnv
clEnv Closure Constraint
cl
                cand :: [Maybe Int]
cand  = forall a b. (a -> b) -> [a] -> [b]
map Dom' Term (Name, Type) -> Maybe Int
findInGamma Context
delta
            -- The domain of our substitution
            let coveredVars :: IntSet
coveredVars = [Int] -> IntSet
VarSet.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith forall (f :: * -> *) a b. Functor f => f a -> b -> f b
($>) [Maybe Int]
cand [Int
0..]
            -- Check that all the free variables of the constraint are contained in
            -- coveredVars.
            -- We ignore the free variables occurring in sorts.
            forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ All -> Bool
getAll forall a b. (a -> b) -> a -> b
$ forall a c t.
(IsVarSet a c, Free t) =>
SingleVar c -> IgnoreSorts -> t -> c
runFree (Bool -> All
All forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> IntSet -> Bool
`VarSet.member` IntSet
coveredVars)) IgnoreSorts
IgnoreAll (forall a. Closure a -> a
clValue Closure Constraint
cl)
            -- Turn cand into a substitution.
            -- Since we ignored the free variables in sorts, we better patch up
            -- the substitution with some dummy term rather than __IMPOSSIBLE__.
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. DeBruijn a => [a] -> Substitution' a
parallelS forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall b a. b -> (a -> b) -> Maybe a -> b
maybe HasCallStack => Term
__DUMMY_TERM__ Int -> Term
var) [Maybe Int]
cand
          ) forall (m :: * -> *) a. Monad m => a -> m a
return -- Phew, we've got the checkpoint! All is well.
  -- Apply substitution to constraint and pray that the Gods are merciful on us.
  Closure Constraint
cl' <- forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' Term
sigma (forall a. Closure a -> a
clValue Closure Constraint
cl)
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ProblemConstraint
c { theConstraint :: Closure Constraint
theConstraint = Closure Constraint
cl' }
  -- Note: the resulting constraint may not well-typed.
  -- Even if it is, it may map variables to their wrong counterpart.

-- | Return the size metas occurring in the simplified constraints.
--   A constraint like @↑ _j =< ∞ : Size@ simplifies to nothing,
--   so @_j@ would not be in this set.
solveSizeConstraints_ :: DefaultToInfty -> [CC] -> TCM (Set MetaId)
solveSizeConstraints_ :: DefaultToInfty -> [ProblemConstraint] -> TCMT IO (Set MetaId)
solveSizeConstraints_ DefaultToInfty
flag [ProblemConstraint]
cs0 = do
  -- Pair constraints with their representation as size constraints.
  -- Discard constraints that do not have such a representation.
  [(ProblemConstraint, HypSizeConstraint)]
ccs :: [(CC,HypSizeConstraint)] <- forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [ProblemConstraint]
cs0 forall a b. (a -> b) -> a -> b
$ \ ProblemConstraint
c0 -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ProblemConstraint
c0,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProblemConstraint -> TCM (Maybe HypSizeConstraint)
computeSizeConstraint ProblemConstraint
c0

  -- Simplify constraints and check for obvious inconsistencies.
  [(ProblemConstraint, HypSizeConstraint)]
ccs' <- forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(ProblemConstraint, HypSizeConstraint)]
ccs forall a b. (a -> b) -> a -> b
$ \ (ProblemConstraint
c0, HypSizeConstraint Context
cxt [Int]
hids [SizeConstraint]
hs SizeConstraint
sc) -> do
      case forall f r. (Pretty f, Pretty r, Eq r) => CTrans r f -> CTrans r f
simplify1 (\ SizeConstraint
sc -> forall (m :: * -> *) a. Monad m => a -> m a
return [SizeConstraint
sc]) SizeConstraint
sc of
        Left TCMT IO Doc
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
          TCMT IO Doc
"Contradictory size constraint" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ProblemConstraint
c0
        Right [SizeConstraint]
cs -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (ProblemConstraint
c0,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context
-> [Int] -> [SizeConstraint] -> SizeConstraint -> HypSizeConstraint
HypSizeConstraint Context
cxt [Int]
hids [SizeConstraint]
hs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [SizeConstraint]
cs

  -- Cluster constraints according to the meta variables they mention.
  -- @csNoM@ are the constraints that do not mention any meta.
  let ([(ProblemConstraint, HypSizeConstraint)]
csNoM, [((ProblemConstraint, HypSizeConstraint), List1 MetaId)]
csMs) = (forall a b. (a -> Maybe b) -> [a] -> ([a], [b])
`List.partitionMaybe` [(ProblemConstraint, HypSizeConstraint)]
ccs') forall a b. (a -> b) -> a -> b
$ \ p :: (ProblemConstraint, HypSizeConstraint)
p@(ProblemConstraint
c0, HypSizeConstraint
c) ->
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((ProblemConstraint, HypSizeConstraint)
p,) forall a b. (a -> b) -> a -> b
$ forall a. [a] -> Maybe (NonEmpty a)
nonEmpty forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map SizeMeta -> MetaId
sizeMetaId forall a b. (a -> b) -> a -> b
$ forall a. Set a -> [a]
Set.toList forall a b. (a -> b) -> a -> b
$ forall a. Flexs a => a -> Set (FlexOf a)
flexs HypSizeConstraint
c
  -- @css@ are the clusters of constraints.
      css :: [List1 (CC,HypSizeConstraint)]
      css :: [List1 (ProblemConstraint, HypSizeConstraint)]
css = forall c a. Ord c => [(a, NonEmpty c)] -> [NonEmpty a]
cluster' [((ProblemConstraint, HypSizeConstraint), List1 MetaId)]
csMs

  -- Check that the closed constraints are valid.
  forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (forall a. [a] -> Maybe (NonEmpty a)
nonEmpty [(ProblemConstraint, HypSizeConstraint)]
csNoM) forall a b. (a -> b) -> a -> b
$ DefaultToInfty
-> List1 (ProblemConstraint, HypSizeConstraint) -> TCM ()
solveCluster DefaultToInfty
flag

  -- Now, process the clusters.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [List1 (ProblemConstraint, HypSizeConstraint)]
css forall a b. (a -> b) -> a -> b
$ DefaultToInfty
-> List1 (ProblemConstraint, HypSizeConstraint) -> TCM ()
solveCluster DefaultToInfty
flag

  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> Set a -> Set b
Set.mapMonotonic SizeMeta -> MetaId
sizeMetaId forall a b. (a -> b) -> a -> b
$ forall a. Flexs a => a -> Set (FlexOf a)
flexs forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [((ProblemConstraint, HypSizeConstraint), List1 MetaId)]
csMs

-- | Solve a cluster of constraints sharing some metas.
--
solveCluster :: DefaultToInfty -> List1 (CC, HypSizeConstraint) -> TCM ()
solveCluster :: DefaultToInfty
-> List1 (ProblemConstraint, HypSizeConstraint) -> TCM ()
solveCluster DefaultToInfty
flag List1 (ProblemConstraint, HypSizeConstraint)
ccs = do
  let cs :: NonEmpty HypSizeConstraint
cs = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> b
snd List1 (ProblemConstraint, HypSizeConstraint)
ccs
  let prettyCs :: [TCMT IO Doc]
prettyCs   = forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall a b. (a -> b) -> a -> b
$ forall l. IsList l => l -> [Item l]
List1.toList NonEmpty HypSizeConstraint
cs
  let err :: TCMT IO Doc -> TCMT IO (Solution NamedRigid MetaId)
err TCMT IO Doc
reason = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
        forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
          [ forall (m :: * -> *). Applicative m => String -> m Doc
text forall a b. (a -> b) -> a -> b
$ String
"Cannot solve size constraints" ] forall a. [a] -> [a] -> [a]
++ [TCMT IO Doc]
prettyCs forall a. [a] -> [a] -> [a]
++
          [ TCMT IO Doc
"Reason:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
reason ]
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
    TCMT IO Doc
"Solving constraint cluster" forall a. a -> [a] -> [a]
: [TCMT IO Doc]
prettyCs
  -- Find the super context of all contexts.
{-
  -- We use the @'ctxId'@s.
  let cis@(ci:cis') = for cs $ \ c -> (c, reverse $ map ctxId $ sizeContext c)
--  let cis@(ci:cis') = for cs $ \ c -> (c, reverse $ sizeHypIds c)
      max a@Left{}            _            = a
      max a@(Right ci@(c,is)) ci'@(c',is') =
        case preOrSuffix is is' of
          -- No common context:
          IsNofix    -> Left (ci, ci')
          IsPrefix{} -> Right ci'
          _          -> a
      res = foldl' max (Right ci) cis'
      noContext ((c,is),(c',is')) = typeError . GenericDocError =<< vcat
        [ "Cannot solve size constraints; the following constraints have no common typing context:"
        , prettyTCM c
        , prettyTCM c'
        ]
  flip (either noContext) res $ \ (HypSizeConstraint gamma hids hs _, _) -> do
-}
  -- We rely on the fact that contexts are only extended...
  -- Just take the longest context.
  let HypSizeConstraint Context
gamma [Int]
hids [SizeConstraint]
hs SizeConstraint
_ = forall (t :: * -> *) a.
Foldable t =>
(a -> a -> Ordering) -> t a -> a
Fold.maximumBy (forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. HypSizeConstraint -> Context
sizeContext)) NonEmpty HypSizeConstraint
cs
  -- Length of longest context.
  let n :: Int
n = forall a. Sized a => a -> Int
size Context
gamma

  -- Now convert all size constraints to the largest context.
      csL :: NonEmpty SizeConstraint
csL = forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for NonEmpty HypSizeConstraint
cs forall a b. (a -> b) -> a -> b
$ \ (HypSizeConstraint Context
cxt [Int]
_ [SizeConstraint]
_ SizeConstraint
c) -> forall a. Subst a => Int -> a -> a
raise (Int
n forall a. Num a => a -> a -> a
- forall a. Sized a => a -> Int
size Context
cxt) SizeConstraint
c
  -- Canonicalize the constraints.
  -- This is unsound in the presence of hypotheses.
      csC :: [SizeConstraint]
      csC :: [SizeConstraint]
csC = forall a. Bool -> (a -> a) -> a -> a
applyWhen (forall a. Null a => a -> Bool
null [SizeConstraint]
hs) (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe SizeConstraint -> Maybe SizeConstraint
canonicalizeSizeConstraint) forall a b. (a -> b) -> a -> b
$ forall l. IsList l => l -> [Item l]
List1.toList NonEmpty SizeConstraint
csL
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
    [ TCMT IO Doc
"Size hypotheses" ] forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context
-> [Int] -> [SizeConstraint] -> SizeConstraint -> HypSizeConstraint
HypSizeConstraint Context
gamma [Int]
hids [SizeConstraint]
hs) [SizeConstraint]
hs forall a. [a] -> [a] -> [a]
++
    [ TCMT IO Doc
"Canonicalized constraints" ] forall a. [a] -> [a] -> [a]
++
    forall a b. (a -> b) -> [a] -> [b]
map (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context
-> [Int] -> [SizeConstraint] -> SizeConstraint -> HypSizeConstraint
HypSizeConstraint Context
gamma [Int]
hids [SizeConstraint]
hs) [SizeConstraint]
csC

  -- -- ALT:
  -- -- Now convert all size constraints to de Bruijn levels.

  -- -- To get from indices in a context of length m <= n
  -- -- to levels into the target context of length n,
  -- -- we apply the following substitution:
  -- -- Index m-1 needs to be mapped to level 0,
  -- -- index m-2 needs to be mapped to level 1,
  -- -- index 0 needs to be mapped to level m-1,
  -- -- so the desired substitution is @downFrom m@.
  -- let sub m = applySubst $ parallelS $ map var $ downFrom m

  -- -- We simply reverse the context to get to de Bruijn levels.
  -- -- Of course, all types in the context are broken, but
  -- -- only need it for pretty printing constraints.
  -- gamma <- return $ reverse gamma

  -- -- We convert the hypotheses to de Bruijn levels.
  -- hs <- return $ sub n hs

  -- -- We get a form for pretty-printing
  -- let prettyC = prettyTCM . HypSizeConstraint gamma hids hs

  -- -- We convert the constraints to de Bruijn level format.
  -- let csC :: [SizeConstraint]
  --     csC = for cs $ \ (HypSizeConstraint cxt _ _ c) -> sub (size cxt) c

  -- reportSDoc "tc.size.solve" 30 $ vcat $
  --   [ "Size hypotheses" ]           ++ map prettyC hs ++
  --   [ "Canonicalized constraints" ] ++ map prettyC csC

  -- Convert size metas to flexible vars.
  let metas :: [SizeMeta]
      metas :: [SizeMeta]
metas = forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (forall a. a -> [a] -> [a]
:[])) [SizeConstraint]
csC
      csF   :: [Size.Constraint' NamedRigid MetaId]
      csF :: [Constraint' NamedRigid MetaId]
csF   = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SizeMeta -> MetaId
sizeMetaId) [SizeConstraint]
csC

  -- Construct the hypotheses graph.
  let hyps :: [Constraint' NamedRigid MetaId]
hyps = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SizeMeta -> MetaId
sizeMetaId) [SizeConstraint]
hs
  -- There cannot be negative cycles in hypotheses graph due to scoping.
  let hg :: HypGraph NamedRigid MetaId
hg = forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => a
__IMPOSSIBLE__ forall a. a -> a
id forall a b. (a -> b) -> a -> b
$ forall rigid flex.
(Ord rigid, Ord flex, Pretty rigid, Pretty flex) =>
Set rigid
-> [Hyp' rigid flex] -> Either (TCMT IO Doc) (HypGraph rigid flex)
hypGraph (forall a. Rigids a => a -> Set (RigidOf a)
rigids [Constraint' NamedRigid MetaId]
csF) [Constraint' NamedRigid MetaId]
hyps

  -- -- Construct the constraint graph.
  -- --    g :: Size.Graph NamedRigid Int Label
  -- g <- either err return $ constraintGraph csF hg
  -- reportSDoc "tc.size.solve" 40 $ vcat $
  --   [ "Constraint graph"
  --   , text (show g)
  --   ]

  -- sol :: Solution NamedRigid Int <- either err return $ solveGraph Map.empty hg g
  -- either err return $ verifySolution hg csF sol

  -- Andreas, 2016-07-13, issue 2096.
  -- Running the solver once might result in unsolvable left-over constraints.
  -- We need to iterate the solver to detect this.
  Solution NamedRigid MetaId
sol :: Solution NamedRigid MetaId <- forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either TCMT IO Doc -> TCMT IO (Solution NamedRigid MetaId)
err forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
    forall r f.
(Ord r, Ord f, Pretty r, Pretty f, PrettyTCM f, Show r, Show f) =>
Polarities f
-> HypGraph r f
-> [Constraint' r f]
-> Solution r f
-> Either (TCMT IO Doc) (Solution r f)
iterateSolver forall k a. Map k a
Map.empty HypGraph NamedRigid MetaId
hg [Constraint' NamedRigid MetaId]
csF forall r f. Solution r f
emptySolution

  -- Convert solution to meta instantiation.
  Set MetaId
solved <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall (f :: * -> *) a. (Foldable f, Ord a) => f (Set a) -> Set a
Set.unions forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall k a. Map k a -> [(k, a)]
Map.assocs forall a b. (a -> b) -> a -> b
$ forall rigid flex.
Solution rigid flex -> Map flex (SizeExpr' rigid flex)
theSolution Solution NamedRigid MetaId
sol) forall a b. (a -> b) -> a -> b
$ \ (MetaId
m, SizeExpr' NamedRigid MetaId
a) -> do
    forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. ValidOffset a => a -> Bool
validOffset SizeExpr' NamedRigid MetaId
a) forall a. HasCallStack => a
__IMPOSSIBLE__
    -- Solution does not contain metas
    Term
u <- forall (m :: * -> *). HasBuiltins m => DBSizeExpr -> m Term
unSizeExpr forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. HasCallStack => a
__IMPOSSIBLE__ SizeExpr' NamedRigid MetaId
a
    let SizeMeta MetaId
_ [Int]
xs = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$
          forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((MetaId
mforall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. SizeMeta -> MetaId
sizeMetaId) [SizeMeta]
metas
    -- Check that solution is well-scoped
    let ys :: [Int]
ys = NamedRigid -> Int
rigidIndex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. Set a -> [a]
Set.toList (forall a. Rigids a => a -> Set (RigidOf a)
rigids SizeExpr' NamedRigid MetaId
a)
        ok :: Bool
ok = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Int]
xs) [Int]
ys -- TODO: more efficient
    -- unless ok $ err "ill-scoped solution for size meta variable"
    Term
u <- if Bool
ok then forall (m :: * -> *) a. Monad m => a -> m a
return Term
u else forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSizeInf
    Type
t <- forall (m :: * -> *). ReadTCState m => MetaId -> m Type
getMetaType MetaId
m
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
20 forall a b. (a -> b) -> a -> b
$ forall (tcm :: * -> *) a.
MonadTCEnv tcm =>
(Context -> Context) -> tcm a -> tcm a
unsafeModifyContext (forall a b. a -> b -> a
const Context
gamma) forall a b. (a -> b) -> a -> b
$ do
      let args :: Elims
args = forall a b. (a -> b) -> [a] -> [b]
map (forall a. Arg a -> Elim' a
Apply forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Arg a
defaultArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
var) [Int]
xs
      TCMT IO Doc
"solution " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (MetaId -> Elims -> Term
MetaV MetaId
m Elims
args) forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
" := " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
u
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
60 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ forall (m :: * -> *). Applicative m => String -> m Doc
text forall a b. (a -> b) -> a -> b
$ String
"  xs = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Int]
xs
      , forall (m :: * -> *). Applicative m => String -> m Doc
text forall a b. (a -> b) -> a -> b
$ String
"  u  = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
u
      ]
    forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m Bool
isFrozen MetaId
m forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`or2M` (Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Bool
envAssignMetas)) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Set a
Set.empty) forall a b. (a -> b) -> a -> b
$ do
      Int -> MetaId -> Type -> [Int] -> Term -> TCM ()
assignMeta Int
n MetaId
m Type
t [Int]
xs Term
u
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Set a
Set.singleton MetaId
m
    -- WRONG:
    -- let partialSubst = List.sort $ zip xs $ map var $ downFrom n
    -- assignMeta' n m t (length xs) partialSubst u
    -- WRONG: assign DirEq m (map (defaultArg . var) xs) u

  -- Possibly set remaining size metas to ∞ (issue 1862)
  -- unless we have an interaction meta in the cluster (issue 2095).

  Set MetaId
ims <- forall a. Ord a => [a] -> Set a
Set.fromList forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). ReadTCState m => m [MetaId]
getInteractionMetas

  --  ms = unsolved size metas from cluster
  let ms :: Set MetaId
ms = forall a. Ord a => [a] -> Set a
Set.fromList (forall a b. (a -> b) -> [a] -> [b]
map SizeMeta -> MetaId
sizeMetaId [SizeMeta]
metas) forall a. Ord a => Set a -> Set a -> Set a
Set.\\ Set MetaId
solved
  --  Make sure they do not contain an interaction point
  let noIP :: Bool
noIP = forall a. Ord a => Set a -> Set a -> Bool
Set.disjoint Set MetaId
ims Set MetaId
ms

  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Null a => a -> Bool
null Set MetaId
ms) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep forall a b. (a -> b) -> a -> b
$
    TCMT IO Doc
"cluster did not solve these size metas: " forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (forall a. Set a -> [a]
Set.toList Set MetaId
ms)

  Bool
solvedAll <- do
    -- If no metas are left, we have solved this cluster completely.
    if forall a. Set a -> Bool
Set.null Set MetaId
ms                then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True  else do
    -- Otherwise, we can solve it completely if we are allowed to set to ∞.
    if DefaultToInfty
flag forall a. Eq a => a -> a -> Bool
== DefaultToInfty
DontDefaultToInfty then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else do
    -- Which is only the case when we have no interaction points in the cluster.
    if Bool -> Bool
not Bool
noIP                   then forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False else do
    -- Try to set all unconstrained size metas to ∞.
    Term
inf <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSizeInf
    forall (t :: * -> *). Foldable t => t Bool -> Bool
and forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a. Set a -> [a]
Set.toList Set MetaId
ms) forall a b. (a -> b) -> a -> b
$ \ MetaId
m -> do
        -- If one variable is frozen, we cannot set it (and hence not all) to ∞
        let no :: TCMT IO Bool
no = do
              forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
30 forall a b. (a -> b) -> a -> b
$
                forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (MetaId -> Elims -> Term
MetaV MetaId
m []) forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"is frozen, cannot set it to ∞"
              forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
        forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *).
(HasCallStack, MonadDebug m, ReadTCState m) =>
MetaId -> m Bool
isFrozen MetaId
m forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
`or2M` do Bool -> Bool
not forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Bool
envAssignMetas) TCMT IO Bool
no forall a b. (a -> b) -> a -> b
$ {-else-} do
          forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
20 forall a b. (a -> b) -> a -> b
$
            TCMT IO Doc
"solution " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (MetaId -> Elims -> Term
MetaV MetaId
m []) forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>
            TCMT IO Doc
" := "      forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
inf
          Type
t <- forall (m :: * -> *). ReadTCState m => MetaId -> m Type
metaType MetaId
m
          TelV Tele (Dom Type)
tel Type
core <- forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView Type
t
          forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (forall a. Maybe a -> Bool
isJust forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(IsSizeType a, HasOptions m, HasBuiltins m) =>
a -> m (Maybe BoundedSize)
isSizeType Type
core) forall a. HasCallStack => a
__IMPOSSIBLE__
          Int -> MetaId -> Type -> [Int] -> Term -> TCM ()
assignMeta Int
0 MetaId
m Type
t (forall a. Integral a => a -> [a]
List.downFrom forall a b. (a -> b) -> a -> b
$ forall a. Sized a => a -> Int
size Tele (Dom Type)
tel) Term
inf
          forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True

  -- Double check.
  forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
solvedAll forall a b. (a -> b) -> a -> b
$ do
    let cs0 :: NonEmpty ProblemConstraint
cs0 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst List1 (ProblemConstraint, HypSizeConstraint)
ccs
        -- Error for giving up
        cannotSolve :: TCM ()
cannotSolve = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
          forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat (TCMT IO Doc
"Cannot solve size constraints" forall a. a -> NonEmpty a -> NonEmpty a
<| forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM NonEmpty ProblemConstraint
cs0)
    forall a b c. (a -> b -> c) -> b -> a -> c
flip forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
catchError (forall a b. a -> b -> a
const TCM ()
cannotSolve) forall a b. (a -> b) -> a -> b
$
      forall (m :: * -> *) a.
(MonadConstraint m, MonadWarning m, MonadError TCErr m,
 MonadFresh ProblemId m) =>
m a -> m a
noConstraints forall a b. (a -> b) -> a -> b
$
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ NonEmpty ProblemConstraint
cs0 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadConstraint m =>
(Constraint -> m a) -> ProblemConstraint -> m a
withConstraint forall (m :: * -> *). MonadConstraint m => Constraint -> m ()
solveConstraint

-- | Collect constraints from a typing context, looking for SIZELT hypotheses.
getSizeHypotheses :: Context -> TCM [(Nat, SizeConstraint)]
getSizeHypotheses :: Context -> TCM [(Int, SizeConstraint)]
getSizeHypotheses Context
gamma = forall (tcm :: * -> *) a.
MonadTCEnv tcm =>
(Context -> Context) -> tcm a -> tcm a
unsafeModifyContext (forall a b. a -> b -> a
const Context
gamma) forall a b. (a -> b) -> a -> b
$ do
  (Maybe QName
_, Maybe QName
msizelt) <- forall (m :: * -> *). HasBuiltins m => m (Maybe QName, Maybe QName)
getBuiltinSize
  forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe QName
msizelt (forall (m :: * -> *) a. Monad m => a -> m a
return []) forall a b. (a -> b) -> a -> b
$ \ QName
sizelt -> do
    -- Traverse the context from newest to oldest de Bruijn Index
    forall a. [Maybe a] -> [a]
catMaybes forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] Context
gamma) forall a b. (a -> b) -> a -> b
$ \ (Int
i, Dom' Term (Name, Type)
ce) -> do
        -- Get name and type of variable i.
        let (Name
x, Type
t) = forall t e. Dom' t e -> e
unDom Dom' Term (Name, Type)
ce
            s :: String
s      = forall a. Pretty a => a -> String
prettyShow Name
x
        Term
t <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Subst a => Int -> a -> a
raise (Int
1 forall a. Num a => a -> a -> a
+ Int
i) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Type'' t a -> a
unEl forall a b. (a -> b) -> a -> b
$ Type
t
        case Term
t of
          Def QName
d [Apply Arg Term
u] | QName
d forall a. Eq a => a -> a -> Bool
== QName
sizelt -> do
            forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Term -> TCM (Maybe DBSizeExpr)
sizeExpr forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
u) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ \ DBSizeExpr
a ->
              forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ (Int
i, forall rigid flex.
SizeExpr' rigid flex
-> Cmp -> SizeExpr' rigid flex -> Constraint' rigid flex
Constraint (forall rigid flex. rigid -> Offset -> SizeExpr' rigid flex
Rigid (String -> Int -> NamedRigid
NamedRigid String
s Int
i) Offset
0) Cmp
Lt DBSizeExpr
a)
          Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing

-- | Convert size constraint into form where each meta is applied
--   to indices @n-1,...,1,0@ where @n@ is the arity of that meta.
--
--   @X[σ] <= t@ becomes @X[id] <= t[σ^-1]@
--
--   @X[σ] ≤ Y[τ]@ becomes @X[id] ≤ Y[τ[σ^-1]]@ or @X[σ[τ^1]] ≤ Y[id]@
--   whichever is defined.  If none is defined, we give up.
--
--   Cf. @SizedTypes.oldCanonicalizeSizeConstraint@.
--
--   Fixes (the rather artificial) issue 300.
--   But it is unsound when pruned metas occur and triggers issue 1914.
--   Thus we deactivate it.
--   This needs to be properly implemented, possibly using the
--   metaPermuatation of each meta variable.

canonicalizeSizeConstraint :: SizeConstraint -> Maybe (SizeConstraint)
canonicalizeSizeConstraint :: SizeConstraint -> Maybe SizeConstraint
canonicalizeSizeConstraint c :: SizeConstraint
c@(Constraint DBSizeExpr
a Cmp
cmp DBSizeExpr
b) = forall a. a -> Maybe a
Just SizeConstraint
c
{-
  case (a,b) of

    -- Case flex-flex
    (Flex (SizeMeta m xs) n, Flex (SizeMeta l ys) n')
         -- try to invert xs on ys
       | let len = size xs
       , Just ys' <- mapM (\ y -> (len-1 -) <$> findIndex (==y) xs) ys ->
           return $ Constraint (Flex (SizeMeta m $ downFrom len) n)
                           cmp (Flex (SizeMeta l ys') n')
         -- try to invert ys on xs
       | let len = size ys
       , Just xs' <- mapM (\ x -> (len-1 -) <$> findIndex (==x) ys) xs ->
           return $ Constraint (Flex (SizeMeta m xs') n)
                           cmp (Flex (SizeMeta l $ downFrom len) n')
         -- give up
       | otherwise -> Nothing

    -- Case flex-rigid
    (Flex (SizeMeta m xs) n, Rigid (NamedRigid x i) n') -> do
      let len = size xs
      j <- (len-1 -) <$> findIndex (==i) xs
      return $ Constraint (Flex (SizeMeta m $ downFrom len) n)
                      cmp (Rigid (NamedRigid x j) n')

    -- Case rigid-flex
    (Rigid (NamedRigid x i) n, Flex (SizeMeta m xs) n') -> do
      let len = size xs
      j <- (len-1 -) <$> findIndex (==i) xs
      return $ Constraint (Rigid (NamedRigid x j) n)
                      cmp (Flex (SizeMeta m $ downFrom len) n')

    -- Case flex-const
    (Flex (SizeMeta m xs) n, _)      ->
      return $ Constraint (Flex (SizeMeta m $ downFrom $ size xs) n) cmp b

    -- Case const-flex
    (_, Flex (SizeMeta m xs) n') -> do
      return $ Constraint a cmp (Flex (SizeMeta m $ downFrom $ size xs) n')

    -- Case no flex
    _ -> return c
-}

-- | Identifiers for rigid variables.
data NamedRigid = NamedRigid
  { NamedRigid -> String
rigidName  :: String   -- ^ Name for printing in debug messages.
  , NamedRigid -> Int
rigidIndex :: Int      -- ^ De Bruijn index.
  } deriving (Int -> NamedRigid -> ShowS
[NamedRigid] -> ShowS
NamedRigid -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [NamedRigid] -> ShowS
$cshowList :: [NamedRigid] -> ShowS
show :: NamedRigid -> String
$cshow :: NamedRigid -> String
showsPrec :: Int -> NamedRigid -> ShowS
$cshowsPrec :: Int -> NamedRigid -> ShowS
Show)

instance Eq NamedRigid where == :: NamedRigid -> NamedRigid -> Bool
(==) = forall a. Eq a => a -> a -> Bool
(==) forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NamedRigid -> Int
rigidIndex
instance Ord NamedRigid where compare :: NamedRigid -> NamedRigid -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` NamedRigid -> Int
rigidIndex
instance Pretty NamedRigid where pretty :: NamedRigid -> Doc
pretty = String -> Doc
P.text forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedRigid -> String
rigidName
instance Plus NamedRigid Int NamedRigid where
  plus :: NamedRigid -> Int -> NamedRigid
plus (NamedRigid String
x Int
i) Int
j = String -> Int -> NamedRigid
NamedRigid String
x (Int
i forall a. Num a => a -> a -> a
+ Int
j)

-- | Size metas in size expressions.
data SizeMeta = SizeMeta
  { SizeMeta -> MetaId
sizeMetaId   :: MetaId
  -- TODO to fix issue 300?
  -- , sizeMetaPerm :: Permutation -- ^ Permutation from the current context
  --                               --   to the context of the meta.
  , SizeMeta -> [Int]
sizeMetaArgs :: [Int]       -- ^ De Bruijn indices.
  } deriving (Int -> SizeMeta -> ShowS
[SizeMeta] -> ShowS
SizeMeta -> String
forall a.
(Int -> a -> ShowS) -> (a -> String) -> ([a] -> ShowS) -> Show a
showList :: [SizeMeta] -> ShowS
$cshowList :: [SizeMeta] -> ShowS
show :: SizeMeta -> String
$cshow :: SizeMeta -> String
showsPrec :: Int -> SizeMeta -> ShowS
$cshowsPrec :: Int -> SizeMeta -> ShowS
Show)

-- | An equality which ignores the meta arguments.
instance Eq  SizeMeta where == :: SizeMeta -> SizeMeta -> Bool
(==)    = forall a. Eq a => a -> a -> Bool
(==)    forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SizeMeta -> MetaId
sizeMetaId
-- | An order which ignores the meta arguments.
instance Ord SizeMeta where compare :: SizeMeta -> SizeMeta -> Ordering
compare = forall a. Ord a => a -> a -> Ordering
compare forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` SizeMeta -> MetaId
sizeMetaId

instance Pretty SizeMeta where pretty :: SizeMeta -> Doc
pretty = forall a. Pretty a => a -> Doc
P.pretty forall b c a. (b -> c) -> (a -> b) -> a -> c
. SizeMeta -> MetaId
sizeMetaId

instance PrettyTCM SizeMeta where
  prettyTCM :: forall (m :: * -> *). MonadPretty m => SizeMeta -> m Doc
prettyTCM (SizeMeta MetaId
x [Int]
es) = forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (MetaId -> Elims -> Term
MetaV MetaId
x forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Arg a -> Elim' a
Apply forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Arg a
defaultArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
var) [Int]
es)

instance Subst SizeMeta where
  type SubstArg SizeMeta = Term
  applySubst :: Substitution' (SubstArg SizeMeta) -> SizeMeta -> SizeMeta
applySubst Substitution' (SubstArg SizeMeta)
sigma (SizeMeta MetaId
x [Int]
es) = MetaId -> [Int] -> SizeMeta
SizeMeta MetaId
x (forall a b. (a -> b) -> [a] -> [b]
map Int -> Int
raise [Int]
es)
    where
      raise :: Int -> Int
raise Int
i =
        case forall a. EndoSubst a => Substitution' a -> Int -> a
lookupS Substitution' (SubstArg SizeMeta)
sigma Int
i of
          Var Int
j [] -> Int
j
          Term
_        -> forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Size expression with de Bruijn indices.
type DBSizeExpr = SizeExpr' NamedRigid SizeMeta

-- deriving instance Functor     (SizeExpr' Int)
-- deriving instance Foldable    (SizeExpr' Int)
-- deriving instance Traversable (SizeExpr' Int)

-- | Only for 'raise'.
instance Subst (SizeExpr' NamedRigid SizeMeta) where
  type SubstArg (SizeExpr' NamedRigid SizeMeta) = Term
  applySubst :: Substitution' (SubstArg DBSizeExpr) -> DBSizeExpr -> DBSizeExpr
applySubst Substitution' (SubstArg DBSizeExpr)
sigma DBSizeExpr
a =
    case DBSizeExpr
a of
      DBSizeExpr
Infty   -> DBSizeExpr
a
      Const{} -> DBSizeExpr
a
      Flex  SizeMeta
x Offset
n -> forall rigid flex. flex -> Offset -> SizeExpr' rigid flex
Flex (forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg DBSizeExpr)
sigma SizeMeta
x) Offset
n
      Rigid NamedRigid
r Offset
n ->
        case forall a. EndoSubst a => Substitution' a -> Int -> a
lookupS Substitution' (SubstArg DBSizeExpr)
sigma forall a b. (a -> b) -> a -> b
$ NamedRigid -> Int
rigidIndex NamedRigid
r of
          Var Int
j [] -> forall rigid flex. rigid -> Offset -> SizeExpr' rigid flex
Rigid NamedRigid
r{ rigidIndex :: Int
rigidIndex = Int
j } Offset
n
          Term
_        -> forall a. HasCallStack => a
__IMPOSSIBLE__

type SizeConstraint = Constraint' NamedRigid SizeMeta

instance Subst SizeConstraint where
  type SubstArg SizeConstraint = Term
  applySubst :: Substitution' (SubstArg SizeConstraint)
-> SizeConstraint -> SizeConstraint
applySubst Substitution' (SubstArg SizeConstraint)
sigma (Constraint DBSizeExpr
a Cmp
cmp DBSizeExpr
b) =
    forall rigid flex.
SizeExpr' rigid flex
-> Cmp -> SizeExpr' rigid flex -> Constraint' rigid flex
Constraint (forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg SizeConstraint)
sigma DBSizeExpr
a) Cmp
cmp (forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg SizeConstraint)
sigma DBSizeExpr
b)

-- | Assumes we are in the right context.
instance PrettyTCM (SizeConstraint) where
  prettyTCM :: forall (m :: * -> *). MonadPretty m => SizeConstraint -> m Doc
prettyTCM (Constraint DBSizeExpr
a Cmp
cmp DBSizeExpr
b) = do
    Term
u <- forall (m :: * -> *). HasBuiltins m => DBSizeExpr -> m Term
unSizeExpr DBSizeExpr
a
    Term
v <- forall (m :: * -> *). HasBuiltins m => DBSizeExpr -> m Term
unSizeExpr DBSizeExpr
b
    forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
u forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Cmp
cmp forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
v

-- | Size constraint with de Bruijn indices.
data HypSizeConstraint = HypSizeConstraint
  { HypSizeConstraint -> Context
sizeContext    :: Context
  , HypSizeConstraint -> [Int]
sizeHypIds     :: [Nat] -- ^ DeBruijn indices
  , HypSizeConstraint -> [SizeConstraint]
sizeHypotheses :: [SizeConstraint]  -- ^ Living in @Context@.
  , HypSizeConstraint -> SizeConstraint
sizeConstraint :: SizeConstraint    -- ^ Living in @Context@.
  }

instance Flexs HypSizeConstraint where
  type FlexOf HypSizeConstraint = SizeMeta
  flexs :: HypSizeConstraint -> Set (FlexOf HypSizeConstraint)
flexs (HypSizeConstraint Context
_ [Int]
_ [SizeConstraint]
hs SizeConstraint
c) = forall a. Flexs a => a -> Set (FlexOf a)
flexs [SizeConstraint]
hs forall a. Monoid a => a -> a -> a
`mappend` forall a. Flexs a => a -> Set (FlexOf a)
flexs SizeConstraint
c

instance PrettyTCM HypSizeConstraint where
  prettyTCM :: forall (m :: * -> *). MonadPretty m => HypSizeConstraint -> m Doc
prettyTCM (HypSizeConstraint Context
cxt [Int]
_ [SizeConstraint]
hs SizeConstraint
c) =
    forall (tcm :: * -> *) a.
MonadTCEnv tcm =>
(Context -> Context) -> tcm a -> tcm a
unsafeModifyContext (forall a b. a -> b -> a
const Context
cxt) forall a b. (a -> b) -> a -> b
$ do
      let cxtNames :: [Name]
cxtNames = forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom) Context
cxt
      -- text ("[#cxt=" ++ show (size cxt) ++ "]") <+> do
      forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList (forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Name]
cxtNames) forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do
      forall a. Bool -> (a -> a) -> a -> a
applyUnless (forall a. Null a => a -> Bool
null [SizeConstraint]
hs)
       ((forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
hcat (forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate m Doc
", " forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [SizeConstraint]
hs) forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> m Doc
"|-") forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>)
       (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM SizeConstraint
c)

-- | Turn a constraint over de Bruijn indices into a size constraint.
computeSizeConstraint :: ProblemConstraint -> TCM (Maybe HypSizeConstraint)
computeSizeConstraint :: ProblemConstraint -> TCM (Maybe HypSizeConstraint)
computeSizeConstraint ProblemConstraint
c = do
  let cxt :: Context
cxt = TCEnv -> Context
envContext forall a b. (a -> b) -> a -> b
$ forall a. Closure a -> TCEnv
clEnv forall a b. (a -> b) -> a -> b
$ ProblemConstraint -> Closure Constraint
theConstraint ProblemConstraint
c
  forall (tcm :: * -> *) a.
MonadTCEnv tcm =>
(Context -> Context) -> tcm a -> tcm a
unsafeModifyContext (forall a b. a -> b -> a
const Context
cxt) forall a b. (a -> b) -> a -> b
$ do
    case forall a. Closure a -> a
clValue forall a b. (a -> b) -> a -> b
$ ProblemConstraint -> Closure Constraint
theConstraint ProblemConstraint
c of
      ValueCmp Comparison
CmpLeq CompareAs
_ Term
u Term
v -> do
        forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.size.solve" Int
50 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep forall a b. (a -> b) -> a -> b
$
          [ TCMT IO Doc
"converting size constraint"
          , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ProblemConstraint
c
          ]
        Maybe DBSizeExpr
ma <- Term -> TCM (Maybe DBSizeExpr)
sizeExpr Term
u
        Maybe DBSizeExpr
mb <- Term -> TCM (Maybe DBSizeExpr)
sizeExpr Term
v
        ([Int]
hids, [SizeConstraint]
hs) <- forall a b. [(a, b)] -> ([a], [b])
unzip forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Context -> TCM [(Int, SizeConstraint)]
getSizeHypotheses Context
cxt
        let mk :: DBSizeExpr -> DBSizeExpr -> HypSizeConstraint
mk DBSizeExpr
a DBSizeExpr
b = Context
-> [Int] -> [SizeConstraint] -> SizeConstraint -> HypSizeConstraint
HypSizeConstraint Context
cxt [Int]
hids [SizeConstraint]
hs forall a b. (a -> b) -> a -> b
$ forall rigid flex.
SizeExpr' rigid flex
-> Cmp -> SizeExpr' rigid flex -> Constraint' rigid flex
Size.Constraint DBSizeExpr
a Cmp
Le DBSizeExpr
b
        -- We only create a size constraint if both terms can be
        -- parsed to our format of size expressions.
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ DBSizeExpr -> DBSizeExpr -> HypSizeConstraint
mk forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe DBSizeExpr
ma forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe DBSizeExpr
mb
      Constraint
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Turn a term into a size expression.
--
--   Returns 'Nothing' if the term isn't a proper size expression.

sizeExpr :: Term -> TCM (Maybe DBSizeExpr)
sizeExpr :: Term -> TCM (Maybe DBSizeExpr)
sizeExpr Term
u = do
  Term
u <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
u -- Andreas, 2009-02-09.
                -- This is necessary to surface the solutions of metavariables.
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.conv.size" Int
60 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"sizeExpr:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
u
  SizeView
s <- forall (m :: * -> *).
(HasBuiltins m, MonadTCEnv m, ReadTCState m) =>
Term -> m SizeView
sizeView Term
u
  case SizeView
s of
    SizeView
SizeInf     -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall rigid flex. SizeExpr' rigid flex
Infty
    SizeSuc Term
u   -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b c. Plus a b c => a -> b -> c
`plus` (Offset
1 :: Offset)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> TCM (Maybe DBSizeExpr)
sizeExpr Term
u
    OtherSize Term
u -> case Term
u of
      Var Int
i []    -> (\ String
x -> forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall rigid flex. rigid -> Offset -> SizeExpr' rigid flex
Rigid (String -> Int -> NamedRigid
NamedRigid String
x Int
i) Offset
0) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> String
prettyShow forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(Applicative m, MonadFail m, MonadTCEnv m) =>
Int -> m Name
nameOfBV Int
i
--      MetaV m es  -> return $ Just $ Flex (SizeMeta m es) 0
      MetaV MetaId
m Elims
es | Just [Int]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Elim' Term -> Maybe Int
isVar Elims
es, forall a. Ord a => [a] -> Bool
List.fastDistinct [Int]
xs
                  -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall rigid flex. flex -> Offset -> SizeExpr' rigid flex
Flex (MetaId -> [Int] -> SizeMeta
SizeMeta MetaId
m [Int]
xs) Offset
0
      Term
_           -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
  where
    isVar :: Elim' Term -> Maybe Int
isVar (Proj{})  = forall a. Maybe a
Nothing
    isVar (IApply Term
_ Term
_ Term
v) = Elim' Term -> Maybe Int
isVar (forall a. Arg a -> Elim' a
Apply (forall a. a -> Arg a
defaultArg Term
v))
    isVar (Apply Arg Term
v) = case forall e. Arg e -> e
unArg Arg Term
v of
      Var Int
i [] -> forall a. a -> Maybe a
Just Int
i
      Term
_        -> forall a. Maybe a
Nothing

-- | Turn a de size expression into a term.
unSizeExpr :: HasBuiltins m => DBSizeExpr -> m Term
unSizeExpr :: forall (m :: * -> *). HasBuiltins m => DBSizeExpr -> m Term
unSizeExpr DBSizeExpr
a =
  case DBSizeExpr
a of
    DBSizeExpr
Infty         -> forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasBuiltins m => String -> m (Maybe Term)
getBuiltin' String
builtinSizeInf
    Rigid NamedRigid
r (O Int
n) -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n forall a. Ord a => a -> a -> Bool
>= Int
0) forall a. HasCallStack => a
__IMPOSSIBLE__
      forall (m :: * -> *). HasBuiltins m => Int -> Term -> m Term
sizeSuc Int
n forall a b. (a -> b) -> a -> b
$ Int -> Term
var forall a b. (a -> b) -> a -> b
$ NamedRigid -> Int
rigidIndex NamedRigid
r
    Flex (SizeMeta MetaId
x [Int]
es) (O Int
n) -> do
      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Int
n forall a. Ord a => a -> a -> Bool
>= Int
0) forall a. HasCallStack => a
__IMPOSSIBLE__
      forall (m :: * -> *). HasBuiltins m => Int -> Term -> m Term
sizeSuc Int
n forall a b. (a -> b) -> a -> b
$ MetaId -> Elims -> Term
MetaV MetaId
x forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. Arg a -> Elim' a
Apply forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Arg a
defaultArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
var) [Int]
es
    Const{} -> forall a. HasCallStack => a
__IMPOSSIBLE__