{-# LANGUAGE NondecreasingIndentation #-}

module Agda.TypeChecking.Coverage.Cubical where

import Prelude hiding (null, (!!))  -- do not use partial functions like !!

import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans ( lift )

import Data.Foldable (for_)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet

import Agda.Syntax.Common
import Agda.Syntax.Position
import Agda.Syntax.Internal hiding (DataOrRecord(..))
import Agda.Syntax.Internal.Pattern
import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..))

import Agda.TypeChecking.Names
import Agda.TypeChecking.Primitive hiding (Nat)
import Agda.TypeChecking.Monad

import Agda.TypeChecking.Rules.LHS (DataOrRecord(..), checkSortOfSplitVar)
import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars)
import Agda.TypeChecking.Rules.LHS.Unify
import Agda.TypeChecking.Rules.Term (unquoteTactic)

import Agda.TypeChecking.Coverage.Match
import Agda.TypeChecking.Coverage.SplitTree
import Agda.TypeChecking.Coverage.SplitClause


import Agda.TypeChecking.Conversion (tryConversion, equalType)
import Agda.TypeChecking.Datatypes (getConForm, getDatatypeArgs)
import {-# SOURCE #-} Agda.TypeChecking.Empty ( checkEmptyTel, isEmptyTel, isEmptyType )
import Agda.TypeChecking.Irrelevance
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Records
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Telescope.Path
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.Warnings

import Agda.Interaction.Options

import Agda.Utils.Either
import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.Singleton
import Agda.Utils.Size
import Agda.Utils.WithDefault

import Agda.Utils.Impossible


createMissingIndexedClauses :: QName
                            -> Arg Nat
                            -> BlockingVar
                            -> SplitClause
                            -> [(SplitTag,(SplitClause,IInfo))]
                            -> [Clause]
                            -> TCM ([(SplitTag,CoverResult)],[Clause])
createMissingIndexedClauses :: QName
-> Arg Int
-> BlockingVar
-> SplitClause
-> [(SplitTag, (SplitClause, IInfo))]
-> [Clause]
-> TCM ([(SplitTag, CoverResult)], [Clause])
createMissingIndexedClauses QName
f Arg Int
n BlockingVar
x SplitClause
old_sc [(SplitTag, (SplitClause, IInfo))]
scs [Clause]
cs = do
  Maybe QName
reflId <- forall (m :: * -> *). HasBuiltins m => String -> m (Maybe QName)
getName' String
builtinReflId
  let infos :: [(QName, UnifyEquiv)]
infos = [(QName
c,UnifyEquiv
i) | (SplitCon QName
c, (SplitClause
_,TheInfo UnifyEquiv
i)) <- [(SplitTag, (SplitClause, IInfo))]
scs ]
  case [(SplitTag, (SplitClause, IInfo))]
scs of
    [(SplitCon QName
c,(SplitClause
_newSc,i :: IInfo
i@TheInfo{}))] | forall a. a -> Maybe a
Just QName
c forall a. Eq a => a -> a -> Bool
== Maybe QName
reflId -> do
      Maybe ((SplitTag, SplitTree' SplitTag), Clause)
mc <- QName
-> Arg Int
-> BlockingVar
-> SplitClause
-> IInfo
-> TCM (Maybe ((SplitTag, SplitTree' SplitTag), Clause))
createMissingConIdClause QName
f Arg Int
n BlockingVar
x SplitClause
old_sc IInfo
i
      forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe ((SplitTag, SplitTree' SplitTag), Clause)
mc (forall (m :: * -> *) a. Monad m => a -> m a
return ([],[Clause]
cs)) forall a b. (a -> b) -> a -> b
$ \ ((SplitTag
sp,SplitTree' SplitTag
tree),Clause
cl) -> do
      let res :: CoverResult
res = SplitTree' SplitTag
-> IntSet
-> [(Telescope, [NamedArg DeBruijnPattern])]
-> [Clause]
-> IntSet
-> CoverResult
CoverResult SplitTree' SplitTag
tree (Int -> IntSet
IntSet.singleton (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Clause]
cs)) [] [Clause
cl] IntSet
IntSet.empty
      forall (m :: * -> *) a. Monad m => a -> m a
return ([(SplitTag
sp,CoverResult
res)],forall a. [a] -> a -> [a]
snoc [Clause]
cs Clause
cl)
    [(SplitTag, (SplitClause, IInfo))]
xs | Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. Null a => a -> Bool
null [(QName, UnifyEquiv)]
infos -> do
         forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.indexed" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"size (xs,infos):" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (forall a. Sized a => a -> Int
size [(SplitTag, (SplitClause, IInfo))]
xs,forall a. Sized a => a -> Int
size [(QName, UnifyEquiv)]
infos)
         forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.indexed" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"xs :" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(SplitTag, (SplitClause, IInfo))]
xs)

         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Sized a => a -> Int
size [(SplitTag, (SplitClause, IInfo))]
xs forall a. Eq a => a -> a -> Bool
== forall a. Sized a => a -> Int
size [(QName, UnifyEquiv)]
infos forall a. Num a => a -> a -> a
+ Int
1) forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.indexed" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"missing some infos"
            -- Andrea: what to do when we only managed to build a unification proof for some of the constructors?
         Constructor{QName
conData :: Defn -> QName
conData :: QName
conData} <- Definition -> Defn
theDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (forall a b. (a, b) -> a
fst (forall a. [a] -> a
head [(QName, UnifyEquiv)]
infos))
         Datatype{dataPars :: Defn -> Int
dataPars = Int
pars, dataIxs :: Defn -> Int
dataIxs = Int
nixs, Maybe QName
dataTranspIx :: Defn -> Maybe QName
dataTranspIx :: Maybe QName
dataTranspIx} <- Definition -> Defn
theDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
conData
         QName
hcomp <- 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 QName)
getName' String
builtinHComp
         QName
trX <- 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 (f :: * -> *) a. Applicative f => a -> f a
pure Maybe QName
dataTranspIx
         Clause
trX_cl <- QName
-> QName -> Arg Int -> BlockingVar -> SplitClause -> TCM Clause
createMissingTrXTrXClause QName
trX QName
f Arg Int
n BlockingVar
x SplitClause
old_sc
         Clause
hcomp_cl <- QName
-> QName -> Arg Int -> BlockingVar -> SplitClause -> TCM Clause
createMissingTrXHCompClause QName
trX QName
f Arg Int
n BlockingVar
x SplitClause
old_sc
         ([(SplitTag, SplitTree' SplitTag)]
trees,[Clause]
cls) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(QName, UnifyEquiv)]
infos forall a b. (a -> b) -> a -> b
$ \ (QName
c,UnifyEquiv
i) -> do
           Clause
cl <- QName
-> QName
-> Arg Int
-> BlockingVar
-> SplitClause
-> QName
-> UnifyEquiv
-> TCM Clause
createMissingTrXConClause QName
trX QName
f Arg Int
n BlockingVar
x SplitClause
old_sc QName
c UnifyEquiv
i
           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ((QName -> SplitTag
SplitCon QName
c , forall a. Int -> SplitTree' a
SplittingDone (forall a. Sized a => a -> Int
size forall a b. (a -> b) -> a -> b
$ Clause -> Telescope
clauseTel Clause
cl)) , Clause
cl)
         let extra :: [(SplitTag, SplitTree' SplitTag)]
extra = [ (QName -> SplitTag
SplitCon QName
trX, forall a. Int -> SplitTree' a
SplittingDone forall a b. (a -> b) -> a -> b
$ forall a. Sized a => a -> Int
size forall a b. (a -> b) -> a -> b
$ Clause -> Telescope
clauseTel Clause
trX_cl)
                                           , (QName -> SplitTag
SplitCon QName
hcomp, forall a. Int -> SplitTree' a
SplittingDone forall a b. (a -> b) -> a -> b
$ forall a. Sized a => a -> Int
size forall a b. (a -> b) -> a -> b
$ Clause -> Telescope
clauseTel Clause
hcomp_cl)
                                           ]
                 --  = [ (SplitCon trX, SplittingDone $ size $ clauseTel trX_cl) ]
             extraCl :: [Clause]
extraCl = [Clause
trX_cl, Clause
hcomp_cl]
                 --  = [trX_cl]
         let clauses :: [Clause]
clauses = [Clause]
cls forall a. [a] -> [a] -> [a]
++ [Clause]
extraCl
         let tree :: SplitTree' SplitTag
tree = forall a. Arg Int -> LazySplit -> SplitTrees' a -> SplitTree' a
SplitAt ((forall a. Num a => a -> a -> a
+(Int
parsforall a. Num a => a -> a -> a
+Int
nixsforall a. Num a => a -> a -> a
+Int
1)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arg Int
n) LazySplit
StrictSplit forall a b. (a -> b) -> a -> b
$
                                           [(SplitTag, SplitTree' SplitTag)]
trees
                                        forall a. [a] -> [a] -> [a]
++ [(SplitTag, SplitTree' SplitTag)]
extra
             res :: CoverResult
res = CoverResult
               { coverSplitTree :: SplitTree' SplitTag
coverSplitTree      = SplitTree' SplitTag
tree
               , coverUsedClauses :: IntSet
coverUsedClauses    = [Int] -> IntSet
IntSet.fromList (forall a b. (a -> b) -> [a] -> [b]
map (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Clause]
cs forall a. Num a => a -> a -> a
+) [Int
0..forall (t :: * -> *) a. Foldable t => t a -> Int
length [Clause]
clausesforall a. Num a => a -> a -> a
-Int
1])
               , coverMissingClauses :: [(Telescope, [NamedArg DeBruijnPattern])]
coverMissingClauses = []
               , coverPatterns :: [Clause]
coverPatterns       = [Clause]
clauses
               , coverNoExactClauses :: IntSet
coverNoExactClauses = IntSet
IntSet.empty
               }
         forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.indexed" Int
20 forall a b. (a -> b) -> a -> b
$
           TCMT IO Doc
"tree:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty SplitTree' SplitTag
tree
         forall (m :: * -> *).
(MonadConstraint m, MonadTCState m) =>
QName -> [Clause] -> m ()
addClauses QName
f [Clause]
clauses
         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ ([(QName -> SplitTag
SplitCon QName
trX,CoverResult
res)],[Clause]
csforall a. [a] -> [a] -> [a]
++[Clause]
clauses)
--         return $ ([],[])
    [(SplitTag, (SplitClause, IInfo))]
xs | Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ([],[Clause]
cs)

covFillTele :: QName -> Abs Telescope -> Term -> Args -> Term -> TCM [Term]
covFillTele :: QName -> Abs Telescope -> Term -> Args -> Term -> TCM [Term]
covFillTele QName
func Abs Telescope
tel Term
face Args
d Term
j = do
  Either (Closure (Abs Type)) Args
ed_f <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) Args
trFillTel Abs Telescope
tel Term
face Args
d Term
j
  case Either (Closure (Abs Type)) Args
ed_f of
    Right Args
d_f -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg Args
d_f
    Left Closure (Abs Type)
failed_t -> forall (m :: * -> *) a c b.
(MonadTCEnv m, ReadTCState m, LensClosure a c) =>
c -> (a -> m b) -> m b
enterClosure Closure (Abs Type)
failed_t forall a b. (a -> b) -> a -> b
$ \Abs Type
failed_t -> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext (String
"i" :: String, HasCallStack => Dom Type
__DUMMY_DOM__) forall a b. (a -> b) -> a -> b
$ do
      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
"Could not generate a transport clause for" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
func
        , TCMT IO Doc
"because a term of type" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (forall a. Abs a -> a
unAbs Abs Type
failed_t)
        , TCMT IO Doc
"lives in the sort" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (forall a. LensSort a => a -> Sort
getSort (forall a. Abs a -> a
unAbs Abs Type
failed_t)) forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"and thus can not be transported"
        ]

createMissingTrXTrXClause :: QName -- ^ trX
                            -> QName -- ^ f defined
                            -> Arg Nat
                            -> BlockingVar
                            -> SplitClause
                            -> TCM Clause
createMissingTrXTrXClause :: QName
-> QName -> Arg Int -> BlockingVar -> SplitClause -> TCM Clause
createMissingTrXTrXClause QName
q_trX QName
f Arg Int
n BlockingVar
x SplitClause
old_sc = do
  let
   old_tel :: Telescope
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
   old_ps :: [NamedArg DeBruijnPattern]
old_ps = [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
   old_t :: Dom Type
old_t = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc

  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.trx" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"trX-trX clause for" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
f
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.trx" Int
20 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
"old_tel:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
old_tel
    , TCMT IO Doc
"old_ps :" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
old_tel (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
old_ps)
    , TCMT IO Doc
"old_t  :" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
old_tel (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Dom Type
old_t)
    ]

  -- TODO: redo comments, the strategy changed.
  -- old_tel = Γ1, (x : D η v), Δ
  -- α = boundary(old_ps)
  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ]

  -- α' = boundary(old_ps[x = pat])
  -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0) ⊢ pat := trX p φ (trX q ψ x0) : D η v

  -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0), Δ[x = pat]

  -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized.

  -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α']
                                -- , φ  ↦ w1[φ = i1, p = refl]
                                -- , ψ  ↦ w1[ψ = i1, q = refl]
                                -- ]
  -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1)
  -- Ξ ⊢ pat_rec[0] = pat : D η v
  -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v
  -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t)

  -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ
  -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]
  -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.

  Type
interval <- forall (m :: * -> *). Functor m => m Term -> m Type
elInf forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primInterval
  Term
iz <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
  Term
io <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
  Term
tHComp <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primHComp
  Term
tNeg <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
  let neg :: NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg NamesT (TCMT IO) Term
i = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tNeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i
  let min :: NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT m Term
i NamesT m Term
j = forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
  let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
i NamesT m Term
j = forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
  let
    old_tel :: Telescope
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
    old_ps' :: AbsN [NamedArg DeBruijnPattern]
old_ps' = forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
    old_ps :: NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AbsN [NamedArg DeBruijnPattern]
old_ps'
    old_ty :: NamesT (TCMT IO) (AbsN (Dom Type))
old_ty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
  -- old_tel = Γ(x: D η v)Δ
  -- Γ1, (x : D η v)  ⊢ delta = (δ : Δ)
    (Telescope
gamma1x,Telescope
delta') = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt (forall a. Sized a => a -> Int
size Telescope
old_tel forall a. Num a => a -> a -> a
- BlockingVar -> Int
blockingVarNo BlockingVar
x) Telescope
old_tel
    delta :: NamesT (TCMT IO) (AbsN Telescope)
delta = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1x) forall a b. (a -> b) -> a -> b
$ Telescope
delta'
    gamma1_size :: Int
gamma1_size = (forall a. Sized a => a -> Int
size Telescope
gamma1x forall a. Num a => a -> a -> a
- Int
1)
    (Telescope
gamma1,ExtendTel Dom Type
dType' Abs Telescope
_) = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt Int
gamma1_size Telescope
gamma1x

  AbsN [(Term, Term)]
old_sides <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM AbsN [NamedArg DeBruijnPattern]
old_ps' forall a b. (a -> b) -> a -> b
$ \ [NamedArg DeBruijnPattern]
ps -> do
    let vs :: [Int]
vs = forall p. IApplyVars p => p -> [Int]
iApplyVars [NamedArg DeBruijnPattern]
ps
    let tm :: Term
tm = QName -> [Elim] -> Term
Def QName
f forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
ps
    [(Term, (Term, Term))]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs forall a b. (a -> b) -> a -> b
$ \ Int
v ->
        -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Term
var Int
v,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ (forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
iz forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm, forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
io forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Term
v,(Term
l,Term
r)) -> [(Term
tNeg forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
v],Term
l),(Term
v,Term
r)]) [(Term, (Term, Term))]
xs
  let
    gamma1ArgNames :: [Arg String]
gamma1ArgNames = Telescope -> [Arg String]
teleArgNames Telescope
gamma1
    deltaArgNames :: [Arg String]
deltaArgNames = Telescope -> [Arg String]
teleArgNames Telescope
delta'
  (AbsN Args
params,AbsN Telescope
xTel,AbsN (AbsN Type)
dT) <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma1 forall a b. (a -> b) -> a -> b
$ do
    Just (QName
d, Args
ps, Args
_is) <- forall (m :: * -> *).
HasConstInfo m =>
Type -> m (Maybe (QName, Args, Args))
getDatatypeArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Dom Type
dType'
    Definition
def <- forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
    let dTy :: Type
dTy = Definition -> Type
defType Definition
def
    let Datatype{dataSort :: Defn -> Sort
dataSort = Sort
s} = Definition -> Defn
theDef Definition
def
    TelV Telescope
tel Type
_ <- forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView Type
dTy
    let params :: AbsN Args
params = forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1) Args
ps
        xTel :: AbsN Telescope
xTel = forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1) (Telescope
tel forall t. Apply t => t -> Args -> t
`apply` Args
ps)

    AbsN (AbsN Type)
dT <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
          NamesT (TCMT IO) (AbsN Sort)
s <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
tel) Sort
s
          forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Telescope -> [Arg String]
teleArgNames Telescope
gamma1) forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
g1 -> do
          forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Telescope -> [Arg String]
teleArgNames forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN AbsN Telescope
xTel) forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x -> do
          Args
params <- forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Args
params forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. Arg e -> e
unArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgVars (TCMT IO)
g1)
          Args
x      <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ArgVars (TCMT IO)
x
          Sort
s <- NamesT (TCMT IO) (AbsN Sort)
s forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) forall a b. (a -> b) -> a -> b
$ Args
params forall a. [a] -> [a] -> [a]
++ Args
x)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Sort' t -> a -> Type'' t a
El Sort
s forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
d [] forall t. Apply t => t -> Args -> t
`apply` (Args
params forall a. [a] -> [a] -> [a]
++ Args
x)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (AbsN Args
params, AbsN Telescope
xTel,AbsN (AbsN Type)
dT)

  let
    xTelI :: NamesT (TCMT IO) (AbsN Telescope)
xTelI = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Type -> Telescope -> Telescope
expTelescope Type
interval forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsN Telescope
xTel
    xTelIArgNames :: [Arg String]
xTelIArgNames = Telescope -> [Arg String]
teleArgNames (forall a. AbsN a -> a
unAbsN AbsN Telescope
xTel) -- same names

  -- Γ1, φ, p, ψ, q, x0 ⊢ pat := trX p φ (trX q ψ x0)
  let trX' :: NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
trX' = forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg String]
gamma1ArgNames forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
g1 -> do
             forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg ([forall e. e -> Arg e
defaultArg String
"phi"] forall a. [a] -> [a] -> [a]
++ [Arg String]
xTelIArgNames) forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
phi_p -> do
             forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [forall e. e -> Arg e
defaultArg String
"x0"] forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x0 -> do
             [NamedArg DeBruijnPattern]
param_args <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a name. a -> Named name a
unnamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Term -> Pattern' a
dotP))) forall a b. (a -> b) -> a -> b
$
               forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Args
params forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. Arg e -> e
unArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgVars (TCMT IO)
g1)
             (NamedArg DeBruijnPattern
phi:[NamedArg DeBruijnPattern]
p) <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ArgVars (TCMT IO)
phi_p
             [NamedArg DeBruijnPattern]
x0 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ArgVars (TCMT IO)
x0
             forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
defaultPatternInfo QName
q_trX forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern]
param_args forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern]
p forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern
phi] forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern]
x0
      trX :: NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
trX'
  let pat' :: NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN DeBruijnPattern))))
pat' =
            forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
gamma1ArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1 -> do
            forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ ([forall e. e -> Arg e
defaultArg String
"phi"] forall a. [a] -> [a] -> [a]
++ [Arg String]
xTelIArgNames)) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
phi_p -> do
            forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ ([forall e. e -> Arg e
defaultArg String
"psi"] forall a. [a] -> [a] -> [a]
++ [Arg String]
xTelIArgNames)) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
psi_q -> do
            forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ [forall e. e -> Arg e
defaultArg String
"x0"]) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
x0 -> do
            -- (phi:p) <- sequence phi_p
            -- (psi:q) <- sequence psi_q
            -- x0 <- sequence x0
            let trX :: NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
trX = NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
trX' forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1
            NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
phi_p forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
psi_q forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
x0]
          --  pure $ trX $ p ++ [phi, defaultArg $ unnamed $ trX $ q ++ [psi] ++ x0]
      pat :: NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN Term))))
pat = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN DeBruijnPattern))))
pat'
  let deltaPat :: [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Telescope
deltaPat [NamesT (TCMT IO) Term]
g1 NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p NamesT (TCMT IO) Term
psi [NamesT (TCMT IO) Term]
q NamesT (TCMT IO) Term
x0 =
        NamesT (TCMT IO) (AbsN Telescope)
delta forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
g1 forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN Term))))
pat forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
phiforall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
p) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
psiforall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
q) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term
x0]])
  -- Ξ
  Telescope
cTel <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (forall (f :: * -> *) a. Applicative f => a -> f a
pure Telescope
gamma1) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1 -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"φ" (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (NamesT (TCMT IO) (AbsN Telescope)
xTelI forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"ψ" (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
psi -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (NamesT (TCMT IO) (AbsN Telescope)
xTelI forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
q -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"x0" (forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN (AbsN Type)
dT forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map Vars (TCMT IO)
q forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
f -> NamesT (TCMT IO) Term
f forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz)) forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
x0 -> do
    [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Telescope
deltaPat Vars (TCMT IO)
g1 Var (TCMT IO)
phi Vars (TCMT IO)
p Var (TCMT IO)
psi Vars (TCMT IO)
q Var (TCMT IO)
x0

  AbsN
  (Abs
     (AbsN
        (Abs
           (AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
ps_ty_rhs <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
gamma1ArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1 -> do
    forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"φ" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
xTelIArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
    forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"ψ" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
psi -> do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
xTelIArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
q -> do
    forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"x0" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
x0 -> do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
deltaArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
d -> do
    let
      ps :: NamesT TCM NAPs
      ps :: NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps = NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Vars (TCMT IO)
g1
                          forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN DeBruijnPattern))))
pat' forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
p) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
psiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
q) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [Var (TCMT IO)
x0]]
                          forall a. [a] -> [a] -> [a]
++ Vars (TCMT IO)
d)

      rhsTy :: NamesT (TCMT IO) (Dom Type)
rhsTy = NamesT (TCMT IO) (AbsN (Dom Type))
old_ty forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Vars (TCMT IO)
g1
                          forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN Term))))
pat forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
p) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
psiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
q) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [Var (TCMT IO)
x0]]
                          forall a. [a] -> [a] -> [a]
++ Vars (TCMT IO)
d)

    NamesT (TCMT IO) Telescope
xTel <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Telescope
xTel forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1
    NamesT (TCMT IO) (Abs [Term])
q4_f <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
      Abs Telescope
ty <- forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
_ -> NamesT (TCMT IO) Telescope
xTel
      Term
face <- forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max Var (TCMT IO)
phi forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg Var (TCMT IO)
j) (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg Var (TCMT IO)
i)
      Args
base <- forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Arg e
defaultArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
Monad m =>
NamesT m [Term] -> NamesT m Term -> NamesT m [Term]
appTel (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Vars (TCMT IO)
q) Var (TCMT IO)
j
      (Term, Abs [Term])
u  <- forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max Var (TCMT IO)
j Var (TCMT IO)
psi) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"h" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
h -> do
              forall (m :: * -> *).
Monad m =>
NamesT m [Term] -> NamesT m Term -> NamesT m [Term]
appTel (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Vars (TCMT IO)
p) (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min Var (TCMT IO)
j (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min Var (TCMT IO)
h Var (TCMT IO)
i))
      Right Args
xs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> Args
-> ExceptT (Closure (Abs Type)) m Args
transpSysTel' Bool
False Abs Telescope
ty [(Term, Abs [Term])
u] Term
face Args
base
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg Args
xs
    -- Ξ ⊢ pat_rec[0] = pat : D η v
    -- Ξ ⊢ pat_rec[1] = trX q4 (φ ∧ ψ) x0 : D η v
    -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q4_f i) (ψ ∧ (φ ∨ ~ i)) t)
    NamesT (TCMT IO) (Abs Term)
pat_rec <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
          [NamesT (TCMT IO) Term]
p_conn <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Vars (TCMT IO)
p forall (m :: * -> *).
Monad m =>
NamesT m [Term] -> NamesT m Term -> NamesT m [Term]
`appTel` forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max Var (TCMT IO)
i Var (TCMT IO)
j
          [NamesT (TCMT IO) Term]
q4_f' <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
q4_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
          NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max Var (TCMT IO)
i Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
p_conn)
              forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min Var (TCMT IO)
psi (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max Var (TCMT IO)
phi (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg Var (TCMT IO)
i))forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
q4_f') forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [Var (TCMT IO)
x0]]

    let mkBndry :: NamesT (TCMT IO) (Abs [Term])
-> NamesT
     (TCMT IO) [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
mkBndry NamesT (TCMT IO) (Abs [Term])
args = do
            [NamesT (TCMT IO) Term]
args1 <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ (forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
            -- faces ought to be constant on "j"
            [Term]
faces <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst) AbsN [(Term, Term)]
old_sides) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
args1
            [Term]
us <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) AbsN [(Term, Term)]
old_sides) forall a b. (a -> b) -> a -> b
$ \ AbsN Term
u -> do
                  forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> do
                    [NamesT (TCMT IO) Term]
args <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ (forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
j)
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Term
u forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
args
            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 [Term]
faces [Term]
us) forall a b. (a -> b) -> a -> b
$ \ (Term
phi,Term
u) -> forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
phi) (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u)
    let mkComp :: NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term)
mkComp NamesT (TCMT IO) (AbsN Term)
pr = forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
          NamesT (TCMT IO) (Abs [Term])
d_f <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
            Abs Telescope
tel <- forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> NamesT (TCMT IO) (AbsN Telescope)
delta forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Vars (TCMT IO)
g1 forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN Term)
pr forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [Var (TCMT IO)
i,Var (TCMT IO)
j]])
            Term
face <- forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min Var (TCMT IO)
phi Var (TCMT IO)
psi forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
`max` (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min Var (TCMT IO)
i (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max Var (TCMT IO)
phi Var (TCMT IO)
psi))
            Term
j <- Var (TCMT IO)
j
            Args
d <- forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Arg e
defaultArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Vars (TCMT IO)
d
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ QName -> Abs Telescope -> Term -> Args -> Term -> TCM [Term]
covFillTele QName
f Abs Telescope
tel Term
face Args
d Term
j
          let args :: NamesT (TCMT IO) (Abs [Term])
args = forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
                [Term]
g1 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Vars (TCMT IO)
g1
                Term
x <- NamesT (TCMT IO) (AbsN Term)
pr forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [Var (TCMT IO)
i,NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg Var (TCMT IO)
j]
                [Term]
ys <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
d_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg Var (TCMT IO)
j
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Term]
g1 forall a. [a] -> [a] -> [a]
++ Term
xforall a. a -> [a] -> [a]
:[Term]
ys
          NamesT (TCMT IO) (Abs Type)
ty <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
               [NamesT (TCMT IO) Term]
args <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
j
               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t e. Dom' t e -> e
unDom forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (AbsN (Dom Type))
old_ty forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
args
          let face :: NamesT (TCMT IO) Term
face = forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max Var (TCMT IO)
i (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min Var (TCMT IO)
phi Var (TCMT IO)
psi)
          NamesT (TCMT IO) Term
base <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
            [NamesT (TCMT IO) Term]
args' <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QName -> [Elim] -> Term
Def QName
f) forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
args'
          [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys <- NamesT (TCMT IO) (Abs [Term])
-> NamesT
     (TCMT IO) [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
mkBndry NamesT (TCMT IO) (Abs [Term])
args
          forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m) =>
NamesT m (Abs Type)
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpSys NamesT (TCMT IO) (Abs Type)
ty [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys NamesT (TCMT IO) Term
face NamesT (TCMT IO) Term
base

    -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ
    -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]
    -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.
    NamesT (TCMT IO) Term
syspsi <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> do
      Abs Term
c <- NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term)
mkComp forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN [String
"i",String
"j"] forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term
i,NamesT (TCMT IO) Term
j] -> do
        Abs String
n (Type
data_ty,[Term]
lines) <- forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"k" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
k -> do
          let phi_k :: NamesT (TCMT IO) Term
phi_k = forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max Var (TCMT IO)
phi (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg Var (TCMT IO)
k)
          let p_k :: [NamesT (TCMT IO) Term]
p_k = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map Vars (TCMT IO)
p forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"h" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
h -> NamesT (TCMT IO) Term
p forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min Var (TCMT IO)
k NamesT (TCMT IO) Term
h)
          Type
data_ty <- forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN (AbsN Type)
dT forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map Vars (TCMT IO)
p forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
p forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Var (TCMT IO)
k)
          Term
line1 <- NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
phi_kforall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
p_k) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [Var (TCMT IO)
x0]

          Term
line2 <- NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1
                       forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT (TCMT IO) Term
phi_k NamesT (TCMT IO) Term
j      forall a. a -> [a] -> [a]
: (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [NamesT (TCMT IO) Term]
p_k forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"h" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
h -> NamesT (TCMT IO) Term
p forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT (TCMT IO) Term
h NamesT (TCMT IO) Term
j)))
                       forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN`
                  [NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1
                       forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT (TCMT IO) Term
phi_k (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg NamesT (TCMT IO) Term
j)forall a. a -> [a] -> [a]
: (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map [NamesT (TCMT IO) Term]
p_k forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"h" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
h -> NamesT (TCMT IO) Term
p forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
h NamesT (TCMT IO) Term
j)))
                       forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [Var (TCMT IO)
x0]]
          forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type
data_ty,[Term
line1,Term
line2])
        NamesT (TCMT IO) (Abs Type)
data_ty <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. String -> a -> Abs a
Abs String
n Type
data_ty
        [NamesT (TCMT IO) (Abs Term)
line1,NamesT (TCMT IO) (Abs Term)
line2] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. String -> a -> Abs a
Abs String
n) [Term]
lines
        let sys :: [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys = [(NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg NamesT (TCMT IO) Term
i, forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"k" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
k -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
line2 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
k)
                  ,(NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg NamesT (TCMT IO) Term
j forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
`max` NamesT (TCMT IO) Term
j forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
`max` NamesT (TCMT IO) Term
i forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
`max` Var (TCMT IO)
phi, forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"k" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
k -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
line1 forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
k)
                  ]
        forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m) =>
NamesT m (Abs Type)
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpSys NamesT (TCMT IO) (Abs Type)
data_ty [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) Var (TCMT IO)
x0
      forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Abs Term
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
i
    NamesT (TCMT IO) Term
sysphi <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
o -> do
      Abs Term
c <- NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term)
mkComp forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN [String
"i",String
"j"] forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
_ij -> do
        NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
psiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
q) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [Var (TCMT IO)
x0]
      forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (f :: * -> *) a. Applicative f => a -> f a
pure Abs Term
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
i
    [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
syse <- NamesT (TCMT IO) (Abs [Term])
-> NamesT
     (TCMT IO) [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
mkBndry forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
_ -> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ Vars (TCMT IO)
g1 forall a. [a] -> [a] -> [a]
++ [forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_rec forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz] forall a. [a] -> [a] -> [a]
++ Vars (TCMT IO)
d
    let sys :: [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys = [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
syse forall a. [a] -> [a] -> [a]
++ [(Var (TCMT IO)
phi,NamesT (TCMT IO) Term
sysphi)] forall a. [a] -> [a] -> [a]
++ [(Var (TCMT IO)
psi,NamesT (TCMT IO) Term
syspsi)]
    NamesT (TCMT IO) Term
w0 <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
      let w :: NamesT (TCMT IO) (Abs Term)
w = NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term)
mkComp (forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN [String
"i",String
"j"] forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term
_i, NamesT (TCMT IO) Term
j] -> forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_rec forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
j)
      forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
w forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
    let rhs :: NamesT (TCMT IO) Term
rhs = forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m,
 MonadPretty m) =>
NamesT m Type
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
hcomp (forall t e. Dom' t e -> e
unDom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Dom Type)
rhsTy) [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys NamesT (TCMT IO) Term
w0
    (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) (Dom Type)
rhsTy forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
rhs
  let ([NamedArg DeBruijnPattern]
ps,Dom Type
ty,Term
rhs) = forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ forall a. Abs a -> a
unAbs forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ forall a. Abs a -> a
unAbs forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ forall a. Abs a -> a
unAbs forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ AbsN
  (Abs
     (AbsN
        (Abs
           (AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
ps_ty_rhs
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.trx" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"trX-trX clause for" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
f
  let c :: Clause
c = Clause { clauseLHSRange :: Range
clauseLHSRange  = forall a. Range' a
noRange
                 , clauseFullRange :: Range
clauseFullRange = forall a. Range' a
noRange
                 , clauseTel :: Telescope
clauseTel       = Telescope
cTel
                 , namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg DeBruijnPattern]
ps
                 , clauseBody :: Maybe Term
clauseBody      = forall a. a -> Maybe a
Just Term
rhs
                 , clauseType :: Maybe (Arg Type)
clauseType      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. ArgInfo -> e -> Arg e
Arg (forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom Type
ty) (forall t e. Dom' t e -> e
unDom Dom Type
ty)
                 , clauseCatchall :: Bool
clauseCatchall    = Bool
False
                 , clauseExact :: Maybe Bool
clauseExact       = forall a. Maybe a
Nothing
                 , clauseRecursive :: Maybe Bool
clauseRecursive   = forall a. a -> Maybe a
Just Bool
True
                 , clauseUnreachable :: Maybe Bool
clauseUnreachable = forall a. a -> Maybe a
Just Bool
False
                 , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis    = ExpandedEllipsis
NoEllipsis
                 , clauseWhereModule :: Maybe ModuleName
clauseWhereModule = forall a. Maybe a
Nothing
                 }
  String -> Clause -> TCMT IO ()
debugClause String
"tc.cover.trx.trx" Clause
c
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Clause
c
createMissingTrXHCompClause :: QName
                            -> QName
                            -> Arg Nat
                            -> BlockingVar
                            -> SplitClause
                            -> TCM Clause
createMissingTrXHCompClause :: QName
-> QName -> Arg Int -> BlockingVar -> SplitClause -> TCM Clause
createMissingTrXHCompClause QName
q_trX QName
f Arg Int
n BlockingVar
x SplitClause
old_sc = do
  let
   old_tel :: Telescope
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
   old_ps :: [NamedArg DeBruijnPattern]
old_ps = [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
   old_t :: Dom Type
old_t = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc

  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"trX-hcomp clause for" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
f
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.hcomp" Int
20 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
"old_tel:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
old_tel
    , TCMT IO Doc
"old_ps :" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
old_tel (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
old_ps)
    , TCMT IO Doc
"old_t  :" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
old_tel (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Dom Type
old_t)
    ]

  -- old_tel = Γ1, (x : D η v), Δ
  -- α = boundary(old_ps)
  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ]

  -- α' = boundary(old_ps[x = pat])
  -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, u : I -> [ψ] → D η (p i0), u0 : D η (p i0) ⊢ pat := trX p φ (hcomp ψ u u0) : D η v

  -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, u : ..., u0 : D η (p i0), Δ[x = pat]

  -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized.

  -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α']
                                -- , φ  ↦ w1[φ = i1, p = refl]   = f old_ps[γ1,x = hcomp ψ u u0    ,δ]
                                -- , ψ  ↦ w1[ψ = i1]             = f old_ps[γ1,x = trX p φ (u i1 _),δ]
                                -- ]

  -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1)
  -- Ξ ⊢ pat_rec[0] = pat : D η v
  -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v
  -- Ξ ⊢ pat-rec[i] := trX (\ j → q (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t)

  -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ : Δ[γ1,x = pat_rec[1]]
  -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]
  -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.

  QName
q_hcomp <- 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 QName)
getName' String
builtinHComp
  let
   old_tel :: Telescope
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
   old_ps :: [NamedArg DeBruijnPattern]
old_ps = [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
   old_t :: Dom Type
old_t = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc

  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.trx" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"trX-trX clause for" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
f
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.trx" Int
20 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
"old_tel:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
old_tel
    , TCMT IO Doc
"old_ps :" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
old_tel (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
old_ps)
    , TCMT IO Doc
"old_t  :" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
old_tel (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Dom Type
old_t)
    ]

  -- TODO: redo comments, the strategy changed.
  -- old_tel = Γ1, (x : D η v), Δ
  -- α = boundary(old_ps)
  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [ α ↦ (f old_ps)[α] ]

  -- α' = boundary(old_ps[x = pat])
  -- Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0) ⊢ pat := trX p φ (trX q ψ x0) : D η v

  -- Ξ = Γ1, φ : I, p : Path X(η) _ v, ψ : I, q : Path X(η) _ (p i0), x0 : D η (q i0), Δ[x = pat]

  -- Ξ ⊢ w1 := f old_ps[γ1,x = pat,δ] : old_t[γ1,x = pat,δ] -- the case we are defining. can only be used if specialized.

  -- Ξ ⊢ rhs : old_t[γ1,x = pat,δ] [ α' ↦ w1[α']
                                -- , φ  ↦ w1[φ = i1, p = refl]
                                -- , ψ  ↦ w1[ψ = i1, q = refl]
                                -- ]
  -- Ξ ⊢ q2 := tr (i. Path X(η) (q i0) (p i)) φ q : Path X(η) (q i0) (p i1)
  -- Ξ ⊢ pat_rec[0] = pat : D η v
  -- Ξ ⊢ pat_rec[1] = trX q2 (φ ∧ ψ) x0 : D η v
  -- Ξ ⊢ pat-rec[i] := trX (\ j → p (i ∨ j)) (i ∨ φ) (trX (q2_f i) (ψ ∧ (φ ∨ ~ i)) t)

  -- Ξ ⊢ δ_f[1] = tr (i. Δ[γ1,x = pat_rec[i]]) (φ ∧ ψ) δ
  -- Ξ ⊢ w0 := f old_ps[γ1,x = pat_rec[1] ,δ_f[1]] : old_t[γ1,x = pat_rec[1],δ_f[1]]
  -- Ξ ⊢ rhs := tr (i. old_t[γ1,x = pat_rec[~i], δ_f[~i]]) (φ ∧ ψ) w0 -- TODO plus sides.

  Type
interval <- forall (m :: * -> *). Functor m => m Term -> m Type
elInf forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primInterval
  Term
iz <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
  Term
io <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
  Term
tHComp <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primHComp
  Term
tNeg <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
  let neg :: NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg NamesT (TCMT IO) Term
i = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tNeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i
  let min :: NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT m Term
i NamesT m Term
j = forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
  let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
i NamesT m Term
j = forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
  let
    old_tel :: Telescope
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
    old_ps' :: AbsN [NamedArg DeBruijnPattern]
old_ps' = forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
    old_ps :: NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ AbsN [NamedArg DeBruijnPattern]
old_ps'
    old_ty :: NamesT (TCMT IO) (AbsN (Dom Type))
old_ty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
  -- old_tel = Γ(x: D η v)Δ
  -- Γ1, (x : D η v)  ⊢ delta = (δ : Δ)
    (Telescope
gamma1x,Telescope
delta') = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt (forall a. Sized a => a -> Int
size Telescope
old_tel forall a. Num a => a -> a -> a
- BlockingVar -> Int
blockingVarNo BlockingVar
x) Telescope
old_tel
    delta :: NamesT (TCMT IO) (AbsN Telescope)
delta = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1x) forall a b. (a -> b) -> a -> b
$ Telescope
delta'
    gamma1_size :: Int
gamma1_size = (forall a. Sized a => a -> Int
size Telescope
gamma1x forall a. Num a => a -> a -> a
- Int
1)
    (Telescope
gamma1,ExtendTel Dom Type
dType' Abs Telescope
_) = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt Int
gamma1_size Telescope
gamma1x

  AbsN [(Term, Term)]
old_sides <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM AbsN [NamedArg DeBruijnPattern]
old_ps' forall a b. (a -> b) -> a -> b
$ \ [NamedArg DeBruijnPattern]
ps -> do
    let vs :: [Int]
vs = forall p. IApplyVars p => p -> [Int]
iApplyVars [NamedArg DeBruijnPattern]
ps
    let tm :: Term
tm = QName -> [Elim] -> Term
Def QName
f forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
ps
    [(Term, (Term, Term))]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs forall a b. (a -> b) -> a -> b
$ \ Int
v ->
        -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?)
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Term
var Int
v,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ (forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
iz forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm, forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
io forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Term
v,(Term
l,Term
r)) -> [(Term
tNeg forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
v],Term
l),(Term
v,Term
r)]) [(Term, (Term, Term))]
xs
  let
    gamma1ArgNames :: [Arg String]
gamma1ArgNames = Telescope -> [Arg String]
teleArgNames Telescope
gamma1
    deltaArgNames :: [Arg String]
deltaArgNames = Telescope -> [Arg String]
teleArgNames Telescope
delta'
  (AbsN Args
params,AbsN Telescope
xTel,AbsN (AbsN Type)
dT) <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma1 forall a b. (a -> b) -> a -> b
$ do
    Just (QName
d, Args
ps, Args
_is) <- forall (m :: * -> *).
HasConstInfo m =>
Type -> m (Maybe (QName, Args, Args))
getDatatypeArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Dom Type
dType'
    Definition
def <- forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
    let dTy :: Type
dTy = Definition -> Type
defType Definition
def
    let Datatype{dataSort :: Defn -> Sort
dataSort = Sort
s} = Definition -> Defn
theDef Definition
def
    TelV Telescope
tel Type
_ <- forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView Type
dTy
    let params :: AbsN Args
params = forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1) Args
ps
        xTel :: AbsN Telescope
xTel = forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1) (Telescope
tel forall t. Apply t => t -> Args -> t
`apply` Args
ps)

    AbsN (AbsN Type)
dT <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
          NamesT (TCMT IO) (AbsN Sort)
s <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
tel) Sort
s
          forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Telescope -> [Arg String]
teleArgNames Telescope
gamma1) forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
g1 -> do
          forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Telescope -> [Arg String]
teleArgNames forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN AbsN Telescope
xTel) forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x -> do
          Args
params <- forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Args
params forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. Arg e -> e
unArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgVars (TCMT IO)
g1)
          Args
x      <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ArgVars (TCMT IO)
x
          Sort
s <- NamesT (TCMT IO) (AbsN Sort)
s forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) forall a b. (a -> b) -> a -> b
$ Args
params forall a. [a] -> [a] -> [a]
++ Args
x)
          forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Sort' t -> a -> Type'' t a
El Sort
s forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
d [] forall t. Apply t => t -> Args -> t
`apply` (Args
params forall a. [a] -> [a] -> [a]
++ Args
x)
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (AbsN Args
params, AbsN Telescope
xTel,AbsN (AbsN Type)
dT)

  let
    xTelI :: NamesT (TCMT IO) (AbsN Telescope)
xTelI = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Type -> Telescope -> Telescope
expTelescope Type
interval forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsN Telescope
xTel
    xTelIArgNames :: [Arg String]
xTelIArgNames = Telescope -> [Arg String]
teleArgNames (forall a. AbsN a -> a
unAbsN AbsN Telescope
xTel) -- same names

  -- Γ1, φ, p, ψ, q, x0 ⊢ pat := trX p φ (trX q ψ x0)
  let trX' :: NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
trX' = forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg String]
gamma1ArgNames forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
g1 -> do
             forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg ([forall e. e -> Arg e
defaultArg String
"phi"] forall a. [a] -> [a] -> [a]
++ [Arg String]
xTelIArgNames) forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
phi_p -> do
             forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [forall e. e -> Arg e
defaultArg String
"x0"] forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x0 -> do
             [NamedArg DeBruijnPattern]
param_args <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a name. a -> Named name a
unnamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Term -> Pattern' a
dotP))) forall a b. (a -> b) -> a -> b
$
               forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Args
params forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. Arg e -> e
unArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgVars (TCMT IO)
g1)
             (NamedArg DeBruijnPattern
phi:[NamedArg DeBruijnPattern]
p) <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ArgVars (TCMT IO)
phi_p
             [NamedArg DeBruijnPattern]
x0 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ArgVars (TCMT IO)
x0
             forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
defaultPatternInfo QName
q_trX forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern]
param_args forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern]
p forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern
phi] forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern]
x0
      trX :: NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
trX'
  let
    hcompD' :: [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
hcompD' [NamesT (TCMT IO) Term]
g1 [NamesT (TCMT IO) Term]
v =
        forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [forall e. e -> Arg e
argH String
"psi",forall e. e -> Arg e
argN String
"u", forall e. e -> Arg e
argN String
"u0"] forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x0 -> do
        [NamedArg DeBruijnPattern]
x0 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ArgVars (TCMT IO)
x0
        Just (LEl Level
l Term
t) <- (forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN (AbsN Type)
dT forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
v
        let ty :: [NamedArg DeBruijnPattern]
ty = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a name. a -> Named name a
unnamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Term -> Pattern' a
dotP) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Arg e
argH) [Level -> Term
Level Level
l,Term
t]
        forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
defaultPatternInfo QName
q_hcomp forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern]
ty forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern]
x0
  AbsN (AbsN (AbsN Term))
hcompD <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
            forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ [Arg String]
gamma1ArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1 -> do
            forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (Telescope -> [String]
teleNames forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ AbsN Telescope
xTel) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
v -> do
            forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DeBruijnPattern -> Term
patternToTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
hcompD' Vars (TCMT IO)
g1 Vars (TCMT IO)
v
  let pat' :: NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
pat' =
            forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
gamma1ArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1 -> do
            forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ ([forall e. e -> Arg e
defaultArg String
"phi"] forall a. [a] -> [a] -> [a]
++ [Arg String]
xTelIArgNames)) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
phi_p -> do
            forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN [String
"psi",String
"u",String
"u0"] forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
x0 -> do
            let trX :: NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
trX = NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
trX' forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1
            let p0 :: [NamesT (TCMT IO) Term]
p0 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map (forall a. [a] -> [a]
tail Vars (TCMT IO)
phi_p) forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
p forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
            NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
phi_p forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [[NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
hcompD' Vars (TCMT IO)
g1 [NamesT (TCMT IO) Term]
p0 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
x0]
      pat :: NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
pat = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
pat'
  let deltaPat :: [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Telescope
deltaPat [NamesT (TCMT IO) Term]
g1 NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p [NamesT (TCMT IO) Term]
x0 =
        NamesT (TCMT IO) (AbsN Telescope)
delta forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
g1 forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
pat forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
phiforall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
p) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
x0])
  -- Ξ
  Telescope
cTel <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (forall (f :: * -> *) a. Applicative f => a -> f a
pure Telescope
gamma1) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1 -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"φ" (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (NamesT (TCMT IO) (AbsN Telescope)
xTelI forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
    let p0 :: [NamesT (TCMT IO) Term]
p0 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map Vars (TCMT IO)
p forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
p forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
    let ty :: NamesT (TCMT IO) Type
ty = forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN (AbsN Type)
dT forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
p0
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"ψ" (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
psi -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"u" (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" Var (TCMT IO)
psi (\ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Type
ty)) forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
u -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"u0" NamesT (TCMT IO) Type
ty forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
u0 -> do
    [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Telescope
deltaPat Vars (TCMT IO)
g1 Var (TCMT IO)
phi Vars (TCMT IO)
p [Var (TCMT IO)
psi,Var (TCMT IO)
u,Var (TCMT IO)
u0]

  AbsN
  (Abs
     (AbsN
        (Abs
           (Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
ps_ty_rhs <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
gamma1ArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1 -> do
    forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"φ" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
xTelIArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
    forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"ψ" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
psi -> do
    forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"u" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
u -> do
    forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"u0" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
u0 -> do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
deltaArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
d -> do
    let
      x0 :: Vars TCM
      x0 :: Vars (TCMT IO)
x0 = [Var (TCMT IO)
psi,Var (TCMT IO)
u,Var (TCMT IO)
u0]
      ps :: NamesT TCM NAPs
      ps :: NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps = NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Vars (TCMT IO)
g1
                          forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
pat' forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
p) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
x0]
                          forall a. [a] -> [a] -> [a]
++ Vars (TCMT IO)
d)

      rhsTy :: NamesT (TCMT IO) (Dom Type)
rhsTy = NamesT (TCMT IO) (AbsN (Dom Type))
old_ty forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Vars (TCMT IO)
g1
                          forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
pat forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
p) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
x0]
                          forall a. [a] -> [a] -> [a]
++ Vars (TCMT IO)
d)

    NamesT (TCMT IO) Telescope
xTel <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Telescope
xTel forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1
    -- Ξ ⊢ pat-rec[i] := trX .. (hfill ... (~ i))
    NamesT (TCMT IO) (Abs Term)
pat_rec <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
          let tr :: NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
tr NamesT (TCMT IO) Term
x = NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
p) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term
x]
          let p0 :: [NamesT (TCMT IO) Term]
p0 = forall a b c. (a -> b -> c) -> b -> a -> c
flip forall a b. (a -> b) -> [a] -> [b]
map Vars (TCMT IO)
p forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
p forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
          NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
tr (forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m,
 MonadPretty m) =>
NamesT m Type
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
hcomp (forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN (AbsN Type)
dT forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1 forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
p0)
                    [(Var (TCMT IO)
psi,forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j -> Var (TCMT IO)
u forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
j (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg Var (TCMT IO)
i)))
                    ,(Var (TCMT IO)
i  ,forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> Var (TCMT IO)
u0)]
                    Var (TCMT IO)
u0)
    --   args : (i.old_tel)  -> ...
    let mkBndry :: NamesT (TCMT IO) (Abs [Term])
-> NamesT
     (TCMT IO) [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
mkBndry NamesT (TCMT IO) (Abs [Term])
args = do
            [NamesT (TCMT IO) Term]
args1 <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ (forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
            -- faces ought to be constant on "j"
            [Term]
faces <- forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst) AbsN [(Term, Term)]
old_sides) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
args1
            [Term]
us <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd) AbsN [(Term, Term)]
old_sides) forall a b. (a -> b) -> a -> b
$ \ AbsN Term
u -> do
                  forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> do
                    [NamesT (TCMT IO) Term]
args <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ (forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
j)
                    forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Term
u forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
args
            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 [Term]
faces [Term]
us) forall a b. (a -> b) -> a -> b
$ \ (Term
phi,Term
u) -> forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
phi) (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u)
    Term
rhs <- do
      NamesT (TCMT IO) (Abs [Term])
d_f <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
        Abs Telescope
tel <- forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> NamesT (TCMT IO) (AbsN Telescope)
delta forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Vars (TCMT IO)
g1 forall a. [a] -> [a] -> [a]
++ [forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_rec forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
j])
        let face :: Term
face = Term
iz
        Term
j <- Var (TCMT IO)
j
        Args
d <- forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Arg e
defaultArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Vars (TCMT IO)
d
        forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ QName -> Abs Telescope -> Term -> Args -> Term -> TCM [Term]
covFillTele QName
f Abs Telescope
tel Term
face Args
d Term
j
      let args :: NamesT (TCMT IO) (Abs [Term])
args = forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
            [Term]
g1 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Vars (TCMT IO)
g1
            Term
x <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_rec forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg Var (TCMT IO)
j
            [Term]
ys <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
d_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg Var (TCMT IO)
j
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ [Term]
g1 forall a. [a] -> [a] -> [a]
++ Term
xforall a. a -> [a] -> [a]
:[Term]
ys
      NamesT (TCMT IO) (Abs Type)
ty <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
           [NamesT (TCMT IO) Term]
args <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
j
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t e. Dom' t e -> e
unDom forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (AbsN (Dom Type))
old_ty forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
args
      let face :: NamesT (TCMT IO) Term
face = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
      NamesT (TCMT IO) Term
othersys <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> do
        [NamesT (TCMT IO) Term]
args' <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
j
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QName -> [Elim] -> Term
Def QName
f) forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
args'
      [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys <- NamesT (TCMT IO) (Abs [Term])
-> NamesT
     (TCMT IO) [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
mkBndry NamesT (TCMT IO) (Abs [Term])
args
      let
        -- we could specialize all of sysphi/syspsi/base to compute
        -- away trX or the hcomp respectively, should lead to
        -- smaller/more efficient terms.
        --
        -- we could also ditch sysphi completely,
        -- as the computation rule for hcomp would achieve the same.
        sysphi :: NamesT (TCMT IO) Term
sysphi = NamesT (TCMT IO) Term
othersys
        syspsi :: NamesT (TCMT IO) Term
syspsi = NamesT (TCMT IO) Term
othersys
      NamesT (TCMT IO) Term
base <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
        [NamesT (TCMT IO) Term]
args' <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
        forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QName -> [Elim] -> Term
Def QName
f) forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
args'
      forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m) =>
NamesT m (Abs Type)
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpSys NamesT (TCMT IO) (Abs Type)
ty ((Var (TCMT IO)
phi,NamesT (TCMT IO) Term
sysphi)forall a. a -> [a] -> [a]
:(Var (TCMT IO)
psi,NamesT (TCMT IO) Term
syspsi)forall a. a -> [a] -> [a]
:[(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys) NamesT (TCMT IO) Term
face NamesT (TCMT IO) Term
base
    (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) (Dom Type)
rhsTy forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
rhs
  let ([NamedArg DeBruijnPattern]
ps,Dom Type
ty,Term
rhs) = forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ forall a. Abs a -> a
unAbs forall a b. (a -> b) -> a -> b
$ forall a. Abs a -> a
unAbs forall a b. (a -> b) -> a -> b
$ forall a. Abs a -> a
unAbs forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ forall a. Abs a -> a
unAbs forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ AbsN
  (Abs
     (AbsN
        (Abs
           (Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
ps_ty_rhs
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"trX-hcomp clause for" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
f
  let c :: Clause
c = Clause { clauseLHSRange :: Range
clauseLHSRange  = forall a. Range' a
noRange
                 , clauseFullRange :: Range
clauseFullRange = forall a. Range' a
noRange
                 , clauseTel :: Telescope
clauseTel       = Telescope
cTel
                 , namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg DeBruijnPattern]
ps
                 , clauseBody :: Maybe Term
clauseBody      = forall a. a -> Maybe a
Just Term
rhs
                 , clauseType :: Maybe (Arg Type)
clauseType      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. ArgInfo -> e -> Arg e
Arg (forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom Type
ty) (forall t e. Dom' t e -> e
unDom Dom Type
ty)
                 , clauseCatchall :: Bool
clauseCatchall    = Bool
False
                 , clauseExact :: Maybe Bool
clauseExact       = forall a. Maybe a
Nothing
                 , clauseRecursive :: Maybe Bool
clauseRecursive   = forall a. a -> Maybe a
Just Bool
True
                 , clauseUnreachable :: Maybe Bool
clauseUnreachable = forall a. a -> Maybe a
Just Bool
False
                 , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis    = ExpandedEllipsis
NoEllipsis
                 , clauseWhereModule :: Maybe ModuleName
clauseWhereModule = forall a. Maybe a
Nothing
                 }
  String -> Clause -> TCMT IO ()
debugClause String
"tc.cover.trx.hcomp" Clause
c
  forall (m :: * -> *) a. Monad m => a -> m a
return Clause
c
createMissingTrXConClause :: QName -- trX
                            -> QName -- f defined
                            -> Arg Nat
                            -> BlockingVar
                            -> SplitClause
                            -> QName -- constructor name
                            -> UnifyEquiv
                            -> TCM Clause
createMissingTrXConClause :: QName
-> QName
-> Arg Int
-> BlockingVar
-> SplitClause
-> QName
-> UnifyEquiv
-> TCM Clause
createMissingTrXConClause QName
q_trX QName
f Arg Int
n BlockingVar
x SplitClause
old_sc QName
c (UE Telescope
gamma Telescope
gamma' Telescope
xTel [Term]
u [Term]
v PatternSubstitution
rho Substitution
tau Substitution
leftInv) = do
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trxcon" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"trX-con clause for" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
f forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"with con" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
c
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trxcon" Int
20 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
"gamma" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
gamma
    , TCMT IO Doc
"gamma'" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
gamma'
    , TCMT IO Doc
"xTel" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
xTel)
    , TCMT IO Doc
"u"  forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Term]
u)
    , TCMT IO Doc
"v"  forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Term]
v)
    , TCMT IO Doc
"rho" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma' (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM PatternSubstitution
rho)
    ]

  Constructor{conSrcCon :: Defn -> ConHead
conSrcCon = ConHead
chead} <- Definition -> Defn
theDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
c

  -- = TheInfo $ UE delta1' eqTel (map unArg conIxs) (map unArg givenIxs) rho0 tau leftInv

  -- η : Params_D ⊢ c : (a : Args(η)) → D η (ξ(η,a))

  -- scTel old_sc = Γ1, (x : D η v), Δ
  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [α(γ1,x,δ) ↦ e(γ1,x,δ)]

  -- Γ = Γ1, a : Args(η)
  -- Γ ⊢ u = ξ(η,a)
  -- Γ ⊢ c a : D η u

  -- Γ' ⊢ ρ : Γ

  -- Γ' ⊢ u[ρ] = v[ρ] : X(η)[ρ]

  -- Γ' ⊢ c a[ρ] : (D η v)[ρ]

  -- Γ' ⊢ ρx := ρ,x = c a[ρ] : Γ,(x : D η v)

  -- Γ',Δ[ρx] ⊢ old_t[ρx]
  -- Γ',Δ[ρx] ⊢ f old_ps[ρx] : old_t[ρx] [α[ρx] ↦ e[γ1,x,δ][ρx]]

  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ τ : Γ'

  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ [ρx][τ] = [ρ[τ], x = c a[ρ[τ]]] : Γ,(x : D η v)

  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv : ρ[τ],i1,refl ≡ idS : Γ,(φ : I),(p : Path X(η) u v)

  -- Γ,(φ : I),(p : Path X(η) u v)| (i : I) ⊢ leftInv i : Γ,(φ : I),(p : Path X(η) u v)

  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv i0 = ρ[τ],i1,refl : Γ,(φ : I),(p : Path X(η) u v)
  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ leftInv i1 = γ   ,φ ,p    : Γ,(φ : I),(p : Path X(η) u v)
  --                                 leftInv[φ = i1][i] = idS

  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢ τ' = liftS |Δ[ρx]| τ : Γ',Δ[ρx]

  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢
  --            w := f old_ps[γ1[ρ[τ]],x = c a[ρ[τ]],δ] : old_t[ρx][τ'] = old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ]

  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ], α(γ1,x,δ)[ρx][τ'] ⊢ w = e(γ1,x,δ)[ρx][τ']

  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ pat := trX p φ (c a) : D η v


  -- Ξ := Γ,(φ : I),(p : Path X(η) u v),(δ : Δ[x = pat])

  -- Ξ ⊢ δ_f[1] = trTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = c a[ρ[τ]]]

  -- Ξ ⊢ w[δ_f[1]] : old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ_f[1]]
  -- Ξ, α(γ1,x,δ)[ρx][τ'][δ = δ_f[1]] ⊢ w[δ_f[1]] = e(γ1,x,δ)[ρx][τ'][δ_f[1]]

  -- Ξ, α(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1]) ⊢ w[δ_f[1]] = e(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1])

  -- Recap:
  -- Γ1, (x : D η v), Δ ⊢ f old_ps : old_t [α(γ1,x,δ) ↦ e(γ1,x,δ)]
  -- Ξ := Γ,(φ : I),(p : Path X(η) u v),(δ : Δ[x = pat])
  -- Ξ ⊢ δ_f[1] := trTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = c a[ρ[τ]]]
  -- Γ,(φ : I),(p : Path X(η) u v),Δ[ρx][τ] ⊢
  --            w := f old_ps[γ1[ρ[τ]],x = c a[ρ[τ]],δ] : old_t[ρx][τ'] = old_t[γ1[ρ[τ]],x = c a[ρ[τ]],δ]
  -- Γ,(φ : I),(p : Path X(η) u v) ⊢ pat := trX p φ (c a) : D η v


  -- Ξ ⊢ ?rhs : old_t[γ1,x = pat,δ] [α(γ1,pat,δ) ↦ e(γ1,pat,δ)
  --                               ,φ           ↦ w
  --                               ]

  -- ?rhs := transp (i. old_t[γ1[leftInv i],x = pat[leftInv i], δ_f[~i]]) φ (w[δ_f[1]])

  -- we shall consider α(γ1,pat,δ) = α(γ1[ρ[τ]],c a[ρ[τ]],δ_f[1])
  -- also rather than (p : Path X(η) u v) we'll have (p : I -> X(η)), same as the type of trX.

  Term
iz <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
  Type
interval <- forall (m :: * -> *). Functor m => m Term -> m Type
elInf forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primInterval
  let
      old_tel :: Telescope
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
      old_ps :: NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
      old_ty :: NamesT (TCMT IO) (AbsN (Dom Type))
old_ty = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
  -- old_tel = Γ(x: D η v)Δ
  -- Γ1, (x : D η v)  ⊢ delta = (δ : Δ)
      (Telescope
gamma1x,Telescope
delta') = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt (forall a. Sized a => a -> Int
size Telescope
old_tel forall a. Num a => a -> a -> a
- BlockingVar -> Int
blockingVarNo BlockingVar
x) Telescope
old_tel
  let
    gammaArgNames :: [Arg String]
gammaArgNames = Telescope -> [Arg String]
teleArgNames Telescope
gamma
    deltaArgNames :: [Arg String]
deltaArgNames = Telescope -> [Arg String]
teleArgNames Telescope
delta'
  let
    xTelI :: NamesT (TCMT IO) (AbsN Telescope)
xTelI = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma) forall a b. (a -> b) -> a -> b
$ Type -> Telescope -> Telescope
expTelescope Type
interval Telescope
xTel
    delta :: NamesT (TCMT IO) (AbsN Telescope)
delta = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1x) forall a b. (a -> b) -> a -> b
$ Telescope
delta'
    gamma1_size :: Int
gamma1_size = (forall a. Sized a => a -> Int
size Telescope
gamma1x forall a. Num a => a -> a -> a
- Int
1)
    (Telescope
gamma1,ExtendTel Dom Type
dType' Abs Telescope
_) = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt Int
gamma1_size Telescope
gamma1x
  AbsN Args
params <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma1 forall a b. (a -> b) -> a -> b
$ do
    Just (QName
_d, Args
ps, Args
_is) <- forall (m :: * -> *).
HasConstInfo m =>
Type -> m (Maybe (QName, Args, Args))
getDatatypeArgs forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Dom Type
dType'
    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1) Args
ps
  -- Γ, φ , p ⊢ pat := trX p φ (c a)
  let pat' :: NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
pat' =
            forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg String]
gammaArgNames forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
g1_args -> do
            forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg ([forall e. e -> Arg e
defaultArg String
"phi"] forall a. [a] -> [a] -> [a]
++ Telescope -> [Arg String]
teleArgNames Telescope
xTel) forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
phi_p -> do
            let ([NamesT (TCMT IO) (NamedArg DeBruijnPattern)]
g1,[NamesT (TCMT IO) (NamedArg DeBruijnPattern)]
args) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
gamma1_size ArgVars (TCMT IO)
g1_args
            (NamedArg DeBruijnPattern
phi:[NamedArg DeBruijnPattern]
p) <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence ArgVars (TCMT IO)
phi_p
            [NamedArg DeBruijnPattern]
args <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [NamesT (TCMT IO) (NamedArg DeBruijnPattern)]
args
            let cargs :: NamedArg DeBruijnPattern
cargs = forall e. e -> Arg e
defaultArg forall a b. (a -> b) -> a -> b
$ forall a name. a -> Named name a
unnamed forall a b. (a -> b) -> a -> b
$ forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
chead ConPatternInfo
noConPatternInfo [NamedArg DeBruijnPattern]
args
            -- Amy (2022-11-06): Set the parameters to quantity-0.
            [NamedArg DeBruijnPattern]
param_args <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a b. (a -> b) -> [a] -> [b]
map (forall a. LensQuantity a => Quantity -> a -> a
setQuantity (Q0Origin -> Quantity
Quantity0 Q0Origin
Q0Inferred) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a name. a -> Named name a
unnamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Term -> Pattern' a
dotP))) forall a b. (a -> b) -> a -> b
$
              forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Args
params forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` forall a. Int -> [a] -> [a]
take Int
gamma1_size (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall e. Arg e -> e
unArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgVars (TCMT IO)
g1_args)
            forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
defaultPatternInfo QName
q_trX forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern]
param_args forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern]
p forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern
phi,NamedArg DeBruijnPattern
cargs]
      pat :: NamesT (TCMT IO) (AbsN (AbsN Term))
pat = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
pat'
      pat_left' :: NamesT (TCMT IO) (AbsN (AbsN (Abs Term)))
pat_left' = (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (forall a. String -> a -> Abs a
Abs String
"i" forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
leftInv)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (AbsN Term))
pat
      g1_left' :: NamesT (TCMT IO) (AbsN (AbsN (Abs [Term])))
g1_left' = forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
gammaArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1_args -> do
                forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ [forall e. e -> Arg e
defaultArg String
"phi"] forall a. [a] -> [a] -> [a]
++ Telescope -> [Arg String]
teleArgNames Telescope
xTel) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
phi_p -> do
                [Term]
g1 <- forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
gamma1_size Vars (TCMT IO)
g1_args :: NamesT TCM [Term]
                forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. String -> a -> Abs a
Abs String
"i" (forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
leftInv [Term]
g1)

  NamesT (TCMT IO) Telescope
gamma <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Telescope
gamma
  let deltaPat :: [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Telescope
deltaPat [NamesT (TCMT IO) Term]
g1_args NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p =
        NamesT (TCMT IO) (AbsN Telescope)
delta forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (forall a. Int -> [a] -> [a]
take Int
gamma1_size [NamesT (TCMT IO) Term]
g1_args forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN Term))
pat forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
g1_args forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
phiforall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
p)])
  let neg :: NamesT m Term -> NamesT m Term
neg NamesT m Term
i = forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i
  -- Ξ
  Telescope
cTel <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN NamesT (TCMT IO) Telescope
gamma forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1_args -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"φ" (forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (NamesT (TCMT IO) (AbsN Telescope)
xTelI forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1_args) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
    [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Telescope
deltaPat Vars (TCMT IO)
g1_args Var (TCMT IO)
phi Vars (TCMT IO)
p
  AbsN
  (Abs (AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
ps_ty_rhs <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg String]
gammaArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1_args -> do
    forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"phi" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (Telescope -> [String]
teleNames Telescope
xTel) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ [Arg String]
deltaArgNames) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
d -> do
    let
      g1_left :: NamesT (TCMT IO) (Abs [Term])
g1_left = NamesT (TCMT IO) (AbsN (AbsN (Abs [Term])))
g1_left' forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1_args forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
p)
      pat_left :: NamesT (TCMT IO) (Abs Term)
pat_left = NamesT (TCMT IO) (AbsN (AbsN (Abs Term)))
pat_left' forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1_args forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
p)
      g1 :: Vars TCM
      g1 :: Vars (TCMT IO)
g1 = forall a. Int -> [a] -> [a]
take Int
gamma1_size Vars (TCMT IO)
g1_args

      args :: Vars TCM
      args :: Vars (TCMT IO)
args = forall a. Int -> [a] -> [a]
drop Int
gamma1_size Vars (TCMT IO)
g1_args

      ps :: NamesT TCM NAPs
      ps :: NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps = NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Vars (TCMT IO)
g1 forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
pat' forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1_args forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
p)] forall a. [a] -> [a] -> [a]
++ Vars (TCMT IO)
d)

      rhsTy :: NamesT (TCMT IO) (Dom Type)
rhsTy = NamesT (TCMT IO) (AbsN (Dom Type))
old_ty forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Vars (TCMT IO)
g1 forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN Term))
pat forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` Vars (TCMT IO)
g1_args forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Var (TCMT IO)
phiforall a. a -> [a] -> [a]
:Vars (TCMT IO)
p)] forall a. [a] -> [a] -> [a]
++ Vars (TCMT IO)
d)

    -- (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]])
    NamesT (TCMT IO) (Abs Telescope)
delta_f <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
      let ni :: NamesT (TCMT IO) Term
ni = forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg Var (TCMT IO)
i
      [NamesT (TCMT IO) Term]
dargs <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
        [Term]
xs <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
g1_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
ni
        Term
y <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
ni
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Term]
xs forall a. [a] -> [a] -> [a]
++ [Term
y]
      NamesT (TCMT IO) (AbsN Telescope)
delta forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
dargs

    --  trFillTel (i. Δ[γ1[leftInv (~ i)], pat[leftInv (~i)]]) φ δ
    NamesT (TCMT IO) (Abs [Term])
d_f <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
      Abs Telescope
delta_f <- NamesT (TCMT IO) (Abs Telescope)
delta_f
      Term
phi <- Var (TCMT IO)
phi
      Args
d <- forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Arg e
defaultArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence Vars (TCMT IO)
d
      Term
i <- Var (TCMT IO)
i
      forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ QName -> Abs Telescope -> Term -> Args -> Term -> TCM [Term]
covFillTele QName
f Abs Telescope
delta_f Term
phi Args
d Term
i

    -- w = Def f (old_ps[g1_left[i],pat_left[i],d_f[~ i]])
    NamesT (TCMT IO) (Abs Term)
w <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
      [NamesT (TCMT IO) Term]
psargs <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
        [Term]
xs <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
g1_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
        Term
y <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
        [Term]
zs <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
d_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg Var (TCMT IO)
i
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Term]
xs forall a. [a] -> [a] -> [a]
++ [Term
y] forall a. [a] -> [a] -> [a]
++ [Term]
zs
      [Elim]
ps <- (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps) forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
psargs
      forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
f [Elim]
ps


    -- (i. old_t[γ1[leftInv i],x = pat[leftInv i], δ_f[~i]])
    NamesT (TCMT IO) (Abs Type)
ty <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
      [NamesT (TCMT IO) Term]
tyargs <- (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
        [Term]
xs <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
g1_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
        Term
y <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
        [Term]
zs <- forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
d_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg Var (TCMT IO)
i
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [Term]
xs forall a. [a] -> [a] -> [a]
++ [Term
y] forall a. [a] -> [a] -> [a]
++ [Term]
zs
      forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t e. Dom' t e -> e
unDom forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (AbsN (Dom Type))
old_ty forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
tyargs

    [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys <- do
      [(Term, Abs Term)]
sides <- do
        Term
neg <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
        Term
io <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
        [Int]
vs <- forall p. IApplyVars p => p -> [Int]
iApplyVars forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps
        Abs Term
tm <- NamesT (TCMT IO) (Abs Term)
w
        [(Term, (Abs Term, Abs Term))]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs forall a b. (a -> b) -> a -> b
$ \ Int
v ->
            -- have to reduce these under the appropriate substitutions, otherwise non-normalizing(?)
              forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Term
var Int
v,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ (forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
iz forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Abs Term
tm, forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
io forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Abs Term
tm)
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Term
v,(Abs Term
l,Abs Term
r)) -> [(Term
neg forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
v],Abs Term
l),(Term
v,Abs Term
r)]) [(Term, (Abs Term, Abs Term))]
xs
      forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Term, Abs Term)]
sides forall a b. (a -> b) -> a -> b
$ \ (Term
psi,Abs Term
u') -> do
        NamesT (TCMT IO) (Abs Term)
u' <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Abs Term
u'
        Term
u <- forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
o -> forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
u' forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
i
        (,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
psi forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u

    let rhs :: NamesT (TCMT IO) Term
rhs = forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m) =>
NamesT m (Abs Type)
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpSys NamesT (TCMT IO) (Abs Type)
ty [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys Var (TCMT IO)
phi (forall a. Subst a => Abs a -> SubstArg a -> a
absApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
w forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz)

    (,,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) (Dom Type)
rhsTy forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
rhs

  let ([NamedArg DeBruijnPattern]
ps,Dom Type
ty,Term
rhs) = forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ forall a. Abs a -> a
unAbs forall a b. (a -> b) -> a -> b
$ forall a. AbsN a -> a
unAbsN forall a b. (a -> b) -> a -> b
$ AbsN
  (Abs (AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
ps_ty_rhs
  [QName]
qs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *). HasBuiltins m => String -> m (Maybe QName)
getName') [String
builtinINeg, String
builtinIMax, String
builtinIMin]
  Term
rhs <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
cTel forall a b. (a -> b) -> a -> b
$
           forall (m :: * -> *) a. MonadTCEnv m => ReduceDefs -> m a -> m a
locallyReduceDefs (Set QName -> ReduceDefs
OnlyReduceDefs (forall a. Ord a => [a] -> Set a
Set.fromList forall a b. (a -> b) -> a -> b
$ QName
q_trX forall a. a -> [a] -> [a]
: [QName]
qs)) forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Normalise a, MonadReduce m) => a -> m a
normalise Term
rhs
  let cl :: Clause
cl = Clause { clauseLHSRange :: Range
clauseLHSRange  = forall a. Range' a
noRange
                  , clauseFullRange :: Range
clauseFullRange = forall a. Range' a
noRange
                  , clauseTel :: Telescope
clauseTel       = Telescope
cTel
                  , namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg DeBruijnPattern]
ps
                  , clauseBody :: Maybe Term
clauseBody      = forall a. a -> Maybe a
Just Term
rhs
                  , clauseType :: Maybe (Arg Type)
clauseType      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. ArgInfo -> e -> Arg e
Arg (forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom Type
ty) (forall t e. Dom' t e -> e
unDom Dom Type
ty)
                  , clauseCatchall :: Bool
clauseCatchall    = Bool
False
                  , clauseExact :: Maybe Bool
clauseExact       = forall a. Maybe a
Nothing
                  , clauseRecursive :: Maybe Bool
clauseRecursive   = forall a. a -> Maybe a
Just Bool
True
                  , clauseUnreachable :: Maybe Bool
clauseUnreachable = forall a. a -> Maybe a
Just Bool
False
                  , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis    = ExpandedEllipsis
NoEllipsis
                  , clauseWhereModule :: Maybe ModuleName
clauseWhereModule = forall a. Maybe a
Nothing
                  }


  String -> Clause -> TCMT IO ()
debugClause String
"tc.cover.trxcon" Clause
cl

  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trxcon" 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
"clause:"
    ,  forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. QName -> a -> QNamed a
QNamed QName
f forall a b. (a -> b) -> a -> b
$ Clause
cl
    ]

  let mod :: Modality
mod =
        forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant forall a b. (a -> b) -> a -> b
$  -- See #5611.
        forall a. LensModality a => a -> Modality
getModality forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
  -- we follow what `cover` does when updating the modality from the target.
  forall (tcm :: * -> *) m a.
(MonadTCEnv tcm, LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext Modality
mod forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC forall a. LensQuantity a => a -> Bool
hasQuantity0) forall a b. (a -> b) -> a -> b
$ do
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trxcon" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"testing usable at mod: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Modality
mod
    forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
cTel forall a b. (a -> b) -> a -> b
$ MonadConstraint (TCMT IO) =>
WhyCheckModality -> Modality -> Term -> TCMT IO ()
usableAtModality WhyCheckModality
IndexedClause Modality
mod Term
rhs

  forall (m :: * -> *) a. Monad m => a -> m a
return Clause
cl

-- | If given @TheInfo{}@ then assumes "x : Id u v" and
--   returns both a @SplittingDone@ for conId, and the @Clause@ that covers it.
createMissingConIdClause :: QName         -- ^ function being defined
                         -> Arg Nat       -- ^ @covSplitArg@ index
                         -> BlockingVar   -- ^ @x@ variable being split on.
                         -> SplitClause   -- ^ clause before split
                         -> IInfo         -- ^ info from unification
                         -> TCM (Maybe ((SplitTag,SplitTree),Clause))
createMissingConIdClause :: QName
-> Arg Int
-> BlockingVar
-> SplitClause
-> IInfo
-> TCM (Maybe ((SplitTag, SplitTree' SplitTag), Clause))
createMissingConIdClause QName
f Arg Int
_n BlockingVar
x SplitClause
old_sc (TheInfo UnifyEquiv
info) = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
f forall a b. (a -> b) -> a -> b
$ do
  let
    -- iΓ'
    itel :: UnifyEquiv -> Telescope
itel = UnifyEquiv -> Telescope
infoTel
    -- with 3 params, reflId : Id A u u -- no arguments.
    -- iΓ' ⊢ iρ : Γ
    --
    -- Δ = Γ,φ,(p : u ≡ v) ⊢ iτ : iΓ'
    -- ρ = iρ
    -- τ = iτ
    irho :: PatternSubstitution
irho = UnifyEquiv -> PatternSubstitution
infoRho UnifyEquiv
info
    itau :: Substitution
itau = UnifyEquiv -> Substitution
infoTau UnifyEquiv
info
    ileftInv :: Substitution
ileftInv = UnifyEquiv -> Substitution
infoLeftInv UnifyEquiv
info
  Type
interval <- forall (m :: * -> *). Functor m => m Term -> m Type
elInf forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primInterval
  Term
tTrans  <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primTrans
  Term
tComp  <- 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)
getTerm' String
builtinComp
  QName
conId <- 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 QName)
getName' String
builtinConId
  let bindSplit :: (Telescope, a) -> (Telescope, AbsN a)
bindSplit (Telescope
tel1,a
tel2) = (Telescope
tel1,forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
tel1) a
tel2)
  let
      old_tel :: Telescope
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc

  -- old_tel = Γ(x: Id A u v)Δ
  -- Γ(x: Id A u v)Δ ⊢ old_t
  -- Γ ⊢ hdelta = (x : Id A u v)(δ : Δ)
      pair :: (Telescope, Telescope)
pair@(Telescope
_gamma,_hdelta :: Telescope
_hdelta@(ExtendTel Dom Type
hdom Abs Telescope
delta)) = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt (forall a. Sized a => a -> Int
size Telescope
old_tel forall a. Num a => a -> a -> a
- (BlockingVar -> Int
blockingVarNo BlockingVar
x forall a. Num a => a -> a -> a
+ Int
1)) Telescope
old_tel
      (Telescope
gamma,AbsN Telescope
hdelta) = forall {a}. (Telescope, a) -> (Telescope, AbsN a)
bindSplit (Telescope, Telescope)
pair
      old_t :: AbsN (Dom Type)
old_t  = forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) forall a b. (a -> b) -> a -> b
$ forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
      old_ps :: AbsN [Elim]
old_ps = forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
      old_ps' :: AbsN [NamedArg DeBruijnPattern]
old_ps' = forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc

  AbsN [Term]
params <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
    NamesT (TCMT IO) (AbsN Telescope)
hdelta <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open AbsN Telescope
hdelta
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (Telescope -> [String]
teleNames Telescope
gamma) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
args -> do
       hdelta :: Telescope
hdelta@(ExtendTel Dom Type
hdom Abs Telescope
_) <- forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
applyN NamesT (TCMT IO) (AbsN Telescope)
hdelta Vars (TCMT IO)
args
       Def QName
_Id es :: [Elim]
es@[Elim
_,Elim
_,Elim
_,Elim
_] <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall t a. Type'' t a -> a
unEl forall a b. (a -> b) -> a -> b
$ forall t e. Dom' t e -> e
unDom Dom Type
hdom
       forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es

  Telescope
working_tel <- forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
    NamesT (TCMT IO) (AbsN Telescope)
hdelta <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open AbsN Telescope
hdelta
    NamesT (TCMT IO) (AbsN [Term])
params <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open AbsN [Term]
params
    forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (forall (f :: * -> *) a. Applicative f => a -> f a
pure Telescope
gamma) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
args -> do
      NamesT (TCMT IO) Telescope
pTel <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Telescope -> Args -> Args -> m Telescope
pathTelescope (UnifyEquiv -> Telescope
infoEqTel UnifyEquiv
info) (forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Arg e
defaultArg forall a b. (a -> b) -> a -> b
$ UnifyEquiv -> [Term]
infoEqLHS UnifyEquiv
info) (forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Arg e
defaultArg forall a b. (a -> b) -> a -> b
$ UnifyEquiv -> [Term]
infoEqRHS UnifyEquiv
info))
      forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (forall (f :: * -> *) a. Applicative f => a -> f a
pure (ListTel -> Telescope
telFromList [forall a. a -> Dom a
defaultDom (String
"phi",Type
interval)] :: Telescope)) forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term
phi] ->
        forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN NamesT (TCMT IO) Telescope
pTel forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term
p] -> do
          [NamesT (TCMT IO) Term
l,NamesT (TCMT IO) Term
bA,NamesT (TCMT IO) Term
x,NamesT (TCMT IO) Term
y] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
applyN NamesT (TCMT IO) (AbsN [Term])
params Vars (TCMT IO)
args
          forall t. Apply t => t -> Term -> t
apply1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
applyN NamesT (TCMT IO) (AbsN Telescope)
hdelta Vars (TCMT IO)
args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primConId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
p)
  -- working_tel ⊢ i. γ[leftInv i]
  (Abs [Term]
gamma_args_left :: Abs [Term], Abs Term
con_phi_p_left :: Abs Term) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall a. Subst a => Int -> a -> a
raise (forall a. Sized a => a -> Int
size Abs Telescope
delta) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. AbsN a -> a
unAbsN) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
    NamesT (TCMT IO) (AbsN [Term])
params <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open AbsN [Term]
params
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (Telescope -> [String]
teleNames Telescope
gamma forall a. [a] -> [a] -> [a]
++ [String
"phi",String
"p"]) forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
args' -> do
      let ([NamesT (TCMT IO) Term]
args,[NamesT (TCMT IO) Term
phi,NamesT (TCMT IO) Term
p]) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall a. Sized a => a -> Int
size Telescope
gamma) Vars (TCMT IO)
args'
      [NamesT (TCMT IO) Term
l,NamesT (TCMT IO) Term
bA,NamesT (TCMT IO) Term
x,NamesT (TCMT IO) Term
y] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
applyN NamesT (TCMT IO) (AbsN [Term])
params [NamesT (TCMT IO) Term]
args
      Abs [Term]
gargs <- forall a. String -> a -> Abs a
Abs String
"i" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
ileftInv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [NamesT (TCMT IO) Term]
args
      Abs Term
con_phi_p <- forall a. String -> a -> Abs a
Abs String
"i" forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
ileftInv forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primConId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
p)
      forall (m :: * -> *) a. Monad m => a -> m a
return (Abs [Term]
gargs,Abs Term
con_phi_p)
  [NamedArg DeBruijnPattern]
ps <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. AbsN a -> a
unAbsN forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
    NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps' <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ AbsN [NamedArg DeBruijnPattern]
old_ps'
    NamesT (TCMT IO) (AbsN [Term])
params <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open AbsN [Term]
params
    forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (Telescope -> [String]
teleNames Telescope
working_tel) forall a b. (a -> b) -> a -> b
$ \ ([NamesT (TCMT IO) Term]
wargs :: [NamesT TCM Term]) -> do
      let ([NamedArg DeBruijnPattern]
g,NamedArg DeBruijnPattern
phi:NamedArg DeBruijnPattern
p:[NamedArg DeBruijnPattern]
d) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall a. Sized a => a -> Int
size Telescope
gamma) forall a b. (a -> b) -> a -> b
$ forall a.
DeBruijn a =>
Telescope -> [(Term, (Term, Term))] -> [NamedArg (Pattern' a)]
telePatterns Telescope
working_tel []
      [NamedArg DeBruijnPattern]
params <- forall a b. (a -> b) -> [a] -> [b]
map (forall e. e -> Arg e
argH forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a name. a -> Named name a
unnamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Term -> Pattern' a
dotP) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
applyN NamesT (TCMT IO) (AbsN [Term])
params (forall a. Int -> [a] -> [a]
take (forall a. Sized a => a -> Int
size Telescope
gamma) [NamesT (TCMT IO) Term]
wargs)
      let x :: DeBruijnPattern
x = forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
defaultPatternInfo QName
conId forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern]
params forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern
phi,NamedArg DeBruijnPattern
p]
      NamesT (TCMT IO) [DeBruijnPattern]
args <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedArg a -> a
namedArg [NamedArg DeBruijnPattern]
g forall a. [a] -> [a] -> [a]
++ [DeBruijnPattern
x] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedArg a -> a
namedArg [NamedArg DeBruijnPattern]
d
      forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> NamesT m [SubstArg a] -> NamesT m a
applyN' NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps' NamesT (TCMT IO) [DeBruijnPattern]
args
  -- tel = Γ',Δ[ρ,x = refl]
  -- Γ' ⊢ ρ : Γ
  -- Γ' ⊢ u[ρ] = v[ρ] : A[ρ]

  -- Γ' ⊢ ρ,x=refl : Γ,(x : Id A u v)

  -- Γ',Δ[ρ,x = refl] ⊢ old_t[ρ,x=refl] = Δ₂ -> t
  -- Γ',Δ[ρ,x = refl] ⊢ f old_ps[ρ,x = refl] : old_t[ρ,x = refl]
  -- Γ,(φ : I),(p : Path A u v) ⊢ τ : Γ'

  -- Γ' ⊢ [ρ,x = refl u[ρ]] : Γ,(x : Id A u v)

  -- Γ,(φ : I),(p : Path A u v) ⊢ [ρ,x = refl u[ρ]][τ] = [ρ[τ], x = refl u[ρ[τ]]] : Γ,(x : Id A u v)

  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv : ρ[τ],i1,refl ≡ idS : Γ,(φ : I),(p : Path A u v)

  -- Γ,(φ : I),(p : Path A u v)| (i : I) ⊢ leftInv i : Γ,(φ : I),(p : Path A u v)

  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i0 = ρ[τ],i1,refl : Γ,(φ : I),(p : Path A u v)
  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i1 = γ   ,φ ,p : Γ,(φ : I),(p : Path A u v)
  --                      leftInv[φ = i1][i] = idS

  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ τ' = liftS |Δ[ρ,x = refl]| τ : Γ',Δ[ρ,x = refl]

  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢
  --            w = f old_ps[ρ[τ],x = refl u[ρ[τ]],δ] : old_t[ρ,x = refl][τ'] = old_t[ρ[τ],x = refl u[ρ[τ]],δ]

  -- Γ,(φ : I),(p : Path A u v) | (i : I) ⊢ μ = ⟨φ,p⟩[leftInv (~i)] : (Id A u v)[γ[leftInv (~ i)]]
  --                                     μ[0] = ⟨ φ             , p    ⟩
  --                                     μ[1] = ⟨ 1             , refl ⟩

  -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢
  --         δ_f[1] = vecTransp (i. Δ[γ[leftInv (~ i)], ⟨φ,p⟩[leftInv (~i)]]) φ δ : Δ[ρ[τ], x = refl u[ρ[τ]]]

  -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢ w[δ_f[1]] : old_t[ρ[τ],x = refl u[ρ[τ]],δ_f[1]]
  -- Γ,(φ : I),(p : Path A u v),Δ[x = ⟨ φ , p ⟩] ⊢ rhs = transp (i. old_t[γ[leftInv i],x = ⟨φ,p⟩[leftInv i], δ_f[~i]]) φ (w[δ_f[1]]) : old_t[γ,x = ⟨ φ , p ⟩,δ]
  let
      getLevel :: a -> m Term
getLevel a
t = do
        Sort
s <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall a. LensSort a => a -> Sort
getSort a
t
        case Sort
s of
          Type Level
l -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Level -> Term
Level Level
l)
          Sort
s      -> do
            forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"getLevel, s = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Sort
s
            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 :: * -> *). Applicative m => String -> m Doc
text String
"The sort of" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
t forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Applicative m => String -> m Doc
text String
"should be of the form \"Set l\"")
  (Dom Type
ty,Term
rhs) <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
working_tel forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
    let
        raiseFrom :: Subst a => Telescope -> a -> a
        raiseFrom :: forall a. Subst a => Telescope -> a -> a
raiseFrom Telescope
tel a
x = forall a. Subst a => Int -> a -> a
raise (forall a. Sized a => a -> Int
size Telescope
working_tel forall a. Num a => a -> a -> a
- forall a. Sized a => a -> Int
size Telescope
tel) a
x
        all_args :: Args
all_args = forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Telescope
working_tel :: Args
        (Args
gamma_args,Arg Term
phi:Arg Term
p:Args
delta_args) = forall a. Int -> [a] -> ([a], [a])
splitAt (forall a. Sized a => a -> Int
size Telescope
gamma) Args
all_args
    NamesT (TCMT IO) (AbsN (Dom Type))
old_t <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Telescope -> a -> a
raiseFrom forall a. Tele a
EmptyTel AbsN (Dom Type)
old_t
    NamesT (TCMT IO) (AbsN [Elim])
old_ps <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Telescope -> a -> a
raiseFrom forall a. Tele a
EmptyTel AbsN [Elim]
old_ps
    NamesT (TCMT IO) Args
delta_args <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Args
delta_args
    NamesT (TCMT IO) (Abs [Term])
gamma_args_left <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Abs [Term]
gamma_args_left
    NamesT (TCMT IO) (Abs Term)
con_phi_p_left <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Abs Term
con_phi_p_left
    NamesT (TCMT IO) (AbsN Telescope)
hdelta <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Telescope -> a -> a
raiseFrom Telescope
gamma AbsN Telescope
hdelta
    Abs Telescope
delta_f <- forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
      forall t. Apply t => t -> Term -> t
apply1 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> NamesT m [SubstArg a] -> NamesT m a
applyN' NamesT (TCMT IO) (AbsN Telescope)
hdelta (forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
gamma_args_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Var (TCMT IO)
i)) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
con_phi_p_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Var (TCMT IO)
i))
    NamesT (TCMT IO) (Abs Telescope)
delta_f <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Abs Telescope
delta_f
    [NamesT (TCMT IO) Term
phi,NamesT (TCMT IO) Term
p] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
phi,Arg Term
p]
    Abs Args
delta_args_f <- forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do

      ExceptT (Closure (Abs Type)) (TCMT IO) Args
m <- forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) m Args
trFillTel' Bool
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Telescope)
delta_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
phi forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Args
delta_args forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
      forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall a. HasCallStack => a
__IMPOSSIBLE__ forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT (Closure (Abs Type)) (TCMT IO) Args
m)
    NamesT (TCMT IO) (Abs Args)
delta_args_f <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Abs Args
delta_args_f
    NamesT (TCMT IO) (Abs (Dom Type))
old_t_f <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
      [Term]
g <- forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
gamma_args_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
      Term
x <- forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
con_phi_p_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
      Args
d <- forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Args)
delta_args_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Var (TCMT IO)
i)
      NamesT (TCMT IO) [Term]
args <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ [Term]
g forall a. [a] -> [a] -> [a]
++ [Term
x] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg Args
d
      forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> NamesT m [SubstArg a] -> NamesT m a
applyN' NamesT (TCMT IO) (AbsN (Dom Type))
old_t NamesT (TCMT IO) [Term]
args
    NamesT (TCMT IO) (Abs Term)
w <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
      [Term]
g <- forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
gamma_args_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
      Term
x <- forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
con_phi_p_left forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
      Args
d <- forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Args)
delta_args_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Var (TCMT IO)
i)
      NamesT (TCMT IO) [Term]
args <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ [Term]
g forall a. [a] -> [a] -> [a]
++ [Term
x] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg Args
d
      QName -> [Elim] -> Term
Def QName
f forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> NamesT m [SubstArg a] -> NamesT m a
applyN' NamesT (TCMT IO) (AbsN [Elim])
old_ps NamesT (TCMT IO) [Term]
args

    NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [NamedArg DeBruijnPattern]
ps
    Term
max <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax
    Term
iz <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
    NamesT (TCMT IO) Term
alphas <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
      [Int]
vs <- forall p. IApplyVars p => p -> [Int]
iApplyVars forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps
      Term
neg <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
      Term
zero <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
      forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Term
x Term
r -> Term
max forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN forall a b. (a -> b) -> a -> b
$ Term
max forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
x, forall e. e -> Arg e
argN (Term
neg forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
x])], forall e. e -> Arg e
argN Term
r]) Term
zero forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map Int -> Term
var [Int]
vs
    NamesT (TCMT IO) (Abs [(Term, Term)])
sides <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
      Term
neg <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
      Term
io <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
      forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
        [Int]
vs <- forall p. IApplyVars p => p -> [Int]
iApplyVars forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps
        Term
tm <- forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
w forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Var (TCMT IO)
i
        [(Term, (Term, Term))]
xs <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs forall a b. (a -> b) -> a -> b
$ \ Int
v ->
          -- have to reduce these under the appropriate substitutions, otherwise non-normalizing
          forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Term
var Int
v,) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ (forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
iz forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm, forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
io forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm)
        Int
phiv <- forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. DeBruijn a => a -> Maybe Int
deBruijnView forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
phi
        -- extra assumption: phi |- w i = w 0, otherwise we need [ phi -> w 0 ] specifically
        Term
tm_phi <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
phiv Term
io forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm
        Term
phi <- NamesT (TCMT IO) Term
phi
        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Term
phi,Term
tm_phi) forall a. a -> [a] -> [a]
: forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(Term
v,(Term
l,Term
r)) -> [(Term
neg forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
v],Term
l),(Term
v,Term
r)]) [(Term, (Term, Term))]
xs

    let imax :: Term -> Term -> Term
imax Term
i Term
j = forall t. Apply t => t -> Args -> t
apply Term
max forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Arg e
argN [Term
i,Term
j]
    Term
tPOr <- 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)
getTerm' String
builtinPOr
    let
      pOr :: NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> Term
-> Term
-> Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
pOr NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty Term
phi Term
psi Term
u0 NamesT (TCMT IO) Term
u1 = do
          [NamesT (TCMT IO) Term
phi,NamesT (TCMT IO) Term
psi] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Term
phi,Term
psi]
          forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
l
                    forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
psi
                    forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
ty) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall {m :: * -> *}. MonadFail m => Term -> NamesT m Term
noilam Term
u0 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u1

      noilam :: Term -> NamesT m Term
noilam Term
u = do
         NamesT m Term
u <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u
         forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
_ -> NamesT m Term
u

      combine :: NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> [(Term, Term)] -> NamesT (TCMT IO) Term
combine NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty [] = forall a. HasCallStack => a
__IMPOSSIBLE__
      combine NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty [(Term
psi,Term
u)] = forall {m :: * -> *}. MonadFail m => Term -> NamesT m Term
noilam Term
u
      combine NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty ((Term
psi,Term
u):[(Term, Term)]
xs) = NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> Term
-> Term
-> Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
pOr NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty Term
psi (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Term -> Term -> Term
imax Term
iz (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Term, Term)]
xs)) Term
u (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> [(Term, Term)] -> NamesT (TCMT IO) Term
combine NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty [(Term, Term)]
xs)

    let ty :: NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Dom Type)
ty NamesT (TCMT IO) Term
i = forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Dom Type))
old_t_f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
i
    NamesT (TCMT IO) Term
l <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> do
           Type
t <- forall t e. Dom' t e -> e
unDom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Dom Type)
ty NamesT (TCMT IO) Term
i
           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
(LensSort a, MonadError TCErr m, PrettyTCM a, MonadFresh NameId m,
 MonadInteractionPoints m, MonadStConcreteNames m, PureTCM m,
 IsString (m Doc), Null (m Doc), Semigroup (m Doc)) =>
a -> m Term
getLevel Type
t
    ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Dom Type)
ty (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) forall a b. (a -> b) -> a -> b
$ do
         Int
n <- forall (t :: * -> *) a. Foldable t => t a -> Int
length forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Abs a -> a
unAbs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [(Term, Term)])
sides
         -- TODO don't comp if the family and the sides "j. [ α ↦ u ]" are constant?
         if Int
n forall a. Ord a => a -> a -> Bool
> Int
1 then
           forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> forall t a. Type'' t a -> a
unEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Dom Type)
ty NamesT (TCMT IO) Term
i)
                forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
alphas)
                forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> [(Term, Term)] -> NamesT (TCMT IO) Term
combine (NamesT (TCMT IO) Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i) (forall t a. Type'' t a -> a
unEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Dom Type)
ty NamesT (TCMT IO) Term
i) forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [(Term, Term)])
sides forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
i))
                forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
w forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero)
         else
           forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> forall t a. Type'' t a -> a
unEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Dom Type)
ty NamesT (TCMT IO) Term
i)
                forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi
                forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
w forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero)

  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.conid" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"conid case for" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Applicative m => String -> m Doc
text (forall a. Show a => a -> String
show QName
f)
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.conid" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"tel =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
working_tel
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.conid" Int
25 forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
working_tel forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
rhs

  let cl :: Clause
cl =   Clause { clauseLHSRange :: Range
clauseLHSRange  = forall a. Range' a
noRange
                    , clauseFullRange :: Range
clauseFullRange = forall a. Range' a
noRange
                    , clauseTel :: Telescope
clauseTel       = Telescope
working_tel
                    , namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg DeBruijnPattern]
ps
                    , clauseBody :: Maybe Term
clauseBody      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Term
rhs
                    , clauseType :: Maybe (Arg Type)
clauseType      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. ArgInfo -> e -> Arg e
Arg (forall t e. Dom' t e -> ArgInfo
domInfo Dom Type
ty) (forall t e. Dom' t e -> e
unDom Dom Type
ty)
                    , clauseCatchall :: Bool
clauseCatchall    = Bool
False
                    , clauseUnreachable :: Maybe Bool
clauseUnreachable = forall a. a -> Maybe a
Just Bool
False  -- missing, thus, not unreachable
                    , clauseRecursive :: Maybe Bool
clauseRecursive   = forall a. a -> Maybe a
Just Bool
False
                    , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis    = ExpandedEllipsis
NoEllipsis
                    , clauseExact :: Maybe Bool
clauseExact       = forall a. Maybe a
Nothing
                    , clauseWhereModule :: Maybe ModuleName
clauseWhereModule = forall a. Maybe a
Nothing
                    }
  forall (m :: * -> *).
(MonadConstraint m, MonadTCState m) =>
QName -> [Clause] -> m ()
addClauses QName
f [Clause
cl]
  forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just ((QName -> SplitTag
SplitCon QName
conId,forall a. Int -> SplitTree' a
SplittingDone (forall a. Sized a => a -> Int
size Telescope
working_tel)),Clause
cl)
createMissingConIdClause QName
f Arg Int
n BlockingVar
x SplitClause
old_sc IInfo
NoInfo = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing


{-
  OLD leftInv case
  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv : ρ[τ] ≡ wkS 2 : Γ
  -- Γ,(φ : I),(p : Path A u v)(i : I) ⊢ leftInv i : Γ
  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i0 = ρ[τ] : Γ
  -- Γ,(φ : I),(p : Path A u v) ⊢ leftInv i1 = wkS 2 : Γ
  -- leftInv[φ = i1][i] = wkS 2

  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ τ' = liftS |Δ[ρ,x = refl]| τ : Γ',Δ[ρ,x = refl]

  -- Γ,(φ : I),(p : Path A u v),Δ[ρ,x = refl][τ] ⊢ w = f old_ps[ρ,x = refl][τ'] : old_t[ρ,x = refl][τ']

  -- Γ,(φ : I),(p : Path A u v) | (i : I) ⊢ μ = ⟨ (φ ∨ ~ i) , (\ j → p (i ∧ j)) ⟩ : Id A u (p i) =?= (Id A u v)[leftInv (~ i)]
                                  μ[0] = ⟨ 1 , (\ _ → u[ρ[τ]]) ⟩
                                  μ[1] = ⟨ φ , p               ⟩
  -- Γ,(φ : I),(p : Path A u v),(δ : Δ[x = ⟨ φ , p ⟩]) ⊢ vecTransp (i. Δ[leftInv (~ i),μ[i]]) φ δ : Δ[ρ[τ], x = refl u[ρ[τ]]]
-}

-- | Append an hcomp clause to the clauses of a function.
createMissingHCompClause
  :: QName
       -- ^ Function name.
  -> Arg Nat -- ^ index of hcomp pattern
  -> BlockingVar -- ^ Blocking var that lead to hcomp split.
  -> SplitClause -- ^ Clause before the hcomp split
  -> SplitClause
       -- ^ Clause to add.
  -> [Clause]
   -> TCM ([(SplitTag,CoverResult)], [Clause])
createMissingHCompClause :: QName
-> Arg Int
-> BlockingVar
-> SplitClause
-> SplitClause
-> [Clause]
-> TCM ([(SplitTag, CoverResult)], [Clause])
createMissingHCompClause QName
f Arg Int
n BlockingVar
x SplitClause
old_sc (SClause Telescope
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_sigma' Map CheckpointId Substitution
_cps (Just Dom Type
t)) [Clause]
cs = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
f forall a b. (a -> b) -> a -> b
$ do
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"Trying to create right-hand side of type" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Dom Type
t
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
30 forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"ps = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps)
  forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"tel = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel

  Term
io      <- 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)
getTerm' String
builtinIOne
  Term
iz      <- 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)
getTerm' String
builtinIZero
  let
    cannotCreate :: MonadTCError m => Doc -> Closure (Abs Type) -> m a
    cannotCreate :: forall (m :: * -> *) a.
MonadTCError m =>
Doc -> Closure (Abs Type) -> m a
cannotCreate Doc
doc Closure (Abs Type)
t = do
      forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall b c a. (b -> c) -> (a -> b) -> a -> c
. SplitError -> TypeError
SplitError forall a b. (a -> b) -> a -> b
$ QName
-> (Telescope, [NamedArg DeBruijnPattern])
-> Doc
-> Closure (Abs Type)
-> SplitError
CannotCreateMissingClause QName
f (Telescope
tel,[NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps) Doc
doc Closure (Abs Type)
t
  let old_ps :: [Elim]
old_ps = [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
      old_t :: Dom Type
old_t  = forall a. HasCallStack => Maybe a -> a
fromJust forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
      old_tel :: Telescope
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
      -- old_tel = Γ(x:H)Δ
      -- Γ(x:H)Δ ⊢ old_t
      -- vs = iApplyVars old_ps
      -- [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]

      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]
      -- Γ(x:H)Δ ⊢ f old_ps : old_t [ α ⇒ b ]
      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ rhs_we_define : (old_t[ α ⇒ b ])(x = hcomp φ u u0)

      -- Extra assumption:
      -- tel = Γ,φ,u,u0,Δ(x = hcomp φ u u0),Δ'
      -- ps = old_ps[x = hcomp φ u u0],ps'
      -- with Δ' and ps' introduced by fixTarget.
      -- So final clause will be:
      -- tel ⊢ ps ↦ rhs_we_define{wkS ..} ps'
      getLevel :: a -> m Term
getLevel a
t = do
        Sort
s <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall a. LensSort a => a -> Sort
getSort a
t
        case Sort
s of
          Type Level
l -> forall (f :: * -> *) a. Applicative f => a -> f a
pure (Level -> Term
Level Level
l)
          Sort
s      -> do
            forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"getLevel, s = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Sort
s
            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 :: * -> *). Applicative m => String -> m Doc
text String
"The sort of" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
t forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Applicative m => String -> m Doc
text String
"should be of the form \"Set l\"")

      -- Γ ⊢ hdelta = (x : H)(δ : Δ)
      (Telescope
gamma,hdelta :: Telescope
hdelta@(ExtendTel Dom Type
hdom Abs Telescope
delta)) = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt (forall a. Sized a => a -> Int
size Telescope
old_tel forall a. Num a => a -> a -> a
- (BlockingVar -> Int
blockingVarNo BlockingVar
x forall a. Num a => a -> a -> a
+ Int
1)) Telescope
old_tel

      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢
      (Telescope
working_tel,Telescope
_deltaEx) = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt (forall a. Sized a => a -> Int
size Telescope
gamma forall a. Num a => a -> a -> a
+ Int
3 forall a. Num a => a -> a -> a
+ forall a. Sized a => a -> Int
size Abs Telescope
delta) Telescope
tel

      -- Γ,φ,u,u0,(x:H)(δ : Δ) ⊢ rhoS : Γ(x:H)(δ : Δ)
      {- rhoS = liftS (size hdelta) $ raiseS 3 -}
      vs :: [Int]
vs = forall p. IApplyVars p => p -> [Int]
iApplyVars (SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc)

  -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]
  [(Term, (Term, Term))]
alphab <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs forall a b. (a -> b) -> a -> b
$ \ Int
i -> do
               let
                 -- Γ(x:H)(δ : Δ) ⊢
                 tm :: Term
tm = QName -> [Elim] -> Term
Def QName
f [Elim]
old_ps
               -- TODO only reduce IApply _ _ (0/1), as to avoid termination problems
               (Term
l,Term
r) <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
i Term
iz forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm, forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
i Term
io forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm)
               forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Int -> Term
var Int
i, (Term
l, Term
r))



  Clause
cl <- do
    (Type
ty,Term
rhs) <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
working_tel forall a b. (a -> b) -> a -> b
$ do
      -- Γ(x:H)Δ ⊢ g = f old_ps : old_t [ α ⇒ b ]
      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]
      -- Γ,φ,u,u0 ⊢ Δf = i.Δ[x = hfill φ u u0 i]
      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ δ_fill     = i.tFillTel (i. Δf[~i]) δ (~ i) : i.Δf[i]
      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ old_t_fill = i.old_t[x = hfill φ u u0 i, δ_fill[i]]
      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ comp (\ i. old_t_fill[i])
      --                 (\ i. [ φ ↦ g[x = hfill φ u u0 i,δ_fill[i]] = g[u i,δ_fill[i]]
      --                         α ↦ b[x = hfill φ u u0 i,δ_fill[i]]
      --                        ])
      --                 (g[x = u0,δ_fill[0]]) : old_t[x = hcomp φ u u0,δ]

      forall (m :: * -> *) a. [String] -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
          Term
tPOr <- 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)
getTerm' String
builtinPOr
          Term
tIMax <- 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)
getTerm' String
builtinIMax
          Term
tIMin <- 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)
getTerm' String
builtinIMin
          Term
tINeg <- 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)
getTerm' String
builtinINeg
          Term
tHComp <- 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)
getTerm' String
builtinHComp
          Term
tTrans <- 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)
getTerm' String
builtinTrans
          NamesT (TCMT IO) [Elim]
extra_ps <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
drop (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Elim]
old_ps) [NamedArg SplitPattern]
ps
          let
            ineg :: NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
ineg NamesT (TCMT IO) Term
j = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j
            imax :: NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
imax NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
j = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j
            trFillTel' :: t (TCMT IO) (Abs Telescope)
-> t (TCMT IO) Term
-> t (TCMT IO) Args
-> t (TCMT IO) Term
-> t (TCMT IO) Args
trFillTel' t (TCMT IO) (Abs Telescope)
a t (TCMT IO) Term
b t (TCMT IO) Args
c t (TCMT IO) Term
d = do
              ExceptT (Closure (Abs Type)) (TCMT IO) Args
m <- Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) Args
trFillTel forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (TCMT IO) (Abs Telescope)
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t (TCMT IO) Term
b forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t (TCMT IO) Args
c forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t (TCMT IO) Term
d
              Either (Closure (Abs Type)) Args
x <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT (Closure (Abs Type)) (TCMT IO) Args
m
              case Either (Closure (Abs Type)) Args
x of
                Left Closure (Abs Type)
bad_t -> forall (m :: * -> *) a.
MonadTCError m =>
Doc -> Closure (Abs Type) -> m a
cannotCreate Doc
"Cannot transport with type family:" Closure (Abs Type)
bad_t
                Right Args
args -> forall (m :: * -> *) a. Monad m => a -> m a
return Args
args
          NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
comp <- forall (m :: * -> *).
HasBuiltins m =>
String
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
mkCompLazy String
"hcompClause"
          let
            hcomp :: NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
hcomp NamesT (TCMT IO) Term
la NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
u NamesT (TCMT IO) Term
u0 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
bA
                                               forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
phi
                                               forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u
                                               forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u0

            hfill :: NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
hfill NamesT (TCMT IO) Term
la NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
u NamesT (TCMT IO) Term
u0 NamesT (TCMT IO) Term
i = NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
hcomp NamesT (TCMT IO) Term
la NamesT (TCMT IO) Term
bA
                                               (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i))
                                               (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
bA)
                                                     forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term
u forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o)
                                                     forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
u0)
                                                   )
                                               NamesT (TCMT IO) Term
u0
          -- Γ,φ,u,u0,(δ : Δ(x = hcomp φ u u0)) ⊢ hcompS : Γ(x:H)(δ : Δ)
          Substitution
hcompS <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ do
            Dom Type
hdom <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Int -> a -> a
raise Int
3 Dom Type
hdom
            let
              [TCMT IO Term
phi,TCMT IO Term
u,TCMT IO Term
u0] = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
var) [Int
2,Int
1,Int
0]
              htype :: TCMT IO Term
htype = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall t a. Type'' t a -> a
unEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom forall a b. (a -> b) -> a -> b
$ Dom Type
hdom
              lvl :: TCMT IO Term
lvl = forall {m :: * -> *} {a}.
(LensSort a, MonadError TCErr m, PrettyTCM a, MonadFresh NameId m,
 MonadInteractionPoints m, MonadStConcreteNames m, PureTCM m,
 IsString (m Doc), Null (m Doc), Semigroup (m Doc)) =>
a -> m Term
getLevel forall a b. (a -> b) -> a -> b
$ forall t e. Dom' t e -> e
unDom Dom Type
hdom
            Term
hc <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> TCMT IO Term
lvl forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> TCMT IO Term
htype
                                      forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> TCMT IO Term
phi
                                      forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term
u
                                      forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term
u0
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> Substitution' a -> Substitution' a
liftS (forall a. Sized a => a -> Int
size Abs Telescope
delta) forall a b. (a -> b) -> a -> b
$ Term
hc forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
`consS` forall a. Int -> Substitution' a
raiseS Int
3
          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ raise 3+|Δ| hdom
          Dom Type
hdom <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Int -> a -> a
raise (Int
3forall a. Num a => a -> a -> a
+forall a. Sized a => a -> Int
size Abs Telescope
delta) Dom Type
hdom
          NamesT (TCMT IO) Term
htype <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall t a. Type'' t a -> a
unEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom forall a b. (a -> b) -> a -> b
$ Dom Type
hdom
          NamesT (TCMT IO) Term
lvl <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {m :: * -> *} {a}.
(LensSort a, MonadError TCErr m, PrettyTCM a, MonadFresh NameId m,
 MonadInteractionPoints m, MonadStConcreteNames m, PureTCM m,
 IsString (m Doc), Null (m Doc), Semigroup (m Doc)) =>
a -> m Term
getLevel forall a b. (a -> b) -> a -> b
$ forall t e. Dom' t e -> e
unDom Dom Type
hdom)

          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢
          [NamesT (TCMT IO) Term
phi,NamesT (TCMT IO) Term
u,NamesT (TCMT IO) Term
u0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Subst a => Int -> a -> a
raise (forall a. Sized a => a -> Int
size Abs Telescope
delta) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> Term
var) [Int
2,Int
1,Int
0]
          -- Γ,x,Δ ⊢ f old_ps
          -- Γ ⊢ abstract hdelta (f old_ps)
          NamesT (TCMT IO) Term
g <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Int -> a -> a
raise (Int
3forall a. Num a => a -> a -> a
+forall a. Sized a => a -> Int
size Abs Telescope
delta) forall a b. (a -> b) -> a -> b
$ forall t. Abstract t => Telescope -> t -> t
abstract Telescope
hdelta (QName -> [Elim] -> Term
Def QName
f [Elim]
old_ps)
          NamesT (TCMT IO) Type
old_t <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Int -> a -> a
raise (Int
3forall a. Num a => a -> a -> a
+forall a. Sized a => a -> Int
size Abs Telescope
delta) forall a b. (a -> b) -> a -> b
$ forall t. Abstract t => Telescope -> t -> t
abstract Telescope
hdelta (forall t e. Dom' t e -> e
unDom Dom Type
old_t)
          let bapp :: f (Abs b) -> f (SubstArg b) -> f b
bapp f (Abs b)
a f (SubstArg b)
x = forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Abs b)
a forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (SubstArg b)
x
          (NamesT (TCMT IO) (Abs Args)
delta_fill :: NamesT TCM (Abs Args)) <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ x.Δ
            NamesT (TCMT IO) (Abs Telescope)
delta <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Int -> a -> a
raise (Int
3forall a. Num a => a -> a -> a
+forall a. Sized a => a -> Int
size Abs Telescope
delta) Abs Telescope
delta
            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ i.Δ(x = hfill phi u u0 (~ i))
            NamesT (TCMT IO) (Abs Telescope)
deltaf <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (\ Var (TCMT IO)
i ->
                           (NamesT (TCMT IO) (Abs Telescope)
delta forall {f :: * -> *} {b}.
(Applicative f, Subst b) =>
f (Abs b) -> f (SubstArg b) -> f b
`bapp` NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
hfill NamesT (TCMT IO) Term
lvl NamesT (TCMT IO) Term
htype NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
u NamesT (TCMT IO) Term
u0 (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
ineg Var (TCMT IO)
i)))
            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ Δ(x = hcomp phi u u0) = Δf[0]
            NamesT (TCMT IO) Args
args <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Telescope)
deltaf forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz)
            forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext (String
"i" :: String) forall a b. (a -> b) -> a -> b
$ do -- for error messages.
              -- Γ,φ,u,u0,Δ(x = hcomp phi u u0),(i:I) ⊢ ... : Δ(x = hfill phi u u0 i)
              forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, MonadTCEnv (t (TCMT IO)), ReadTCState (t (TCMT IO)),
 MonadError TCErr (t (TCMT IO))) =>
t (TCMT IO) (Abs Telescope)
-> t (TCMT IO) Term
-> t (TCMT IO) Args
-> t (TCMT IO) Term
-> t (TCMT IO) Args
trFillTel' NamesT (TCMT IO) (Abs Telescope)
deltaf (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT (TCMT IO) Args
args (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
ineg Var (TCMT IO)
i)
          let
            apply_delta_fill :: NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
apply_delta_fill NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
f = forall t. Apply t => t -> Args -> t
apply forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
f forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (NamesT (TCMT IO) (Abs Args)
delta_fill forall {f :: * -> *} {b}.
(Applicative f, Subst b) =>
f (Abs b) -> f (SubstArg b) -> f b
`bapp` NamesT (TCMT IO) Term
i)
            call :: NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
call NamesT (TCMT IO) Term
v NamesT (TCMT IO) Term
i = NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
apply_delta_fill NamesT (TCMT IO) Term
i forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
g forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
v
          NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
ty <- do
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> do
                    Term
v <- NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
hfill NamesT (TCMT IO) Term
lvl NamesT (TCMT IO) Term
htype NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
u NamesT (TCMT IO) Term
u0 NamesT (TCMT IO) Term
i
                    Type
hd <- NamesT (TCMT IO) Type
old_t
                    Args
args <- NamesT (TCMT IO) (Abs Args)
delta_fill forall {f :: * -> *} {b}.
(Applicative f, Subst b) =>
f (Abs b) -> f (SubstArg b) -> f b
`bapp` NamesT (TCMT IO) Term
i
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
piApplyM Type
hd forall a b. (a -> b) -> a -> b
$ forall e. ArgInfo -> e -> Arg e
Arg (forall t e. Dom' t e -> ArgInfo
domInfo Dom Type
hdom) Term
v forall a. a -> [a] -> [a]
: Args
args
          NamesT (TCMT IO) Term
ty_level <- do
            Abs Type
t <- forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
x -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
ty Var (TCMT IO)
x
            Sort
s <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall a. LensSort a => a -> Sort
getSort (forall a. Subst a => Abs a -> a
absBody Abs Type
t)
            forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"ty_level, s = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Sort
s
            case Sort
s of
              Type Level
l -> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (\ NamesT (TCMT IO) Term
_ -> forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Level -> Term
Level Level
l)
              Sort
_      -> do Closure (Abs Type)
cl <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Abs Type
t)
                           forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (forall (m :: * -> *) a.
MonadTCError m =>
Doc -> Closure (Abs Type) -> m a
cannotCreate Doc
"Cannot compose with type family:" Closure (Abs Type)
cl)

          let
            pOr_ty :: NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
pOr_ty NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
psi NamesT (TCMT IO) Term
u0 NamesT (TCMT IO) Term
u1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT (TCMT IO) Term
ty_level forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i)
                                               forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
psi
                                               forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT (TCMT IO) Term
_ -> forall t a. Type'' t a -> a
unEl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
ty NamesT (TCMT IO) Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u0 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u1
          NamesT (TCMT IO) Term
alpha <- do
            [NamesT (TCMT IO) Term]
vars <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
hcompS forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) [(Term, (Term, Term))]
alphab
            forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
imax forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ NamesT (TCMT IO) Term
v -> NamesT (TCMT IO) Term
v NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
`imax` NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
ineg NamesT (TCMT IO) Term
v)) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) [NamesT (TCMT IO) Term]
vars

          -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ b : (i : I) → [α] -> old_t[x = hfill φ u u0 i,δ_fill[i]]
          NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
b <- do
             [(NamesT (TCMT IO) Term,
  NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)]
sides <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Term, (Term, Term))]
alphab forall a b. (a -> b) -> a -> b
$ \ (Term
psi,(Term
side0,Term
side1)) -> do
                NamesT (TCMT IO) Term
psi <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ Substitution
hcompS forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
psi

                [NamesT (TCMT IO) Term
side0,NamesT (TCMT IO) Term
side1] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Subst a => Int -> a -> a
raise (Int
3forall a. Num a => a -> a -> a
+forall a. Sized a => a -> Int
size Abs Telescope
delta) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Abstract t => Telescope -> t -> t
abstract Telescope
hdelta) [Term
side0,Term
side1]
                forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
ineg NamesT (TCMT IO) Term
psi NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
`imax` NamesT (TCMT IO) Term
psi, \ NamesT (TCMT IO) Term
i -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
pOr_ty NamesT (TCMT IO) Term
i (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
ineg NamesT (TCMT IO) Term
psi) NamesT (TCMT IO) Term
psi (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
apply_delta_fill NamesT (TCMT IO) Term
i forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
side0 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
hfill NamesT (TCMT IO) Term
lvl NamesT (TCMT IO) Term
htype NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
u NamesT (TCMT IO) Term
u0 NamesT (TCMT IO) Term
i)
                                                            (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
apply_delta_fill NamesT (TCMT IO) Term
i forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
side1 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
hfill NamesT (TCMT IO) Term
lvl NamesT (TCMT IO) Term
htype NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
u NamesT (TCMT IO) Term
u0 NamesT (TCMT IO) Term
i))
             let recurse :: [(NamesT (TCMT IO) Term,
  NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)]
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
recurse []           NamesT (TCMT IO) Term
i = forall a. HasCallStack => a
__IMPOSSIBLE__
                 recurse [(NamesT (TCMT IO) Term
psi,NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
u)]    NamesT (TCMT IO) Term
i = NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
u NamesT (TCMT IO) Term
i
                 recurse ((NamesT (TCMT IO) Term
psi,NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
u):[(NamesT (TCMT IO) Term,
  NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)]
xs) NamesT (TCMT IO) Term
i = NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
pOr_ty NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
psi (forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
imax forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) [(NamesT (TCMT IO) Term,
  NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)]
xs) (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
u NamesT (TCMT IO) Term
i) ([(NamesT (TCMT IO) Term,
  NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)]
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
recurse [(NamesT (TCMT IO) Term,
  NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)]
xs NamesT (TCMT IO) Term
i)
             forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [(NamesT (TCMT IO) Term,
  NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)]
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
recurse [(NamesT (TCMT IO) Term,
  NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)]
sides

          ((,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
ty (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) forall a b. (a -> b) -> a -> b
$ do
            NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
comp NamesT (TCMT IO) Term
ty_level
               (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t a. Type'' t a -> a
unEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
ty)
                           (NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
`imax` NamesT (TCMT IO) Term
alpha)
                           (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i ->
                               let rhs :: NamesT (TCMT IO) Term
rhs = (forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
call (NamesT (TCMT IO) Term
u forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o) NamesT (TCMT IO) Term
i)
                               in if forall a. Null a => a -> Bool
null [(Term, (Term, Term))]
alphab then NamesT (TCMT IO) Term
rhs else
                                   NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
pOr_ty NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
alpha NamesT (TCMT IO) Term
rhs (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
b NamesT (TCMT IO) Term
i)
                           )
                           (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
call NamesT (TCMT IO) Term
u0 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz))
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"old_tel =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
    let n :: Int
n = forall a. Sized a => a -> Int
size Telescope
tel forall a. Num a => a -> a -> a
- (forall a. Sized a => a -> Int
size Telescope
gamma forall a. Num a => a -> a -> a
+ Int
3 forall a. Num a => a -> a -> a
+ forall a. Sized a => a -> Int
size Abs Telescope
delta)
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"n =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Applicative m => String -> m Doc
text (forall a. Show a => a -> String
show Int
n)
    (TelV Telescope
deltaEx Type
t,[(Term, (Term, Term))]
bs) <- forall (m :: * -> *).
PureTCM m =>
Int -> Type -> m (TelV Type, [(Term, (Term, Term))])
telViewUpToPathBoundary' Int
n Type
ty
    Term
rhs <- forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Int -> a -> a
raise Int
n Term
rhs forall t. Apply t => t -> [Elim] -> t
`applyE` forall a. DeBruijn a => Telescope -> Boundary' (a, a) -> [Elim' a]
teleElims Telescope
deltaEx [(Term, (Term, Term))]
bs

    Telescope
cxt <- forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Telescope
getContextTelescope
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"cxt = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
cxt
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"tel = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"t = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
t
    forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => String -> m Doc
text String
"rhs = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
rhs

    forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Clause { clauseLHSRange :: Range
clauseLHSRange  = forall a. Range' a
noRange
                    , clauseFullRange :: Range
clauseFullRange = forall a. Range' a
noRange
                    , clauseTel :: Telescope
clauseTel       = Telescope
tel
                    , namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps
                    , clauseBody :: Maybe Term
clauseBody      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Term
rhs
                    , clauseType :: Maybe (Arg Type)
clauseType      = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. e -> Arg e
defaultArg Type
t
                    , clauseCatchall :: Bool
clauseCatchall    = Bool
False
                    , clauseExact :: Maybe Bool
clauseExact       = forall a. a -> Maybe a
Just Bool
True
                    , clauseRecursive :: Maybe Bool
clauseRecursive   = forall a. Maybe a
Nothing     -- TODO: can it be recursive?
                    , clauseUnreachable :: Maybe Bool
clauseUnreachable = forall a. a -> Maybe a
Just Bool
False  -- missing, thus, not unreachable
                    , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis    = ExpandedEllipsis
NoEllipsis
                    , clauseWhereModule :: Maybe ModuleName
clauseWhereModule = forall a. Maybe a
Nothing
                    }
  forall (m :: * -> *).
(MonadConstraint m, MonadTCState m) =>
QName -> [Clause] -> m ()
addClauses QName
f [Clause
cl]  -- Important: add at the end.
  let result :: CoverResult
result = CoverResult
          { coverSplitTree :: SplitTree' SplitTag
coverSplitTree      = forall a. Int -> SplitTree' a
SplittingDone (forall a. Sized a => a -> Int
size (Clause -> Telescope
clauseTel Clause
cl))
          , coverUsedClauses :: IntSet
coverUsedClauses    = Int -> IntSet
IntSet.singleton (forall (t :: * -> *) a. Foldable t => t a -> Int
length [Clause]
cs)
          , coverMissingClauses :: [(Telescope, [NamedArg DeBruijnPattern])]
coverMissingClauses = []
          , coverPatterns :: [Clause]
coverPatterns       = [Clause
cl]
          , coverNoExactClauses :: IntSet
coverNoExactClauses = IntSet
IntSet.empty
          }
  QName
hcompName <- 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 QName)
getName' String
builtinHComp
  forall (m :: * -> *) a. Monad m => a -> m a
return ([(QName -> SplitTag
SplitCon QName
hcompName,CoverResult
result)],[Clause]
csforall a. [a] -> [a] -> [a]
++[Clause
cl])
createMissingHCompClause QName
_ Arg Int
_ BlockingVar
_ SplitClause
_ (SClause Telescope
_ [NamedArg SplitPattern]
_ Substitution' SplitPattern
_ Map CheckpointId Substitution
_ Maybe (Dom Type)
Nothing) [Clause]
_ = forall a. HasCallStack => a
__IMPOSSIBLE__