{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.Coverage.Cubical where
import Prelude hiding (null, (!!))
import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans ( lift )
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.Common.Pretty (prettyShow)
import Agda.TypeChecking.Constraints ()
import Agda.TypeChecking.Coverage.Match
import Agda.TypeChecking.Coverage.SplitClause
import Agda.TypeChecking.Coverage.SplitTree
import Agda.TypeChecking.Datatypes (getDatatypeArgs)
import Agda.TypeChecking.Irrelevance
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Names
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Primitive hiding (Nat)
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Telescope.Path
import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.List1 ( pattern (:|) )
import qualified Agda.Utils.List1 as List1
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Singleton
import Agda.Utils.Size
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
reflId <- BuiltinId -> TCMT IO (Maybe QName)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe QName)
getName' BuiltinId
builtinReflId
let infos = [(QName
c,UnifyEquiv
i) | (SplitCon QName
c, (SplitClause
_,TheInfo UnifyEquiv
i)) <- [(SplitTag, (SplitClause, IInfo))]
scs ]
case scs of
[(SplitCon QName
c,(SplitClause
_newSc,i :: IInfo
i@TheInfo{}))] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
reflId -> do
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
caseMaybe mc (return ([],cs)) $ \ ((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 ([Clause] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Clause]
cs)) [] [Clause
cl] IntSet
IntSet.empty
([(SplitTag, CoverResult)], [Clause])
-> TCM ([(SplitTag, CoverResult)], [Clause])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(SplitTag
sp,CoverResult
res)],[Clause] -> Clause -> [Clause]
forall a. [a] -> a -> [a]
snoc [Clause]
cs Clause
cl)
[(SplitTag, (SplitClause, IInfo))]
xs | (QName, UnifyEquiv)
info:[(QName, UnifyEquiv)]
_ <- [(QName, UnifyEquiv)]
infos -> do
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.indexed" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"size (xs,infos):" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Int, Int) -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty ([(SplitTag, (SplitClause, IInfo))] -> Int
forall a. Sized a => a -> Int
size [(SplitTag, (SplitClause, IInfo))]
xs,[(QName, UnifyEquiv)] -> Int
forall a. Sized a => a -> Int
size [(QName, UnifyEquiv)]
infos)
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.indexed" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"xs :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [SplitTag] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (((SplitTag, (SplitClause, IInfo)) -> SplitTag)
-> [(SplitTag, (SplitClause, IInfo))] -> [SplitTag]
forall a b. (a -> b) -> [a] -> [b]
map (SplitTag, (SplitClause, IInfo)) -> SplitTag
forall a b. (a, b) -> a
fst [(SplitTag, (SplitClause, IInfo))]
xs)
Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(SplitTag, (SplitClause, IInfo))] -> Int
forall a. Sized a => a -> Int
size [(SplitTag, (SplitClause, IInfo))]
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [(QName, UnifyEquiv)] -> Int
forall a. Sized a => a -> Int
size [(QName, UnifyEquiv)]
infos) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.indexed" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"missing some infos"
Constructor{conData} <- Definition -> Defn
theDef (Definition -> Defn) -> TCMT IO Definition -> TCMT IO Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo ((QName, UnifyEquiv) -> QName
forall a b. (a, b) -> a
fst (QName, UnifyEquiv)
info)
Datatype{dataPars = pars, dataIxs = nixs, dataTranspIx} <- theDef <$> getConstInfo conData
hcomp <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp
trX <- fromMaybe __IMPOSSIBLE__ <$> pure dataTranspIx
trX_cl <- createMissingTrXTrXClause trX f n x old_sc
hcomp_cl <- createMissingTrXHCompClause trX f n x old_sc
(trees,cls) <- fmap unzip . forM infos $ \ (QName
c,UnifyEquiv
i) -> do
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
return $ ((SplitCon c , SplittingDone (size $ clauseTel cl)) , cl)
let extra = [ (QName -> SplitTag
SplitCon QName
trX, Int -> SplitTree' SplitTag
forall a. Int -> SplitTree' a
SplittingDone (Int -> SplitTree' SplitTag) -> Int -> SplitTree' SplitTag
forall a b. (a -> b) -> a -> b
$ Telescope -> Int
forall a. Sized a => a -> Int
size (Telescope -> Int) -> Telescope -> Int
forall a b. (a -> b) -> a -> b
$ Clause -> Telescope
clauseTel Clause
trX_cl)
, (QName -> SplitTag
SplitCon QName
hcomp, Int -> SplitTree' SplitTag
forall a. Int -> SplitTree' a
SplittingDone (Int -> SplitTree' SplitTag) -> Int -> SplitTree' SplitTag
forall a b. (a -> b) -> a -> b
$ Telescope -> Int
forall a. Sized a => a -> Int
size (Telescope -> Int) -> Telescope -> Int
forall a b. (a -> b) -> a -> b
$ Clause -> Telescope
clauseTel Clause
hcomp_cl)
]
extraCl = [Clause
trX_cl, Clause
hcomp_cl]
let clauses = [Clause]
cls [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ [Clause]
extraCl
let tree = Arg Int
-> LazySplit
-> [(SplitTag, SplitTree' SplitTag)]
-> SplitTree' SplitTag
forall a. Arg Int -> LazySplit -> SplitTrees' a -> SplitTree' a
SplitAt (Arg Int
n Arg Int -> (Int -> Int) -> Arg Int
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> (Int -> Int -> Int
forall a. Num a => a -> a -> a
+ (Int
pars Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
nixs Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1))) LazySplit
StrictSplit ([(SplitTag, SplitTree' SplitTag)] -> SplitTree' SplitTag)
-> [(SplitTag, SplitTree' SplitTag)] -> SplitTree' SplitTag
forall a b. (a -> b) -> a -> b
$
[(SplitTag, SplitTree' SplitTag)]
trees
[(SplitTag, SplitTree' SplitTag)]
-> [(SplitTag, SplitTree' SplitTag)]
-> [(SplitTag, SplitTree' SplitTag)]
forall a. [a] -> [a] -> [a]
++ [(SplitTag, SplitTree' SplitTag)]
extra
res = CoverResult
{ coverSplitTree :: SplitTree' SplitTag
coverSplitTree = SplitTree' SplitTag
tree
, coverUsedClauses :: IntSet
coverUsedClauses = let l :: Int
l = [Clause] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Clause]
cs in [Int] -> IntSet
IntSet.fromAscList [Int
l .. Int
l Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Clause] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Clause]
clauses Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1]
, coverMissingClauses :: [(Telescope, [NamedArg DeBruijnPattern])]
coverMissingClauses = []
, coverPatterns :: [Clause]
coverPatterns = [Clause]
clauses
, coverNoExactClauses :: IntSet
coverNoExactClauses = IntSet
IntSet.empty
}
reportSDoc "tc.cover.indexed" 20 $
"tree:" <+> pretty tree
addClauses f clauses
return ([(SplitCon trX, res)], cs ++ clauses)
[(SplitTag, (SplitClause, IInfo))]
xs | Bool
otherwise -> ([(SplitTag, CoverResult)], [Clause])
-> TCM ([(SplitTag, CoverResult)], [Clause])
forall a. a -> TCMT IO a
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
ed_f <- TCM (Either (Closure (Abs Type)) Args)
-> TCM (Either (Closure (Abs Type)) Args)
forall a. TCM a -> TCM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Either (Closure (Abs Type)) Args)
-> TCM (Either (Closure (Abs Type)) Args))
-> TCM (Either (Closure (Abs Type)) Args)
-> TCM (Either (Closure (Abs Type)) Args)
forall a b. (a -> b) -> a -> b
$ ExceptT (Closure (Abs Type)) (TCMT IO) Args
-> TCM (Either (Closure (Abs Type)) Args)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Closure (Abs Type)) (TCMT IO) Args
-> TCM (Either (Closure (Abs Type)) Args))
-> ExceptT (Closure (Abs Type)) (TCMT IO) Args
-> TCM (Either (Closure (Abs Type)) Args)
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 ed_f of
Right Args
d_f -> [Term] -> TCM [Term]
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Term] -> TCM [Term]) -> [Term] -> TCM [Term]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> Term) -> Args -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Term
forall e. Arg e -> e
unArg Args
d_f
Left Closure (Abs Type)
failed_t -> Closure (Abs Type) -> (Abs Type -> TCM [Term]) -> TCM [Term]
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure Closure (Abs Type)
failed_t ((Abs Type -> TCM [Term]) -> TCM [Term])
-> (Abs Type -> TCM [Term]) -> TCM [Term]
forall a b. (a -> b) -> a -> b
$ \Abs Type
failed_t -> (String, Dom Type) -> TCM [Term] -> TCM [Term]
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
(String, Dom Type) -> m a -> m a
addContext (String
"i" :: String, Dom Type
HasCallStack => Dom Type
__DUMMY_DOM__) (TCM [Term] -> TCM [Term]) -> TCM [Term] -> TCM [Term]
forall a b. (a -> b) -> a -> b
$ do
TypeError -> TCM [Term]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM [Term])
-> (Doc -> TypeError) -> Doc -> TCM [Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCM [Term]) -> TCMT IO Doc -> TCM [Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"Could not generate a transport clause for" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
func
, TCMT IO Doc
"because a term of type" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM (Abs Type -> Type
forall a. Abs a -> a
unAbs Abs Type
failed_t)
, TCMT IO Doc
"lives in the sort" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort -> m Doc
prettyTCM (Type -> Sort
forall a. LensSort a => a -> Sort
getSort (Abs Type -> Type
forall a. Abs a -> a
unAbs Abs Type
failed_t)) TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"and thus can not be transported"
]
createMissingTrXTrXClause :: QName
-> QName
-> 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 ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
old_t :: Dom Type
old_t = Dom Type -> Maybe (Dom Type) -> Dom Type
forall a. a -> Maybe a -> a
fromMaybe Dom Type
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.trx" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"trX-trX clause for" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
f
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.trx" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
[ TCMT IO Doc
"old_tel:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
old_tel
, TCMT IO Doc
"old_ps :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
old_tel ([Elim] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Elim] -> m Doc
prettyTCM ([Elim] -> TCMT IO Doc) -> [Elim] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
old_ps)
, TCMT IO Doc
"old_t :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
old_tel (Dom Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Dom Type -> m Doc
prettyTCM Dom Type
old_t)
]
interval <- TCMT IO Term -> TCMT IO Type
forall (m :: * -> *). Functor m => m Term -> m Type
elInf TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primInterval
iz <- primIZero
io <- primIOne
tHComp <- primHComp
tNeg <- primINeg
let neg NamesT (TCMT IO) Term
i = Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tNeg NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i
let min NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
let max NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
let
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
old_ps' = [String]
-> [NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern]
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) ([NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
old_ps = AbsN [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern]))
-> AbsN [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
forall a b. (a -> b) -> a -> b
$ AbsN [NamedArg DeBruijnPattern]
old_ps'
old_ty = AbsN (Dom Type) -> NamesT (TCMT IO) (AbsN (Dom Type))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN (Dom Type) -> NamesT (TCMT IO) (AbsN (Dom Type)))
-> AbsN (Dom Type) -> NamesT (TCMT IO) (AbsN (Dom Type))
forall a b. (a -> b) -> a -> b
$ [String] -> Dom Type -> AbsN (Dom Type)
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) (Dom Type -> AbsN (Dom Type)) -> Dom Type -> AbsN (Dom Type)
forall a b. (a -> b) -> a -> b
$ Dom Type -> Maybe (Dom Type) -> Dom Type
forall a. a -> Maybe a -> a
fromMaybe Dom Type
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
(gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel
delta = AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope))
-> AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a b. (a -> b) -> a -> b
$ [String] -> Telescope -> AbsN Telescope
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1x) (Telescope -> AbsN Telescope) -> Telescope -> AbsN Telescope
forall a b. (a -> b) -> a -> b
$ Telescope
delta'
gamma1_size = (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
gamma1x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
(gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x
old_sides <- forM old_ps' $ \ [NamedArg DeBruijnPattern]
ps -> do
let vs :: [Int]
vs = [NamedArg DeBruijnPattern] -> [Int]
forall p. IApplyVars p => p -> [Int]
iApplyVars [NamedArg DeBruijnPattern]
ps
let tm :: Term
tm = QName -> [Elim] -> Term
Def QName
f ([Elim] -> Term) -> [Elim] -> Term
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
ps
xs <- [Int]
-> (Int -> TCMT IO (Term, (Term, Term)))
-> TCMT IO [(Term, (Term, Term))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs ((Int -> TCMT IO (Term, (Term, Term)))
-> TCMT IO [(Term, (Term, Term))])
-> (Int -> TCMT IO (Term, (Term, Term)))
-> TCMT IO [(Term, (Term, Term))]
forall a b. (a -> b) -> a -> b
$ \ Int
v ->
((Term, Term) -> (Term, (Term, Term)))
-> TCMT IO (Term, Term) -> TCMT IO (Term, (Term, Term))
forall a b. (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Term
var Int
v,) (TCMT IO (Term, Term) -> TCMT IO (Term, (Term, Term)))
-> ((Term, Term) -> TCMT IO (Term, Term))
-> (Term, Term)
-> TCMT IO (Term, (Term, Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term, Term) -> TCMT IO (Term, Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce ((Term, Term) -> TCMT IO (Term, (Term, Term)))
-> (Term, Term) -> TCMT IO (Term, (Term, Term))
forall a b. (a -> b) -> a -> b
$ (Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
iz Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm, Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
io Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm)
return $ concatMap (\(Term
v,(Term
l,Term
r)) -> [(Term
tNeg Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
v],Term
l),(Term
v,Term
r)]) xs
let
gamma1ArgNames = Telescope -> [Arg String]
teleArgNames Telescope
gamma1
deltaArgNames = Telescope -> [Arg String]
teleArgNames Telescope
delta'
(params,xTel,dT) <- addContext gamma1 $ do
Just (d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType'
def <- getConstInfo d
let dTy = Definition -> Type
defType Definition
def
let Datatype{dataSort = s} = theDef def
TelV tel _ <- telView dTy
let params = [String] -> Args -> AbsN Args
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1) Args
ps
xTel = [String] -> Telescope -> AbsN Telescope
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1) (Telescope
tel Telescope -> Args -> Telescope
forall t. Apply t => t -> Args -> t
`apply` Args
ps)
dT <- runNamesT [] $ do
s <- open $ AbsN (teleNames tel) s
bindNArg (teleArgNames gamma1) $ \ ArgVars (TCMT IO)
g1 -> do
[Arg String]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) (AbsN Type)
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Telescope -> [Arg String]
teleArgNames (Telescope -> [Arg String]) -> Telescope -> [Arg String]
forall a b. (a -> b) -> a -> b
$ AbsN Telescope -> Telescope
forall a. AbsN a -> a
unAbsN AbsN Telescope
xTel) ((ArgVars (TCMT IO) -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) (AbsN Type))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) (AbsN Type)
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x -> do
params <- AbsN Args -> NamesT (TCMT IO) (AbsN Args)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Args
params NamesT (TCMT IO) (AbsN Args)
-> [NamesT (TCMT IO) (SubstArg Args)] -> NamesT (TCMT IO) Args
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ((Arg Term -> Term)
-> NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg Term -> Term
forall e. Arg e -> e
unArg (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamesT (TCMT IO) (Arg Term)]
ArgVars (TCMT IO)
g1)
x <- sequence x
s <- s `applyN` map (pure . unArg) (params ++ x)
pure $ El s $ Def d [] `apply` (params ++ x)
return $ (params, xTel,dT)
let
xTelI = AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope))
-> AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a b. (a -> b) -> a -> b
$ Type -> Telescope -> Telescope
expTelescope Type
interval (Telescope -> Telescope) -> AbsN Telescope -> AbsN Telescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsN Telescope
xTel
xTelIArgNames = Telescope -> [Arg String]
teleArgNames (AbsN Telescope -> Telescope
forall a. AbsN a -> a
unAbsN AbsN Telescope
xTel)
let trX' = [Arg String]
-> (ArgVars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg String]
gamma1ArgNames ((ArgVars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern))))
-> (ArgVars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
g1 -> do
[Arg String]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg ([String -> Arg String
forall e. e -> Arg e
defaultArg String
"phi"] [Arg String] -> [Arg String] -> [Arg String]
forall a. [a] -> [a] -> [a]
++ [Arg String]
xTelIArgNames) ((ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
phi_p -> do
[Arg String]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [String -> Arg String
forall e. e -> Arg e
defaultArg String
"x0"] ((ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x0 -> do
param_args <- (Args -> [NamedArg DeBruijnPattern])
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Arg Term -> NamedArg DeBruijnPattern)
-> Args -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> [a] -> [b]
map (Hiding -> NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden (NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern)
-> (Arg Term -> NamedArg DeBruijnPattern)
-> Arg Term
-> NamedArg DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> Named_ DeBruijnPattern)
-> Arg Term -> NamedArg DeBruijnPattern
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DeBruijnPattern -> Named_ DeBruijnPattern
forall a name. a -> Named name a
unnamed (DeBruijnPattern -> Named_ DeBruijnPattern)
-> (Term -> DeBruijnPattern) -> Term -> Named_ DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> DeBruijnPattern
forall a. Term -> Pattern' a
dotP))) (NamesT (TCMT IO) Args
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern])
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$
AbsN Args -> NamesT (TCMT IO) (AbsN Args)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Args
params NamesT (TCMT IO) (AbsN Args)
-> [NamesT (TCMT IO) (SubstArg Args)] -> NamesT (TCMT IO) Args
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ((Arg Term -> Term)
-> NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg Term -> Term
forall e. Arg e -> e
unArg (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamesT (TCMT IO) (Arg Term)]
ArgVars (TCMT IO)
g1)
(phi:p) <- sequence phi_p
x0 <- sequence x0
pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi] ++ x0
trX = ((AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term))
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> ((DeBruijnPattern -> Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN (AbsN DeBruijnPattern))
-> AbsN (AbsN (AbsN Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term)
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> ((DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term)
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN DeBruijnPattern)
-> AbsN (AbsN Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm (AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
trX'
let pat' =
[String]
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern))))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN DeBruijnPattern))))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg [Arg String]
gamma1ArgNames) ((Vars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern))))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN DeBruijnPattern)))))
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern))))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN DeBruijnPattern))))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1 -> do
[String]
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg ([Arg String] -> [String]) -> [Arg String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String -> Arg String
forall e. e -> Arg e
defaultArg String
"phi"] [Arg String] -> [Arg String] -> [Arg String]
forall a. [a] -> [a] -> [a]
++ [Arg String]
xTelIArgNames)) ((Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern))))
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
phi_p -> do
[String]
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg ([Arg String] -> [String]) -> [Arg String] -> [String]
forall a b. (a -> b) -> a -> b
$ ([String -> Arg String
forall e. e -> Arg e
defaultArg String
"psi"] [Arg String] -> [Arg String] -> [Arg String]
forall a. [a] -> [a] -> [a]
++ [Arg String]
xTelIArgNames)) ((Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
psi_q -> do
[String]
-> (Vars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg ([Arg String] -> [String]) -> [Arg String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String -> Arg String
forall e. e -> Arg e
defaultArg String
"x0"]) ((Vars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
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' NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN DeBruijnPattern)))]
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg (AbsN (AbsN DeBruijnPattern)))]
Vars (TCMT IO)
g1
NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
trX NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
-> [NamesT (TCMT IO) (SubstArg (AbsN DeBruijnPattern))]
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg (AbsN DeBruijnPattern))]
Vars (TCMT IO)
phi_p NamesT (TCMT IO) (AbsN DeBruijnPattern)
-> [NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
-> NamesT (TCMT IO) DeBruijnPattern
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 NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
-> [NamesT (TCMT IO) (SubstArg (AbsN DeBruijnPattern))]
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg (AbsN DeBruijnPattern))]
Vars (TCMT IO)
psi_q NamesT (TCMT IO) (AbsN DeBruijnPattern)
-> [NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
-> NamesT (TCMT IO) DeBruijnPattern
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
Vars (TCMT IO)
x0]
pat = ((AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> AbsN (AbsN (AbsN (AbsN DeBruijnPattern)))
-> AbsN (AbsN (AbsN (AbsN Term)))
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> AbsN (AbsN (AbsN (AbsN DeBruijnPattern)))
-> AbsN (AbsN (AbsN (AbsN Term))))
-> ((DeBruijnPattern -> Term)
-> AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN (AbsN (AbsN DeBruijnPattern)))
-> AbsN (AbsN (AbsN (AbsN Term)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term))
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> ((DeBruijnPattern -> Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN (AbsN DeBruijnPattern))
-> AbsN (AbsN (AbsN Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term)
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> ((DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term)
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN DeBruijnPattern)
-> AbsN (AbsN Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm (AbsN (AbsN (AbsN (AbsN DeBruijnPattern)))
-> AbsN (AbsN (AbsN (AbsN Term))))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN DeBruijnPattern))))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN Term))))
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]
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 NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
g1 [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN Term))))
pat NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN Term))))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN (AbsN Term))))]
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
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) (SubstArg (AbsN (AbsN (AbsN Term))))]
g1 NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN Term)))]
-> NamesT (TCMT IO) (AbsN (AbsN Term))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
phiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
p) NamesT (TCMT IO) (AbsN (AbsN Term))
-> [NamesT (TCMT IO) (SubstArg (AbsN Term))]
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
psiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
q) NamesT (TCMT IO) (AbsN Term)
-> [NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term
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) (SubstArg Term)
x0]])
cTel <- runNamesT [] $
abstractN (pure gamma1) $ \ Vars (TCMT IO)
g1 -> do
String
-> NamesT (TCMT IO) Type
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"φ" (Type -> NamesT (TCMT IO) Type
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
NamesT (TCMT IO) Telescope
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
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 NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
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) (SubstArg Telescope)]
Vars (TCMT IO)
g1) ((Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
String
-> NamesT (TCMT IO) Type
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"ψ" (Type -> NamesT (TCMT IO) Type
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
psi -> do
NamesT (TCMT IO) Telescope
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
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 NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
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) (SubstArg Telescope)]
Vars (TCMT IO)
g1) ((Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
q -> do
String
-> NamesT (TCMT IO) Type
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"x0" (AbsN (AbsN Type) -> NamesT (TCMT IO) (AbsN (AbsN Type))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN (AbsN Type)
dT NamesT (TCMT IO) (AbsN (AbsN Type))
-> [NamesT (TCMT IO) (SubstArg (AbsN Type))]
-> NamesT (TCMT IO) (AbsN Type)
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) (SubstArg (AbsN Type))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
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) Term)
-> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for [NamesT (TCMT IO) Term]
Vars (TCMT IO)
q (\ NamesT (TCMT IO) Term
f -> NamesT (TCMT IO) Term
f NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz)) ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
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 [NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1 NamesT (TCMT IO) Term
Var (TCMT IO)
phi [NamesT (TCMT IO) Term]
Vars (TCMT IO)
p NamesT (TCMT IO) Term
Var (TCMT IO)
psi [NamesT (TCMT IO) Term]
Vars (TCMT IO)
q NamesT (TCMT IO) Term
Var (TCMT IO)
x0
ps_ty_rhs <- runNamesT [] $ do
bindN (map unArg gamma1ArgNames) $ \ Vars (TCMT IO)
g1 -> do
String
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
-> NamesT
(TCMT IO)
(Abs
(AbsN
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"φ" ((Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
-> NamesT
(TCMT IO)
(Abs
(AbsN
(Abs
(AbsN
(Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))))
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
-> NamesT
(TCMT IO)
(Abs
(AbsN
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
[String]
-> (Vars (TCMT IO)
-> NamesT
(TCMT IO)
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
-> NamesT
(TCMT IO)
(AbsN
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg [Arg String]
xTelIArgNames) ((Vars (TCMT IO)
-> NamesT
(TCMT IO)
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
-> NamesT
(TCMT IO)
(AbsN
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
-> (Vars (TCMT IO)
-> NamesT
(TCMT IO)
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
-> NamesT
(TCMT IO)
(AbsN
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
String
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
-> NamesT
(TCMT IO)
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"ψ" ((Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
-> NamesT
(TCMT IO)
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
-> NamesT
(TCMT IO)
(Abs
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
psi -> do
[String]
-> (Vars (TCMT IO)
-> NamesT
(TCMT IO)
(Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> NamesT
(TCMT IO)
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg [Arg String]
xTelIArgNames) ((Vars (TCMT IO)
-> NamesT
(TCMT IO)
(Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> NamesT
(TCMT IO)
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
-> (Vars (TCMT IO)
-> NamesT
(TCMT IO)
(Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> NamesT
(TCMT IO)
(AbsN (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
q -> do
String
-> (Var (TCMT IO)
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> NamesT
(TCMT IO) (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
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" ((Var (TCMT IO)
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> NamesT
(TCMT IO)
(Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> (Var (TCMT IO)
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> NamesT
(TCMT IO) (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
x0 -> do
[String]
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) ([NamedArg DeBruijnPattern], Dom Type, Term))
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg [Arg String]
deltaArgNames) ((Vars (TCMT IO)
-> NamesT (TCMT IO) ([NamedArg DeBruijnPattern], Dom Type, Term))
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) ([NamedArg DeBruijnPattern], Dom Type, Term))
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))
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 NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
-> [NamesT (TCMT IO) (SubstArg [NamedArg DeBruijnPattern])]
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
g1
[NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN DeBruijnPattern))))
pat' NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN DeBruijnPattern))))
-> [NamesT
(TCMT IO) (SubstArg (AbsN (AbsN (AbsN DeBruijnPattern))))]
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg (AbsN (AbsN (AbsN DeBruijnPattern))))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN DeBruijnPattern)))]
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) DeBruijnPattern
Var (TCMT IO)
phiNamesT (TCMT IO) DeBruijnPattern
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
p) NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
-> [NamesT (TCMT IO) (SubstArg (AbsN DeBruijnPattern))]
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) DeBruijnPattern
Var (TCMT IO)
psiNamesT (TCMT IO) DeBruijnPattern
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
q) NamesT (TCMT IO) (AbsN DeBruijnPattern)
-> [NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
-> NamesT (TCMT IO) DeBruijnPattern
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern
NamesT (TCMT IO) (SubstArg DeBruijnPattern)
Var (TCMT IO)
x0]]
[NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
d)
rhsTy :: NamesT (TCMT IO) (Dom Type)
rhsTy = NamesT (TCMT IO) (AbsN (Dom Type))
old_ty NamesT (TCMT IO) (AbsN (Dom Type))
-> [NamesT (TCMT IO) (SubstArg (Dom Type))]
-> NamesT (TCMT IO) (Dom Type)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1
[NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN Term))))
pat NamesT (TCMT IO) (AbsN (AbsN (AbsN (AbsN Term))))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN (AbsN Term))))]
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
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) (SubstArg (AbsN (AbsN (AbsN Term))))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN Term)))]
-> NamesT (TCMT IO) (AbsN (AbsN Term))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
Var (TCMT IO)
phiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
Vars (TCMT IO)
p) NamesT (TCMT IO) (AbsN (AbsN Term))
-> [NamesT (TCMT IO) (SubstArg (AbsN Term))]
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
Var (TCMT IO)
psiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
Vars (TCMT IO)
q) NamesT (TCMT IO) (AbsN Term)
-> [NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term
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) (SubstArg Term)
Var (TCMT IO)
x0]]
[NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) Term]
Vars (TCMT IO)
d)
xTel <- (Telescope -> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Telescope -> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope))
-> NamesT (TCMT IO) Telescope
-> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) Telescope
-> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope))
-> NamesT (TCMT IO) Telescope
-> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope)
forall a b. (a -> b) -> a -> b
$ AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Telescope
xTel NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
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) (SubstArg Telescope)]
Vars (TCMT IO)
g1
q4_f <- (open =<<) $ bind "i" $ \ Var (TCMT IO)
i -> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
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" ((Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
ty <- String
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
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) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope))
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
_ -> NamesT (TCMT IO) Telescope
xTel
face <- max phi $ max (neg j) (neg i)
base <- map defaultArg <$> appTel (sequence q) j
u <- liftM2 (,) (max j psi) $ bind "h" $ \ Var (TCMT IO)
h -> do
NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m [Term] -> NamesT m Term -> NamesT m [Term]
appTel ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [NamesT (TCMT IO) Term]
Vars (TCMT IO)
p) (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
Var (TCMT IO)
j (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
Var (TCMT IO)
h NamesT (TCMT IO) Term
Var (TCMT IO)
i))
Right xs <- lift $ runExceptT $ transpSysTel' False ty [u] face base
pure $ map unArg xs
pat_rec <- (open =<<) $ bind "i" $ \ Var (TCMT IO)
i -> do
p_conn <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
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) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [NamesT (TCMT IO) Term]
Vars (TCMT IO)
p NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m [Term] -> NamesT m Term -> NamesT m [Term]
`appTel` NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
Var (TCMT IO)
i NamesT (TCMT IO) Term
Var (TCMT IO)
j
q4_f' <- (mapM open =<<) $ absApp <$> q4_f <*> i
trX `applyN` g1 `applyN` (max i phi:p_conn)
`applyN` [trX `applyN` g1 `applyN` (min psi (max phi (neg i)):q4_f') `applyN` [x0]]
let mkBndry NamesT (TCMT IO) (Abs [Term])
args = do
args1 <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ (Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
faces <- pure (fmap (map fst) old_sides) `applyN` args1
us <- forM (mapM (map snd) old_sides) $ \ AbsN Term
u -> do
String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> do
args <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ (Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
j)
pure u `applyN` args
forM (zip faces us) $ \ (Term
phi,Term
u) -> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term, NamesT (TCMT IO) Term))
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
phi) (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u)
let mkComp NamesT (TCMT IO) (AbsN Term)
pr = String
-> (Var (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (Abs Term)
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) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (Abs Term))
-> (Var (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (Abs Term)
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
d_f <- (Abs [Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs [Term]))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs [Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs [Term])))
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs [Term]))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs [Term])))
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs [Term]))
forall a b. (a -> b) -> a -> b
$ String
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
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" ((Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
tel <- String
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
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" ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope))
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> NamesT (TCMT IO) (AbsN Telescope)
delta NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1 [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN Term)
pr NamesT (TCMT IO) (AbsN Term)
-> [NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term
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) (SubstArg Term)
Var (TCMT IO)
i,NamesT (TCMT IO) Term
NamesT (TCMT IO) (SubstArg Term)
Var (TCMT IO)
j]])
face <- min phi psi `max` (min i (max phi psi))
j <- j
d <- map defaultArg <$> sequence d
lift $ covFillTele f tel face d j
let args = String
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
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" ((Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
g1 <- [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1
x <- pr `applyN` [i,neg j]
ys <- absApp <$> d_f <*> neg j
pure $ g1 ++ x:ys
ty <- (open =<<) $ bind "j" $ \ Var (TCMT IO)
j -> do
args <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
Var (TCMT IO)
j
fmap unDom $ old_ty `applyN` args
let face = NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
Var (TCMT IO)
i (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
Var (TCMT IO)
phi NamesT (TCMT IO) Term
Var (TCMT IO)
psi)
base <- (open =<<) $ do
args' <- (mapM open =<<) $ absApp <$> args <*> pure iz
fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args'
sys <- mkBndry args
transpSys ty sys face base
syspsi <- (open =<<) $ lam "i" $ \ NamesT (TCMT IO) Term
i -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> do
c <- NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term)
mkComp (NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term))
-> NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term)
forall a b. (a -> b) -> a -> b
$ [String]
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN [String
"i",String
"j"] ((Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term)
forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term
i,NamesT (TCMT IO) Term
j] -> do
Abs n (data_ty,lines) <- String
-> (Var (TCMT IO) -> NamesT (TCMT IO) (Type, [Term]))
-> NamesT (TCMT IO) (Abs (Type, [Term]))
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" ((Var (TCMT IO) -> NamesT (TCMT IO) (Type, [Term]))
-> NamesT (TCMT IO) (Abs (Type, [Term])))
-> (Var (TCMT IO) -> NamesT (TCMT IO) (Type, [Term]))
-> NamesT (TCMT IO) (Abs (Type, [Term]))
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
k -> do
let phi_k :: NamesT (TCMT IO) Term
phi_k = NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
Var (TCMT IO)
phi (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg NamesT (TCMT IO) Term
Var (TCMT IO)
k)
let p_k :: [NamesT (TCMT IO) Term]
p_k = [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for [NamesT (TCMT IO) Term]
Vars (TCMT IO)
p ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term])
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"h" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
h -> NamesT (TCMT IO) Term
p NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
Var (TCMT IO)
k NamesT (TCMT IO) Term
h)
data_ty <- AbsN (AbsN Type) -> NamesT (TCMT IO) (AbsN (AbsN Type))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN (AbsN Type)
dT NamesT (TCMT IO) (AbsN (AbsN Type))
-> [NamesT (TCMT IO) (SubstArg (AbsN Type))]
-> NamesT (TCMT IO) (AbsN Type)
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) (SubstArg (AbsN Type))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
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) Term)
-> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for [NamesT (TCMT IO) Term]
Vars (TCMT IO)
p (\ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
p NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
Var (TCMT IO)
k)
line1 <- trX `applyN` g1 `applyN` (phi_k:p_k) `applyN` [x0]
line2 <- trX `applyN` g1
`applyN` (max phi_k j : for p_k (\ NamesT (TCMT IO) Term
p -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"h" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
h -> NamesT (TCMT IO) Term
p NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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)))
`applyN`
[trX `applyN` g1
`applyN` (max phi_k (neg j): for p_k (\ NamesT (TCMT IO) Term
p -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"h" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
h -> NamesT (TCMT IO) Term
p NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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)))
`applyN` [x0]]
pure (data_ty,[line1,line2])
data_ty <- open $ Abs n data_ty
[line1,line2] <- mapM (open . Abs n) lines
let sys = [(NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
neg NamesT (TCMT IO) Term
i, String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"k" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
k -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> Abs Term -> Term -> Term
Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Term -> Term -> Term)
-> NamesT (TCMT IO) (Abs Term) -> NamesT (TCMT IO) (Term -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
line2 NamesT (TCMT IO) (Term -> Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
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 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
j NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
i NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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
Var (TCMT IO)
phi, String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"k" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
k -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> Abs Term -> Term -> Term
Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Term -> Term -> Term)
-> NamesT (TCMT IO) (Abs Term) -> NamesT (TCMT IO) (Term -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
line1 NamesT (TCMT IO) (Term -> Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
k)
]
transpSys data_ty sys (pure iz) x0
absApp <$> pure c <*> i
sysphi <- (open =<<) $ lam "i" $ \ NamesT (TCMT IO) Term
i -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
o -> do
c <- NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term)
mkComp (NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term))
-> NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term)
forall a b. (a -> b) -> a -> b
$ [String]
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN [String
"i",String
"j"] ((Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term)
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
_ij -> do
NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trX NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN Term)))]
-> NamesT (TCMT IO) (AbsN (AbsN Term))
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) (SubstArg (AbsN (AbsN Term)))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN (AbsN Term))
-> [NamesT (TCMT IO) (SubstArg (AbsN Term))]
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
Var (TCMT IO)
psiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
Vars (TCMT IO)
q) NamesT (TCMT IO) (AbsN Term)
-> [NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term
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) (SubstArg Term)
Var (TCMT IO)
x0]
absApp <$> pure c <*> i
syse <- mkBndry $ bind "j" $ \ Var (TCMT IO)
_ -> [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term])
-> [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ [NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1 [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [Abs Term -> Term -> Term
Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Term -> Term -> Term)
-> NamesT (TCMT IO) (Abs Term) -> NamesT (TCMT IO) (Term -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_rec NamesT (TCMT IO) (Term -> Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz] [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) Term]
Vars (TCMT IO)
d
let sys = [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
syse [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
forall a. [a] -> [a] -> [a]
++ [(NamesT (TCMT IO) Term
Var (TCMT IO)
phi,NamesT (TCMT IO) Term
sysphi)] [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
forall a. [a] -> [a] -> [a]
++ [(NamesT (TCMT IO) Term
Var (TCMT IO)
psi,NamesT (TCMT IO) Term
syspsi)]
w0 <- (open =<<) $ do
let w = NamesT (TCMT IO) (AbsN Term) -> NamesT (TCMT IO) (Abs Term)
mkComp ([String]
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN [String
"i",String
"j"] ((Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term)
forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term
_i, NamesT (TCMT IO) Term
j] -> Abs Term -> Term -> Term
Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Term -> Term -> Term)
-> NamesT (TCMT IO) (Abs Term) -> NamesT (TCMT IO) (Term -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_rec NamesT (TCMT IO) (Term -> Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
j)
absApp <$> w <*> pure iz
let rhs = NamesT (TCMT IO) Type
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
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 (Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Type)
-> NamesT (TCMT IO) (Dom Type) -> NamesT (TCMT IO) Type
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
(,,) <$> ps <*> rhsTy <*> rhs
let (ps,ty,rhs) = unAbsN $ unAbs $ unAbsN $ unAbs $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs
reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f
let c = Clause { clauseLHSRange :: Range
clauseLHSRange = Range
forall a. Range' a
noRange
, clauseFullRange :: Range
clauseFullRange = Range
forall a. Range' a
noRange
, clauseTel :: Telescope
clauseTel = Telescope
cTel
, namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg DeBruijnPattern]
ps
, clauseBody :: Maybe Term
clauseBody = Term -> Maybe Term
forall a. a -> Maybe a
Just Term
rhs
, clauseType :: Maybe (Arg Type)
clauseType = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Arg Type -> Maybe (Arg Type)) -> Arg Type -> Maybe (Arg Type)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Type -> Arg Type
forall e. ArgInfo -> e -> Arg e
Arg (Dom Type -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom Type
ty) (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
ty)
, clauseCatchall :: Bool
clauseCatchall = Bool
False
, clauseExact :: Maybe Bool
clauseExact = Maybe Bool
forall a. Maybe a
Nothing
, clauseRecursive :: Maybe Bool
clauseRecursive = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
, clauseUnreachable :: Maybe Bool
clauseUnreachable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
, clauseEllipsis :: ExpandedEllipsis
clauseEllipsis = ExpandedEllipsis
NoEllipsis
, clauseWhereModule :: Maybe ModuleName
clauseWhereModule = Maybe ModuleName
forall a. Maybe a
Nothing
}
debugClause "tc.cover.trx.trx" c
return $ 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 ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
old_t :: Dom Type
old_t = Dom Type -> Maybe (Dom Type) -> Dom Type
forall a. a -> Maybe a -> a
fromMaybe Dom Type
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.hcomp" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"trX-hcomp clause for" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
f
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trx.hcomp" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
[ TCMT IO Doc
"old_tel:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
old_tel
, TCMT IO Doc
"old_ps :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
old_tel ([Elim] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Elim] -> m Doc
prettyTCM ([Elim] -> TCMT IO Doc) -> [Elim] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
old_ps)
, TCMT IO Doc
"old_t :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
old_tel (Dom Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Dom Type -> m Doc
prettyTCM Dom Type
old_t)
]
q_hcomp <- QName -> Maybe QName -> QName
forall a. a -> Maybe a -> a
fromMaybe QName
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe QName -> QName) -> TCMT IO (Maybe QName) -> TCMT IO QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrimitiveId -> TCMT IO (Maybe QName)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe QName)
getName' PrimitiveId
builtinHComp
let
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
old_ps = [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
old_t = Dom Type -> Maybe (Dom Type) -> Dom Type
forall a. a -> Maybe a -> a
fromMaybe Dom Type
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
reportSDoc "tc.cover.trx.trx" 20 $ "trX-trX clause for" <+> prettyTCM f
reportSDoc "tc.cover.trx.trx" 20 $ nest 2 $ vcat $
[ "old_tel:" <+> prettyTCM old_tel
, "old_ps :" <+> addContext old_tel (prettyTCM $ patternsToElims old_ps)
, "old_t :" <+> addContext old_tel (prettyTCM old_t)
]
interval <- elInf primInterval
iz <- primIZero
io <- primIOne
tHComp <- primHComp
tNeg <- primINeg
let neg NamesT (TCMT IO) Term
i = Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tNeg NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i
let min NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
let max NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
let
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
old_ps' = [String]
-> [NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern]
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) ([NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
old_ps = AbsN [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern]))
-> AbsN [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
forall a b. (a -> b) -> a -> b
$ AbsN [NamedArg DeBruijnPattern]
old_ps'
old_ty = AbsN (Dom Type) -> NamesT (TCMT IO) (AbsN (Dom Type))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN (Dom Type) -> NamesT (TCMT IO) (AbsN (Dom Type)))
-> AbsN (Dom Type) -> NamesT (TCMT IO) (AbsN (Dom Type))
forall a b. (a -> b) -> a -> b
$ [String] -> Dom Type -> AbsN (Dom Type)
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) (Dom Type -> AbsN (Dom Type)) -> Dom Type -> AbsN (Dom Type)
forall a b. (a -> b) -> a -> b
$ Dom Type -> Maybe (Dom Type) -> Dom Type
forall a. a -> Maybe a -> a
fromMaybe Dom Type
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
(gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel
delta = AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope))
-> AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a b. (a -> b) -> a -> b
$ [String] -> Telescope -> AbsN Telescope
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1x) (Telescope -> AbsN Telescope) -> Telescope -> AbsN Telescope
forall a b. (a -> b) -> a -> b
$ Telescope
delta'
gamma1_size = (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
gamma1x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
(gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x
old_sides <- forM old_ps' $ \ [NamedArg DeBruijnPattern]
ps -> do
let vs :: [Int]
vs = [NamedArg DeBruijnPattern] -> [Int]
forall p. IApplyVars p => p -> [Int]
iApplyVars [NamedArg DeBruijnPattern]
ps
let tm :: Term
tm = QName -> [Elim] -> Term
Def QName
f ([Elim] -> Term) -> [Elim] -> Term
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
ps
xs <- [Int]
-> (Int -> TCMT IO (Term, (Term, Term)))
-> TCMT IO [(Term, (Term, Term))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Int]
vs ((Int -> TCMT IO (Term, (Term, Term)))
-> TCMT IO [(Term, (Term, Term))])
-> (Int -> TCMT IO (Term, (Term, Term)))
-> TCMT IO [(Term, (Term, Term))]
forall a b. (a -> b) -> a -> b
$ \ Int
v ->
((Term, Term) -> (Term, (Term, Term)))
-> TCMT IO (Term, Term) -> TCMT IO (Term, (Term, Term))
forall a b. (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Term
var Int
v,) (TCMT IO (Term, Term) -> TCMT IO (Term, (Term, Term)))
-> ((Term, Term) -> TCMT IO (Term, Term))
-> (Term, Term)
-> TCMT IO (Term, (Term, Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term, Term) -> TCMT IO (Term, Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce ((Term, Term) -> TCMT IO (Term, (Term, Term)))
-> (Term, Term) -> TCMT IO (Term, (Term, Term))
forall a b. (a -> b) -> a -> b
$ (Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
iz Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm, Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
io Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm)
return $ concatMap (\(Term
v,(Term
l,Term
r)) -> [(Term
tNeg Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
v],Term
l),(Term
v,Term
r)]) xs
let
gamma1ArgNames = Telescope -> [Arg String]
teleArgNames Telescope
gamma1
deltaArgNames = Telescope -> [Arg String]
teleArgNames Telescope
delta'
(params,xTel,dT) <- addContext gamma1 $ do
Just (d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType'
def <- getConstInfo d
let dTy = Definition -> Type
defType Definition
def
let Datatype{dataSort = s} = theDef def
TelV tel _ <- telView dTy
let params = [String] -> Args -> AbsN Args
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1) Args
ps
xTel = [String] -> Telescope -> AbsN Telescope
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1) (Telescope
tel Telescope -> Args -> Telescope
forall t. Apply t => t -> Args -> t
`apply` Args
ps)
dT <- runNamesT [] $ do
s <- open $ AbsN (teleNames tel) s
bindNArg (teleArgNames gamma1) $ \ ArgVars (TCMT IO)
g1 -> do
[Arg String]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) (AbsN Type)
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Telescope -> [Arg String]
teleArgNames (Telescope -> [Arg String]) -> Telescope -> [Arg String]
forall a b. (a -> b) -> a -> b
$ AbsN Telescope -> Telescope
forall a. AbsN a -> a
unAbsN AbsN Telescope
xTel) ((ArgVars (TCMT IO) -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) (AbsN Type))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) (AbsN Type)
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x -> do
params <- AbsN Args -> NamesT (TCMT IO) (AbsN Args)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Args
params NamesT (TCMT IO) (AbsN Args)
-> [NamesT (TCMT IO) (SubstArg Args)] -> NamesT (TCMT IO) Args
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ((Arg Term -> Term)
-> NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg Term -> Term
forall e. Arg e -> e
unArg (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamesT (TCMT IO) (Arg Term)]
ArgVars (TCMT IO)
g1)
x <- sequence x
s <- s `applyN` map (pure . unArg) (params ++ x)
pure $ El s $ Def d [] `apply` (params ++ x)
return $ (params, xTel,dT)
let
xTelI = AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope))
-> AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a b. (a -> b) -> a -> b
$ Type -> Telescope -> Telescope
expTelescope Type
interval (Telescope -> Telescope) -> AbsN Telescope -> AbsN Telescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> AbsN Telescope
xTel
xTelIArgNames = Telescope -> [Arg String]
teleArgNames (AbsN Telescope -> Telescope
forall a. AbsN a -> a
unAbsN AbsN Telescope
xTel)
let trX' = [Arg String]
-> (ArgVars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg String]
gamma1ArgNames ((ArgVars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern))))
-> (ArgVars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
g1 -> do
[Arg String]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg ([String -> Arg String
forall e. e -> Arg e
defaultArg String
"phi"] [Arg String] -> [Arg String] -> [Arg String]
forall a. [a] -> [a] -> [a]
++ [Arg String]
xTelIArgNames) ((ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
phi_p -> do
[Arg String]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [String -> Arg String
forall e. e -> Arg e
defaultArg String
"x0"] ((ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x0 -> do
param_args <- (Args -> [NamedArg DeBruijnPattern])
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Arg Term -> NamedArg DeBruijnPattern)
-> Args -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> [a] -> [b]
map (Hiding -> NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden (NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern)
-> (Arg Term -> NamedArg DeBruijnPattern)
-> Arg Term
-> NamedArg DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> Named_ DeBruijnPattern)
-> Arg Term -> NamedArg DeBruijnPattern
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DeBruijnPattern -> Named_ DeBruijnPattern
forall a name. a -> Named name a
unnamed (DeBruijnPattern -> Named_ DeBruijnPattern)
-> (Term -> DeBruijnPattern) -> Term -> Named_ DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> DeBruijnPattern
forall a. Term -> Pattern' a
dotP))) (NamesT (TCMT IO) Args
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern])
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$
AbsN Args -> NamesT (TCMT IO) (AbsN Args)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Args
params NamesT (TCMT IO) (AbsN Args)
-> [NamesT (TCMT IO) (SubstArg Args)] -> NamesT (TCMT IO) Args
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ((Arg Term -> Term)
-> NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg Term -> Term
forall e. Arg e -> e
unArg (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamesT (TCMT IO) (Arg Term)]
ArgVars (TCMT IO)
g1)
(phi:p) <- sequence phi_p
x0 <- sequence x0
pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi] ++ x0
trX = ((AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term))
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> ((DeBruijnPattern -> Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN (AbsN DeBruijnPattern))
-> AbsN (AbsN (AbsN Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term)
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> ((DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term)
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN DeBruijnPattern)
-> AbsN (AbsN Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm (AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
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]
g1 [NamesT (TCMT IO) Term]
v =
[Arg String]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [String -> Arg String
forall e. e -> Arg e
argH String
"psi",String -> Arg String
forall e. e -> Arg e
argN String
"u", String -> Arg String
forall e. e -> Arg e
argN String
"u0"] ((ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x0 -> do
x0 <- [NamesT (TCMT IO) (NamedArg DeBruijnPattern)]
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [NamesT (TCMT IO) (NamedArg DeBruijnPattern)]
ArgVars (TCMT IO)
x0
Just (LEl l t) <- (toLType =<<) $ pure dT `applyN` g1 `applyN` v
let ty = (Term -> NamedArg DeBruijnPattern)
-> [Term] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Named_ DeBruijnPattern)
-> Arg Term -> NamedArg DeBruijnPattern
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (DeBruijnPattern -> Named_ DeBruijnPattern
forall a name. a -> Named name a
unnamed (DeBruijnPattern -> Named_ DeBruijnPattern)
-> (Term -> DeBruijnPattern) -> Term -> Named_ DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> DeBruijnPattern
forall a. Term -> Pattern' a
dotP) (Arg Term -> NamedArg DeBruijnPattern)
-> (Term -> Arg Term) -> Term -> NamedArg DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argH) [Level -> Term
Level Level
l,Term
t]
pure $ DefP defaultPatternInfo q_hcomp $ ty ++ x0
hcompD <- runNamesT [] $
bindN (map unArg $ gamma1ArgNames) $ \ Vars (TCMT IO)
g1 -> do
[String]
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN Term))
-> NamesT (TCMT IO) (AbsN (AbsN Term))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (Telescope -> [String]
teleNames (Telescope -> [String]) -> Telescope -> [String]
forall a b. (a -> b) -> a -> b
$ AbsN Telescope -> Telescope
forall a. AbsN a -> a
unAbsN (AbsN Telescope -> Telescope) -> AbsN Telescope -> Telescope
forall a b. (a -> b) -> a -> b
$ AbsN Telescope
xTel) ((Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN Term))
-> NamesT (TCMT IO) (AbsN (AbsN Term)))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN Term))
-> NamesT (TCMT IO) (AbsN (AbsN Term))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
v -> do
(DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap DeBruijnPattern -> Term
patternToTerm (AbsN DeBruijnPattern -> AbsN Term)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN Term)
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' [NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1 [NamesT (TCMT IO) Term]
Vars (TCMT IO)
v
let pat' =
[String]
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg [Arg String]
gamma1ArgNames) ((Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern))))
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1 -> do
List1 String
-> (Vars1 (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall (m :: * -> *) a.
MonadFail m =>
List1 String -> (Vars1 m -> NamesT m a) -> NamesT m (AbsN a)
bindN1 ((Arg String -> String) -> NonEmpty (Arg String) -> List1 String
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg String -> String
forall e. Arg e -> e
unArg (String -> Arg String
forall e. e -> Arg e
defaultArg String
"phi" Arg String -> [Arg String] -> NonEmpty (Arg String)
forall a. a -> [a] -> NonEmpty a
:| [Arg String]
xTelIArgNames)) ((Vars1 (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> (Vars1 (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall a b. (a -> b) -> a -> b
$ \ Vars1 (TCMT IO)
phi_p -> do
[String]
-> (Vars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN [String
"psi",String
"u",String
"u0"] ((Vars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
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' NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN DeBruijnPattern)))]
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg (AbsN (AbsN DeBruijnPattern)))]
Vars (TCMT IO)
g1
let p0 :: [NamesT (TCMT IO) Term]
p0 = [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for (NonEmpty (NamesT (TCMT IO) Term) -> [NamesT (TCMT IO) Term]
forall a. NonEmpty a -> [a]
List1.tail NonEmpty (NamesT (TCMT IO) Term)
Vars1 (TCMT IO)
phi_p) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term])
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
p NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
trX NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
-> [NamesT (TCMT IO) (SubstArg (AbsN DeBruijnPattern))]
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (List1 (NamesT (TCMT IO) DeBruijnPattern)
-> [Item (List1 (NamesT (TCMT IO) DeBruijnPattern))]
forall l. IsList l => l -> [Item l]
List1.toList List1 (NamesT (TCMT IO) DeBruijnPattern)
Vars1 (TCMT IO)
phi_p) NamesT (TCMT IO) (AbsN DeBruijnPattern)
-> [NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
-> NamesT (TCMT IO) DeBruijnPattern
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' [NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1 [NamesT (TCMT IO) Term]
p0 NamesT (TCMT IO) (AbsN DeBruijnPattern)
-> [NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
-> NamesT (TCMT IO) DeBruijnPattern
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
Vars (TCMT IO)
x0]
pat = ((AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term))
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> ((DeBruijnPattern -> Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN (AbsN DeBruijnPattern))
-> AbsN (AbsN (AbsN Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term)
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> ((DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term)
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN DeBruijnPattern)
-> AbsN (AbsN Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm (AbsN (AbsN (AbsN DeBruijnPattern)) -> AbsN (AbsN (AbsN Term)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
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]
g1 NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p [NamesT (TCMT IO) Term]
x0 =
NamesT (TCMT IO) (AbsN Telescope)
delta NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
g1 [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
pat NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN Term)))]
-> NamesT (TCMT IO) (AbsN (AbsN Term))
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) (SubstArg (AbsN (AbsN Term)))]
g1 NamesT (TCMT IO) (AbsN (AbsN Term))
-> [NamesT (TCMT IO) (SubstArg (AbsN Term))]
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
phiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
p) NamesT (TCMT IO) (AbsN Term)
-> [NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term
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) (SubstArg Term)]
x0])
cTel <- runNamesT [] $
abstractN (pure gamma1) $ \ Vars (TCMT IO)
g1 -> do
String
-> NamesT (TCMT IO) Type
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"φ" (Type -> NamesT (TCMT IO) Type
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
NamesT (TCMT IO) Telescope
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
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 NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
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) (SubstArg Telescope)]
Vars (TCMT IO)
g1) ((Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
let p0 :: [NamesT (TCMT IO) Term]
p0 = [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for [NamesT (TCMT IO) Term]
Vars (TCMT IO)
p ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term])
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
p NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
let ty :: NamesT (TCMT IO) Type
ty = AbsN (AbsN Type) -> NamesT (TCMT IO) (AbsN (AbsN Type))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN (AbsN Type)
dT NamesT (TCMT IO) (AbsN (AbsN Type))
-> [NamesT (TCMT IO) (SubstArg (AbsN Type))]
-> NamesT (TCMT IO) (AbsN Type)
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) (SubstArg (AbsN Type))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
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) (SubstArg Type)]
p0
String
-> NamesT (TCMT IO) Type
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"ψ" (Type -> NamesT (TCMT IO) Type
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
psi -> do
String
-> NamesT (TCMT IO) Type
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"u" (Type -> NamesT (TCMT IO) Type
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) 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" NamesT (TCMT IO) Term
Var (TCMT IO)
psi (\ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Type
ty)) ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
u -> do
String
-> NamesT (TCMT IO) Type
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
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 ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
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 [NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1 NamesT (TCMT IO) Term
Var (TCMT IO)
phi [NamesT (TCMT IO) Term]
Vars (TCMT IO)
p [NamesT (TCMT IO) Term
Var (TCMT IO)
psi,NamesT (TCMT IO) Term
Var (TCMT IO)
u,NamesT (TCMT IO) Term
Var (TCMT IO)
u0]
ps_ty_rhs <- runNamesT [] $ do
bindN (map unArg gamma1ArgNames) $ \ Vars (TCMT IO)
g1 -> do
String
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
-> NamesT
(TCMT IO)
(Abs
(AbsN
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"φ" ((Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
-> NamesT
(TCMT IO)
(Abs
(AbsN
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))))
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
-> NamesT
(TCMT IO)
(Abs
(AbsN
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
[String]
-> (Vars (TCMT IO)
-> NamesT
(TCMT IO)
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
-> NamesT
(TCMT IO)
(AbsN
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg [Arg String]
xTelIArgNames) ((Vars (TCMT IO)
-> NamesT
(TCMT IO)
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
-> NamesT
(TCMT IO)
(AbsN
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))))
-> (Vars (TCMT IO)
-> NamesT
(TCMT IO)
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
-> NamesT
(TCMT IO)
(AbsN
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
String
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
-> NamesT
(TCMT IO)
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"ψ" ((Var (TCMT IO)
-> NamesT
(TCMT IO)
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
-> NamesT
(TCMT IO)
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))))
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
-> NamesT
(TCMT IO)
(Abs
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
psi -> do
String
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> NamesT
(TCMT IO)
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
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" ((Var (TCMT IO)
-> NamesT
(TCMT IO)
(Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> NamesT
(TCMT IO)
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> NamesT
(TCMT IO)
(Abs (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
u -> do
String
-> (Var (TCMT IO)
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> NamesT
(TCMT IO) (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
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" ((Var (TCMT IO)
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> NamesT
(TCMT IO)
(Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> (Var (TCMT IO)
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> NamesT
(TCMT IO) (Abs (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
u0 -> do
[String]
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) ([NamedArg DeBruijnPattern], Dom Type, Term))
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg [Arg String]
deltaArgNames) ((Vars (TCMT IO)
-> NamesT (TCMT IO) ([NamedArg DeBruijnPattern], Dom Type, Term))
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) ([NamedArg DeBruijnPattern], Dom Type, Term))
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
d -> do
let
x0 :: Vars TCM
x0 :: Vars (TCMT IO)
x0 = [NamesT (TCMT IO) b
Var (TCMT IO)
psi,NamesT (TCMT IO) b
Var (TCMT IO)
u,NamesT (TCMT IO) b
Var (TCMT IO)
u0]
ps :: NamesT TCM NAPs
ps :: NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps = NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
-> [NamesT (TCMT IO) (SubstArg [NamedArg DeBruijnPattern])]
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
g1
[NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
pat' NamesT (TCMT IO) (AbsN (AbsN (AbsN DeBruijnPattern)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN DeBruijnPattern)))]
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg (AbsN (AbsN DeBruijnPattern)))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
-> [NamesT (TCMT IO) (SubstArg (AbsN DeBruijnPattern))]
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) DeBruijnPattern
Var (TCMT IO)
phiNamesT (TCMT IO) DeBruijnPattern
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
p) NamesT (TCMT IO) (AbsN DeBruijnPattern)
-> [NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
-> NamesT (TCMT IO) DeBruijnPattern
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
Vars (TCMT IO)
x0]
[NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
d)
rhsTy :: NamesT (TCMT IO) (Dom Type)
rhsTy = NamesT (TCMT IO) (AbsN (Dom Type))
old_ty NamesT (TCMT IO) (AbsN (Dom Type))
-> [NamesT (TCMT IO) (SubstArg (Dom Type))]
-> NamesT (TCMT IO) (Dom Type)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1
[NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
pat NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN Term)))]
-> NamesT (TCMT IO) (AbsN (AbsN Term))
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) (SubstArg (AbsN (AbsN Term)))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN (AbsN Term))
-> [NamesT (TCMT IO) (SubstArg (AbsN Term))]
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
Var (TCMT IO)
phiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
Vars (TCMT IO)
p) NamesT (TCMT IO) (AbsN Term)
-> [NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term
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) (SubstArg Term)]
Vars (TCMT IO)
x0]
[NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) Term]
Vars (TCMT IO)
d)
xTel <- (Telescope -> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Telescope -> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope))
-> NamesT (TCMT IO) Telescope
-> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) Telescope
-> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope))
-> NamesT (TCMT IO) Telescope
-> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope)
forall a b. (a -> b) -> a -> b
$ AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN Telescope
xTel NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
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) (SubstArg Telescope)]
Vars (TCMT IO)
g1
pat_rec <- (open =<<) $ bind "i" $ \ 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 NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (AbsN Term)))]
-> NamesT (TCMT IO) (AbsN (AbsN Term))
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) (SubstArg (AbsN (AbsN Term)))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN (AbsN Term))
-> [NamesT (TCMT IO) (SubstArg (AbsN Term))]
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
Var (TCMT IO)
phiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
Vars (TCMT IO)
p) NamesT (TCMT IO) (AbsN Term)
-> [NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term
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) (SubstArg Term)
x]
let p0 :: [NamesT (TCMT IO) Term]
p0 = [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for [NamesT (TCMT IO) Term]
Vars (TCMT IO)
p ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term])
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
p NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
tr (NamesT (TCMT IO) Type
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
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 (AbsN (AbsN Type) -> NamesT (TCMT IO) (AbsN (AbsN Type))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure AbsN (AbsN Type)
dT NamesT (TCMT IO) (AbsN (AbsN Type))
-> [NamesT (TCMT IO) (SubstArg (AbsN Type))]
-> NamesT (TCMT IO) (AbsN Type)
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) (SubstArg (AbsN Type))]
Vars (TCMT IO)
g1 NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
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) (SubstArg Type)]
p0)
[(NamesT (TCMT IO) Term
Var (TCMT IO)
psi,String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j -> NamesT (TCMT IO) Term
Var (TCMT IO)
u NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) 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 NamesT (TCMT IO) Term
Var (TCMT IO)
i)))
,(NamesT (TCMT IO) Term
Var (TCMT IO)
i ,String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
Var (TCMT IO)
u0)]
NamesT (TCMT IO) Term
Var (TCMT IO)
u0)
let mkBndry NamesT (TCMT IO) (Abs [Term])
args = do
args1 <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ (Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
faces <- pure (fmap (map fst) old_sides) `applyN` args1
us <- forM (mapM (map snd) old_sides) $ \ AbsN Term
u -> do
String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> do
args <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ (Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
j)
pure u `applyN` args
forM (zip faces us) $ \ (Term
phi,Term
u) -> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term, NamesT (TCMT IO) Term))
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (,) (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
phi) (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u)
rhs <- do
d_f <- (open =<<) $ bind "j" $ \ Var (TCMT IO)
j -> do
tel <- String
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
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" ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope))
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> NamesT (TCMT IO) (AbsN Telescope)
delta NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1 [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [Abs Term -> Term -> Term
Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Term -> Term -> Term)
-> NamesT (TCMT IO) (Abs Term) -> NamesT (TCMT IO) (Term -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
pat_rec NamesT (TCMT IO) (Term -> Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
Var (TCMT IO)
j])
let face = Term
iz
j <- j
d <- map defaultArg <$> sequence d
lift $ covFillTele f tel face d j
let args = String
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
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" ((Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> (Var (TCMT IO) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
j -> do
g1 <- [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1
x <- absApp <$> pat_rec <*> neg j
ys <- absApp <$> d_f <*> neg j
pure $ g1 ++ x:ys
ty <- (open =<<) $ bind "j" $ \ Var (TCMT IO)
j -> do
args <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
Var (TCMT IO)
j
fmap unDom $ old_ty `applyN` args
let face = Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz
othersys <- (open =<<) $ lam "j" $ \ NamesT (TCMT IO) Term
j -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> do
args' <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
args NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
j
fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args'
sys <- mkBndry args
let
sysphi = NamesT (TCMT IO) Term
othersys
syspsi = NamesT (TCMT IO) Term
othersys
base <- (open =<<) $ do
args' <- (mapM open =<<) $ absApp <$> args <*> pure iz
fmap (Def f) $ (fmap patternsToElims <$> old_ps) `applyN` args'
transpSys ty ((phi,sysphi):(psi,syspsi):sys) face base
(,,) <$> ps <*> rhsTy <*> pure rhs
let (ps,ty,rhs) = unAbsN $ unAbs $ unAbs $ unAbs $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs
reportSDoc "tc.cover.trx.hcomp" 20 $ "trX-hcomp clause for" <+> prettyTCM f
let c = Clause { clauseLHSRange :: Range
clauseLHSRange = Range
forall a. Range' a
noRange
, clauseFullRange :: Range
clauseFullRange = Range
forall a. Range' a
noRange
, clauseTel :: Telescope
clauseTel = Telescope
cTel
, namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg DeBruijnPattern]
ps
, clauseBody :: Maybe Term
clauseBody = Term -> Maybe Term
forall a. a -> Maybe a
Just Term
rhs
, clauseType :: Maybe (Arg Type)
clauseType = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Arg Type -> Maybe (Arg Type)) -> Arg Type -> Maybe (Arg Type)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Type -> Arg Type
forall e. ArgInfo -> e -> Arg e
Arg (Dom Type -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom Type
ty) (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
ty)
, clauseCatchall :: Bool
clauseCatchall = Bool
False
, clauseExact :: Maybe Bool
clauseExact = Maybe Bool
forall a. Maybe a
Nothing
, clauseRecursive :: Maybe Bool
clauseRecursive = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
, clauseUnreachable :: Maybe Bool
clauseUnreachable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
, clauseEllipsis :: ExpandedEllipsis
clauseEllipsis = ExpandedEllipsis
NoEllipsis
, clauseWhereModule :: Maybe ModuleName
clauseWhereModule = Maybe ModuleName
forall a. Maybe a
Nothing
}
debugClause "tc.cover.trx.hcomp" c
return c
createMissingTrXConClause :: QName
-> QName
-> Arg Nat
-> BlockingVar
-> SplitClause
-> QName
-> 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' Term
tau Substitution' Term
leftInv) = do
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trxcon" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"trX-con clause for" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
f TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"with con" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
c
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.trxcon" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
[ TCMT IO Doc
"gamma" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
gamma
, TCMT IO Doc
"gamma'" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
gamma'
, TCMT IO Doc
"xTel" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
gamma (Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
xTel)
, TCMT IO Doc
"u" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
gamma ([Term] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Term] -> m Doc
prettyTCM [Term]
u)
, TCMT IO Doc
"v" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
gamma ([Term] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Term] -> m Doc
prettyTCM [Term]
v)
, TCMT IO Doc
"rho" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
gamma' (PatternSubstitution -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => PatternSubstitution -> m Doc
prettyTCM PatternSubstitution
rho)
]
Constructor{conSrcCon = chead} <- Definition -> Defn
theDef (Definition -> Defn) -> TCMT IO Definition -> TCMT IO Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
c
iz <- primIZero
interval <- elInf primInterval
let
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
old_ps = AbsN [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern]))
-> AbsN [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
forall a b. (a -> b) -> a -> b
$ [String]
-> [NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern]
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) ([NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
old_ty = AbsN (Dom Type) -> NamesT (TCMT IO) (AbsN (Dom Type))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN (Dom Type) -> NamesT (TCMT IO) (AbsN (Dom Type)))
-> AbsN (Dom Type) -> NamesT (TCMT IO) (AbsN (Dom Type))
forall a b. (a -> b) -> a -> b
$ [String] -> Dom Type -> AbsN (Dom Type)
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) (Dom Type -> AbsN (Dom Type)) -> Dom Type -> AbsN (Dom Type)
forall a b. (a -> b) -> a -> b
$ Dom Type -> Maybe (Dom Type) -> Dom Type
forall a. a -> Maybe a -> a
fromMaybe Dom Type
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
(gamma1x,delta') = splitTelescopeAt (size old_tel - blockingVarNo x) old_tel
let
gammaArgNames = Telescope -> [Arg String]
teleArgNames Telescope
gamma
deltaArgNames = Telescope -> [Arg String]
teleArgNames Telescope
delta'
let
xTelI = AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope))
-> AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a b. (a -> b) -> a -> b
$ [String] -> Telescope -> AbsN Telescope
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma) (Telescope -> AbsN Telescope) -> Telescope -> AbsN Telescope
forall a b. (a -> b) -> a -> b
$ Type -> Telescope -> Telescope
expTelescope Type
interval Telescope
xTel
delta = AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope))
-> AbsN Telescope -> NamesT (TCMT IO) (AbsN Telescope)
forall a b. (a -> b) -> a -> b
$ [String] -> Telescope -> AbsN Telescope
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
gamma1x) (Telescope -> AbsN Telescope) -> Telescope -> AbsN Telescope
forall a b. (a -> b) -> a -> b
$ Telescope
delta'
gamma1_size = (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
gamma1x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
(gamma1,ExtendTel dType' _) = splitTelescopeAt gamma1_size gamma1x
params <- addContext gamma1 $ do
Just (_d, ps, _is) <- getDatatypeArgs . unDom =<< reduce dType'
return $ AbsN (teleNames gamma1) ps
let pat' =
[Arg String]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg String]
gammaArgNames ((ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern)))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
g1_args -> do
[Arg String]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
MonadFail m =>
[Arg String] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg ([String -> Arg String
forall e. e -> Arg e
defaultArg String
"phi"] [Arg String] -> [Arg String] -> [Arg String]
forall a. [a] -> [a] -> [a]
++ Telescope -> [Arg String]
teleArgNames Telescope
xTel) ((ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) DeBruijnPattern)
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
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) = Int
-> [NamesT (TCMT IO) (NamedArg DeBruijnPattern)]
-> ([NamesT (TCMT IO) (NamedArg DeBruijnPattern)],
[NamesT (TCMT IO) (NamedArg DeBruijnPattern)])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
gamma1_size [NamesT (TCMT IO) (NamedArg DeBruijnPattern)]
ArgVars (TCMT IO)
g1_args
(phi:p) <- [NamesT (TCMT IO) (NamedArg DeBruijnPattern)]
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [NamesT (TCMT IO) (NamedArg DeBruijnPattern)]
ArgVars (TCMT IO)
phi_p
args <- sequence args
let cargs = Named_ DeBruijnPattern -> NamedArg DeBruijnPattern
forall e. e -> Arg e
defaultArg (Named_ DeBruijnPattern -> NamedArg DeBruijnPattern)
-> Named_ DeBruijnPattern -> NamedArg DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ DeBruijnPattern -> Named_ DeBruijnPattern
forall a name. a -> Named name a
unnamed (DeBruijnPattern -> Named_ DeBruijnPattern)
-> DeBruijnPattern -> Named_ DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ ConHead
-> ConPatternInfo -> [NamedArg DeBruijnPattern] -> DeBruijnPattern
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
chead ConPatternInfo
noConPatternInfo [NamedArg DeBruijnPattern]
args
param_args <- fmap (map (setQuantity (Quantity0 Q0Inferred) . setHiding Hidden . fmap (unnamed . dotP))) $
pure params `applyN` take gamma1_size (fmap unArg <$> g1_args)
pure $ DefP defaultPatternInfo q_trX $ param_args ++ p ++ [phi,cargs]
pat = ((AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term)
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN DeBruijnPattern -> AbsN Term)
-> AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> ((DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term)
-> (DeBruijnPattern -> Term)
-> AbsN (AbsN DeBruijnPattern)
-> AbsN (AbsN Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijnPattern -> Term) -> AbsN DeBruijnPattern -> AbsN Term
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm (AbsN (AbsN DeBruijnPattern) -> AbsN (AbsN Term))
-> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
-> NamesT (TCMT IO) (AbsN (AbsN Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
pat'
pat_left' = ((AbsN Term -> AbsN (Abs Term))
-> AbsN (AbsN Term) -> AbsN (AbsN (Abs Term))
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((AbsN Term -> AbsN (Abs Term))
-> AbsN (AbsN Term) -> AbsN (AbsN (Abs Term)))
-> ((Term -> Abs Term) -> AbsN Term -> AbsN (Abs Term))
-> (Term -> Abs Term)
-> AbsN (AbsN Term)
-> AbsN (AbsN (Abs Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> Abs Term) -> AbsN Term -> AbsN (Abs Term)
forall a b. (a -> b) -> AbsN a -> AbsN b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i" (Term -> Abs Term) -> (Term -> Term) -> Term -> Abs Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' Term
Substitution' (SubstArg Term)
leftInv)) (AbsN (AbsN Term) -> AbsN (AbsN (Abs Term)))
-> NamesT (TCMT IO) (AbsN (AbsN Term))
-> NamesT (TCMT IO) (AbsN (AbsN (Abs Term)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (AbsN Term))
pat
g1_left' = [String]
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN (Abs [Term])))
-> NamesT (TCMT IO) (AbsN (AbsN (Abs [Term])))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg [Arg String]
gammaArgNames) ((Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN (Abs [Term])))
-> NamesT (TCMT IO) (AbsN (AbsN (Abs [Term]))))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (AbsN (Abs [Term])))
-> NamesT (TCMT IO) (AbsN (AbsN (Abs [Term])))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
g1_args -> do
[String]
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) (AbsN (Abs [Term]))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg ([Arg String] -> [String]) -> [Arg String] -> [String]
forall a b. (a -> b) -> a -> b
$ [String -> Arg String
forall e. e -> Arg e
defaultArg String
"phi"] [Arg String] -> [Arg String] -> [Arg String]
forall a. [a] -> [a] -> [a]
++ Telescope -> [Arg String]
teleArgNames Telescope
xTel) ((Vars (TCMT IO) -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) (AbsN (Abs [Term])))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) (AbsN (Abs [Term]))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
phi_p -> do
g1 <- [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term])
-> [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ Int -> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. Int -> [a] -> [a]
take Int
gamma1_size [NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1_args :: NamesT TCM [Term]
pure $ Abs "i" (applySubst leftInv g1)
gamma <- return $ pure gamma
let deltaPat [NamesT (TCMT IO) Term]
g1_args NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p =
NamesT (TCMT IO) (AbsN Telescope)
delta NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (Int -> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. Int -> [a] -> [a]
take Int
gamma1_size [NamesT (TCMT IO) Term]
g1_args [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN Term))
pat NamesT (TCMT IO) (AbsN (AbsN Term))
-> [NamesT (TCMT IO) (SubstArg (AbsN Term))]
-> NamesT (TCMT IO) (AbsN Term)
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) (SubstArg (AbsN Term))]
g1_args NamesT (TCMT IO) (AbsN Term)
-> [NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
phiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
p)])
let neg NamesT m Term
i = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i
cTel <- runNamesT [] $
abstractN gamma $ \ Vars (TCMT IO)
g1_args -> do
String
-> NamesT (TCMT IO) Type
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
String -> NamesT m Type -> (Var m -> NamesT m a) -> NamesT m a
abstractT String
"φ" (Type -> NamesT (TCMT IO) Type
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
interval) ((Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
NamesT (TCMT IO) Telescope
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
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 NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) Telescope
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) (SubstArg Telescope)]
Vars (TCMT IO)
g1_args) ((Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
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 [NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1_args NamesT (TCMT IO) Term
Var (TCMT IO)
phi [NamesT (TCMT IO) Term]
Vars (TCMT IO)
p
ps_ty_rhs <- runNamesT [] $ do
bindN (map unArg gammaArgNames) $ \ Vars (TCMT IO)
g1_args -> do
String
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> NamesT
(TCMT IO)
(Abs (AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
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" ((Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> NamesT
(TCMT IO)
(Abs (AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))))
-> (Var (TCMT IO)
-> NamesT
(TCMT IO)
(AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> NamesT
(TCMT IO)
(Abs (AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
phi -> do
[String]
-> (Vars (TCMT IO)
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> NamesT
(TCMT IO)
(AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN (Telescope -> [String]
teleNames Telescope
xTel) ((Vars (TCMT IO)
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> NamesT
(TCMT IO)
(AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))))
-> (Vars (TCMT IO)
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> NamesT
(TCMT IO)
(AbsN (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
p -> do
[String]
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) ([NamedArg DeBruijnPattern], Dom Type, Term))
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))
forall (m :: * -> *) a.
MonadFail m =>
[String] -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN ((Arg String -> String) -> [Arg String] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Arg String -> String
forall e. Arg e -> e
unArg ([Arg String] -> [String]) -> [Arg String] -> [String]
forall a b. (a -> b) -> a -> b
$ [Arg String]
deltaArgNames) ((Vars (TCMT IO)
-> NamesT (TCMT IO) ([NamedArg DeBruijnPattern], Dom Type, Term))
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term)))
-> (Vars (TCMT IO)
-> NamesT (TCMT IO) ([NamedArg DeBruijnPattern], Dom Type, Term))
-> NamesT
(TCMT IO) (AbsN ([NamedArg DeBruijnPattern], Dom Type, Term))
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' NamesT (TCMT IO) (AbsN (AbsN (Abs [Term])))
-> [NamesT (TCMT IO) (SubstArg (AbsN (Abs [Term])))]
-> NamesT (TCMT IO) (AbsN (Abs [Term]))
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) (SubstArg (AbsN (Abs [Term])))]
Vars (TCMT IO)
g1_args NamesT (TCMT IO) (AbsN (Abs [Term]))
-> [NamesT (TCMT IO) (SubstArg (Abs [Term]))]
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
Var (TCMT IO)
phiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
Vars (TCMT IO)
p)
pat_left :: NamesT (TCMT IO) (Abs Term)
pat_left = NamesT (TCMT IO) (AbsN (AbsN (Abs Term)))
pat_left' NamesT (TCMT IO) (AbsN (AbsN (Abs Term)))
-> [NamesT (TCMT IO) (SubstArg (AbsN (Abs Term)))]
-> NamesT (TCMT IO) (AbsN (Abs Term))
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) (SubstArg (AbsN (Abs Term)))]
Vars (TCMT IO)
g1_args NamesT (TCMT IO) (AbsN (Abs Term))
-> [NamesT (TCMT IO) (SubstArg (Abs Term))]
-> NamesT (TCMT IO) (Abs Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
Var (TCMT IO)
phiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
Vars (TCMT IO)
p)
g1 :: Vars TCM
g1 :: Vars (TCMT IO)
g1 = Int -> [NamesT (TCMT IO) b] -> [NamesT (TCMT IO) b]
forall a. Int -> [a] -> [a]
take Int
gamma1_size [NamesT (TCMT IO) b]
Vars (TCMT IO)
g1_args
args :: Vars TCM
args :: Vars (TCMT IO)
args = Int -> [NamesT (TCMT IO) b] -> [NamesT (TCMT IO) b]
forall a. Int -> [a] -> [a]
drop Int
gamma1_size [NamesT (TCMT IO) b]
Vars (TCMT IO)
g1_args
ps :: NamesT TCM NAPs
ps :: NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps = NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
old_ps NamesT (TCMT IO) (AbsN [NamedArg DeBruijnPattern])
-> [NamesT (TCMT IO) (SubstArg [NamedArg DeBruijnPattern])]
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
g1 [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
pat' NamesT (TCMT IO) (AbsN (AbsN DeBruijnPattern))
-> [NamesT (TCMT IO) (SubstArg (AbsN DeBruijnPattern))]
-> NamesT (TCMT IO) (AbsN DeBruijnPattern)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) DeBruijnPattern]
[NamesT (TCMT IO) (SubstArg (AbsN DeBruijnPattern))]
Vars (TCMT IO)
g1_args NamesT (TCMT IO) (AbsN DeBruijnPattern)
-> [NamesT (TCMT IO) (SubstArg DeBruijnPattern)]
-> NamesT (TCMT IO) DeBruijnPattern
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) DeBruijnPattern
Var (TCMT IO)
phiNamesT (TCMT IO) DeBruijnPattern
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
p)] [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
-> [NamesT (TCMT IO) DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) DeBruijnPattern]
Vars (TCMT IO)
d)
rhsTy :: NamesT (TCMT IO) (Dom Type)
rhsTy = NamesT (TCMT IO) (AbsN (Dom Type))
old_ty NamesT (TCMT IO) (AbsN (Dom Type))
-> [NamesT (TCMT IO) (SubstArg (Dom Type))]
-> NamesT (TCMT IO) (Dom Type)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
Vars (TCMT IO)
g1 [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) (AbsN (AbsN Term))
pat NamesT (TCMT IO) (AbsN (AbsN Term))
-> [NamesT (TCMT IO) (SubstArg (AbsN Term))]
-> NamesT (TCMT IO) (AbsN Term)
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) (SubstArg (AbsN Term))]
Vars (TCMT IO)
g1_args NamesT (TCMT IO) (AbsN Term)
-> [NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term
Var (TCMT IO)
phiNamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. a -> [a] -> [a]
:[NamesT (TCMT IO) Term]
Vars (TCMT IO)
p)] [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++ [NamesT (TCMT IO) Term]
Vars (TCMT IO)
d)
delta_f <- (Abs Telescope
-> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Telescope))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Telescope
-> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Telescope)))
-> NamesT (TCMT IO) (Abs Telescope)
-> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Telescope))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) (Abs Telescope)
-> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Telescope)))
-> NamesT (TCMT IO) (Abs Telescope)
-> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Telescope))
forall a b. (a -> b) -> a -> b
$ String
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
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) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope))
-> (Var (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ Var (TCMT IO)
i -> do
let ni :: NamesT (TCMT IO) Term
ni = NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg NamesT (TCMT IO) Term
Var (TCMT IO)
i
dargs <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ do
xs <- Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
g1_left NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
ni
y <- absApp <$> pat_left <*> ni
return $ xs ++ [y]
delta `applyN` dargs
d_f <- (open =<<) $ bind "i" $ \ Var (TCMT IO)
i -> do
delta_f <- NamesT (TCMT IO) (Abs Telescope)
delta_f
phi <- phi
d <- map defaultArg <$> sequence d
i <- i
lift $ covFillTele f delta_f phi d i
w <- (open =<<) $ bind "i" $ \ Var (TCMT IO)
i -> do
psargs <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ do
xs <- Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
g1_left NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
Var (TCMT IO)
i
y <- absApp <$> pat_left <*> i
zs <- absApp <$> d_f <*> neg i
return $ xs ++ [y] ++ zs
ps <- (fmap patternsToElims <$> old_ps) `applyN` psargs
pure $ Def f ps
ty <- (open =<<) $ bind "i" $ \ Var (TCMT IO)
i -> do
tyargs <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ do
xs <- Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
g1_left NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
Var (TCMT IO)
i
y <- absApp <$> pat_left <*> i
zs <- absApp <$> d_f <*> neg i
return $ xs ++ [y] ++ zs
fmap unDom $ old_ty `applyN` tyargs
sys <- do
sides <- do
neg <- primINeg
io <- primIOne
vs <- iApplyVars <$> ps
tm <- w
xs <- forM vs $ \ Int
v ->
((Abs Term, Abs Term) -> (Term, (Abs Term, Abs Term)))
-> NamesT (TCMT IO) (Abs Term, Abs Term)
-> NamesT (TCMT IO) (Term, (Abs Term, Abs Term))
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Term
var Int
v,) (NamesT (TCMT IO) (Abs Term, Abs Term)
-> NamesT (TCMT IO) (Term, (Abs Term, Abs Term)))
-> ((Abs Term, Abs Term) -> NamesT (TCMT IO) (Abs Term, Abs Term))
-> (Abs Term, Abs Term)
-> NamesT (TCMT IO) (Term, (Abs Term, Abs Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Abs Term, Abs Term) -> NamesT (TCMT IO) (Abs Term, Abs Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce ((Abs Term, Abs Term)
-> NamesT (TCMT IO) (Term, (Abs Term, Abs Term)))
-> (Abs Term, Abs Term)
-> NamesT (TCMT IO) (Term, (Abs Term, Abs Term))
forall a b. (a -> b) -> a -> b
$ (Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
iz Substitution' (SubstArg (Abs Term)) -> Abs Term -> Abs Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Abs Term
tm, Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
io Substitution' (SubstArg (Abs Term)) -> Abs Term -> Abs Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Abs Term
tm)
return $ concatMap (\(Term
v,(Abs Term
l,Abs Term
r)) -> [(Term
neg Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
v],Abs Term
l),(Term
v,Abs Term
r)]) xs
forM sides $ \ (Term
psi,Abs Term
u') -> do
u' <- Abs Term -> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Term))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Abs Term
u'
u <- lam "i" $ \ NamesT (TCMT IO) Term
i -> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
o -> Abs Term -> Term -> Term
Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Term -> Term -> Term)
-> NamesT (TCMT IO) (Abs Term) -> NamesT (TCMT IO) (Term -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
u' NamesT (TCMT IO) (Term -> Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
i
(,) <$> open psi <*> open u
let rhs = NamesT (TCMT IO) (Abs Type)
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
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
Var (TCMT IO)
phi (Abs Term -> Term -> Term
Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Term -> Term -> Term)
-> NamesT (TCMT IO) (Abs Term) -> NamesT (TCMT IO) (Term -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
w NamesT (TCMT IO) (Term -> Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz)
(,,) <$> ps <*> rhsTy <*> rhs
let (ps,ty,rhs) = unAbsN $ unAbsN $ unAbs $ unAbsN $ ps_ty_rhs
qs <- mapM (fmap (fromMaybe __IMPOSSIBLE__) . getName') [builtinINeg, builtinIMax, builtinIMin]
rhs <- addContext cTel $
locallyReduceDefs (OnlyReduceDefs (Set.fromList $ q_trX : qs)) $ normalise rhs
let cl = Clause { clauseLHSRange :: Range
clauseLHSRange = Range
forall a. Range' a
noRange
, clauseFullRange :: Range
clauseFullRange = Range
forall a. Range' a
noRange
, clauseTel :: Telescope
clauseTel = Telescope
cTel
, namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg DeBruijnPattern]
ps
, clauseBody :: Maybe Term
clauseBody = Term -> Maybe Term
forall a. a -> Maybe a
Just Term
rhs
, clauseType :: Maybe (Arg Type)
clauseType = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Arg Type -> Maybe (Arg Type)) -> Arg Type -> Maybe (Arg Type)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Type -> Arg Type
forall e. ArgInfo -> e -> Arg e
Arg (Dom Type -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom Type
ty) (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
ty)
, clauseCatchall :: Bool
clauseCatchall = Bool
False
, clauseExact :: Maybe Bool
clauseExact = Maybe Bool
forall a. Maybe a
Nothing
, clauseRecursive :: Maybe Bool
clauseRecursive = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
, clauseUnreachable :: Maybe Bool
clauseUnreachable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
, clauseEllipsis :: ExpandedEllipsis
clauseEllipsis = ExpandedEllipsis
NoEllipsis
, clauseWhereModule :: Maybe ModuleName
clauseWhereModule = Maybe ModuleName
forall a. Maybe a
Nothing
}
debugClause "tc.cover.trxcon" cl
reportSDoc "tc.cover.trxcon" 20 $ vcat $
[ "clause:"
, nest 2 $ prettyTCM . QNamed f $ cl
]
let mod =
Relevance -> Modality -> Modality
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant (Modality -> Modality) -> Modality -> Modality
forall a b. (a -> b) -> a -> b
$
Dom Type -> Modality
forall a. LensModality a => a -> Modality
getModality (Dom Type -> Modality) -> Dom Type -> Modality
forall a b. (a -> b) -> a -> b
$ Dom Type -> Maybe (Dom Type) -> Dom Type
forall a. a -> Maybe a -> a
fromMaybe Dom Type
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
applyModalityToContext mod $ do
unlessM (hasQuantity0 <$> viewTC eQuantity) $ do
reportSDoc "tc.cover.trxcon" 20 $ text "testing usable at mod: " <+> pretty mod
addContext cTel $ usableAtModality IndexedClause mod rhs
return cl
createMissingConIdClause :: QName
-> Arg Nat
-> BlockingVar
-> SplitClause
-> IInfo
-> 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) = QName
-> TCM (Maybe ((SplitTag, SplitTree' SplitTag), Clause))
-> TCM (Maybe ((SplitTag, SplitTree' SplitTag), Clause))
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
f (TCM (Maybe ((SplitTag, SplitTree' SplitTag), Clause))
-> TCM (Maybe ((SplitTag, SplitTree' SplitTag), Clause)))
-> TCM (Maybe ((SplitTag, SplitTree' SplitTag), Clause))
-> TCM (Maybe ((SplitTag, SplitTree' SplitTag), Clause))
forall a b. (a -> b) -> a -> b
$ do
let
itel :: UnifyEquiv -> Telescope
itel = UnifyEquiv -> Telescope
infoTel
irho :: PatternSubstitution
irho = UnifyEquiv -> PatternSubstitution
infoRho UnifyEquiv
info
itau :: Substitution' Term
itau = UnifyEquiv -> Substitution' Term
infoTau UnifyEquiv
info
ileftInv :: Substitution' Term
ileftInv = UnifyEquiv -> Substitution' Term
infoLeftInv UnifyEquiv
info
interval <- TCMT IO Term -> TCMT IO Type
forall (m :: * -> *). Functor m => m Term -> m Type
elInf TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primInterval
tTrans <- primTrans
tComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinComp
conId <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinConId
let bindSplit (Telescope
tel1,a
tel2) = (Telescope
tel1,[String] -> a -> AbsN a
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
tel1) a
tel2)
let
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
pair@(_gamma,_hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel
(gamma,hdelta) = bindSplit pair
old_t = [String] -> Dom Type -> AbsN (Dom Type)
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) (Dom Type -> AbsN (Dom Type)) -> Dom Type -> AbsN (Dom Type)
forall a b. (a -> b) -> a -> b
$ Maybe (Dom Type) -> Dom Type
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
old_ps = [String] -> [Elim] -> AbsN [Elim]
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) ([Elim] -> AbsN [Elim]) -> [Elim] -> AbsN [Elim]
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims ([NamedArg DeBruijnPattern] -> [Elim])
-> [NamedArg DeBruijnPattern] -> [Elim]
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
old_ps' = [String]
-> [NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern]
forall a. [String] -> a -> AbsN a
AbsN (Telescope -> [String]
teleNames Telescope
old_tel) ([NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> AbsN [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
params <- runNamesT [] $ do
hdelta <- open hdelta
bindN (teleNames gamma) $ \ Vars (TCMT IO)
args -> do
hdelta@(ExtendTel hdom _) <- NamesT (TCMT IO) (AbsN Telescope)
-> [NamesT (TCMT IO) (SubstArg Telescope)]
-> NamesT (TCMT IO) 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 [NamesT (TCMT IO) Term]
[NamesT (TCMT IO) (SubstArg Telescope)]
Vars (TCMT IO)
args
Def _Id es@[_,_,_,_] <- reduce $ unEl $ unDom hdom
return $ map unArg $ fromMaybe __IMPOSSIBLE__ $ allApplyElims es
working_tel <- runNamesT [] $ do
hdelta <- open hdelta
params <- open params
abstractN (pure gamma) $ \ Vars (TCMT IO)
args -> do
pTel <- Telescope -> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Telescope -> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope))
-> NamesT (TCMT IO) Telescope
-> NamesT (TCMT IO) (NamesT (TCMT IO) Telescope)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCMT IO Telescope -> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Telescope -> Args -> Args -> TCMT IO Telescope
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Telescope -> Args -> Args -> m Telescope
pathTelescope (UnifyEquiv -> Telescope
infoEqTel UnifyEquiv
info) ((Term -> Arg Term) -> [Term] -> Args
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
defaultArg ([Term] -> Args) -> [Term] -> Args
forall a b. (a -> b) -> a -> b
$ UnifyEquiv -> [Term]
infoEqLHS UnifyEquiv
info) ((Term -> Arg Term) -> [Term] -> Args
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
defaultArg ([Term] -> Args) -> [Term] -> Args
forall a b. (a -> b) -> a -> b
$ UnifyEquiv -> [Term]
infoEqRHS UnifyEquiv
info))
abstractN (pure (telFromList [defaultDom ("phi",interval)] :: Telescope)) $ \ [NamesT (TCMT IO) Term
phi] ->
NamesT (TCMT IO) Telescope
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall (m :: * -> *) a.
(MonadFail m, Abstract a) =>
NamesT m Telescope -> (Vars m -> NamesT m a) -> NamesT m a
abstractN NamesT (TCMT IO) Telescope
pTel ((Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope)
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) Telescope
forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term
p] -> do
[l,bA,x,y] <- (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NamesT (TCMT IO) (AbsN [Term])
-> [NamesT (TCMT IO) (SubstArg [Term])] -> NamesT (TCMT IO) [Term]
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]
[NamesT (TCMT IO) (SubstArg [Term])]
Vars (TCMT IO)
args
apply1 <$> applyN hdelta args <*> (cl primConId <#> l <#> bA <#> x <#> y <@> phi <@> p)
(gamma_args_left :: Abs [Term], con_phi_p_left :: Abs Term) <- fmap (raise (size delta) . unAbsN) . runNamesT [] $ do
params <- open params
bindN (teleNames gamma ++ ["phi","p"]) $ \ Vars (TCMT IO)
args' -> do
let ([NamesT (TCMT IO) Term]
args,[NamesT (TCMT IO) Term
phi,NamesT (TCMT IO) Term
p]) = Int
-> [NamesT (TCMT IO) Term]
-> ([NamesT (TCMT IO) Term], [NamesT (TCMT IO) Term])
forall a. Int -> [a] -> ([a], [a])
splitAt (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
gamma) [NamesT (TCMT IO) Term]
Vars (TCMT IO)
args'
[l,bA,x,y] <- (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NamesT (TCMT IO) (AbsN [Term])
-> [NamesT (TCMT IO) (SubstArg [Term])] -> NamesT (TCMT IO) [Term]
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]
[NamesT (TCMT IO) (SubstArg [Term])]
args
gargs <- Abs "i" . applySubst ileftInv <$> sequence args
con_phi_p <- Abs "i" . applySubst ileftInv <$> do
(cl primConId <#> l <#> bA <#> x <#> y <@> phi <@> p)
return (gargs,con_phi_p)
ps <- fmap unAbsN . runNamesT [] $ do
old_ps' <- open $ old_ps'
params <- open params
bindN (teleNames working_tel) $ \ ([NamesT (TCMT IO) Term]
wargs :: [NamesT TCM Term]) -> do
let ([NamedArg DeBruijnPattern]
g,NamedArg DeBruijnPattern
phi:NamedArg DeBruijnPattern
p:[NamedArg DeBruijnPattern]
d) = Int
-> [NamedArg DeBruijnPattern]
-> ([NamedArg DeBruijnPattern], [NamedArg DeBruijnPattern])
forall a. Int -> [a] -> ([a], [a])
splitAt (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
gamma) ([NamedArg DeBruijnPattern]
-> ([NamedArg DeBruijnPattern], [NamedArg DeBruijnPattern]))
-> [NamedArg DeBruijnPattern]
-> ([NamedArg DeBruijnPattern], [NamedArg DeBruijnPattern])
forall a b. (a -> b) -> a -> b
$ Telescope -> [(Term, (Term, Term))] -> [NamedArg DeBruijnPattern]
forall a.
DeBruijn a =>
Telescope -> [(Term, (Term, Term))] -> [NamedArg (Pattern' a)]
telePatterns Telescope
working_tel []
params <- (Term -> NamedArg DeBruijnPattern)
-> [Term] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> [a] -> [b]
map (Named_ DeBruijnPattern -> NamedArg DeBruijnPattern
forall e. e -> Arg e
argH (Named_ DeBruijnPattern -> NamedArg DeBruijnPattern)
-> (Term -> Named_ DeBruijnPattern)
-> Term
-> NamedArg DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. DeBruijnPattern -> Named_ DeBruijnPattern
forall a name. a -> Named name a
unnamed (DeBruijnPattern -> Named_ DeBruijnPattern)
-> (Term -> DeBruijnPattern) -> Term -> Named_ DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> DeBruijnPattern
forall a. Term -> Pattern' a
dotP) ([Term] -> [NamedArg DeBruijnPattern])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN [Term])
-> [NamesT (TCMT IO) (SubstArg [Term])] -> NamesT (TCMT IO) [Term]
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 (Int -> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. Int -> [a] -> [a]
take (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
gamma) [NamesT (TCMT IO) Term]
wargs)
let x = PatternInfo
-> QName -> [NamedArg DeBruijnPattern] -> DeBruijnPattern
forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
defaultPatternInfo QName
conId ([NamedArg DeBruijnPattern] -> DeBruijnPattern)
-> [NamedArg DeBruijnPattern] -> DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern]
params [NamedArg DeBruijnPattern]
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern
phi,NamedArg DeBruijnPattern
p]
args <- open $ map namedArg g ++ [x] ++ map namedArg d
applyN' old_ps' args
let
getLevel a
t = do
s <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ a -> Sort
forall a. LensSort a => a -> Sort
getSort a
t
case s of
Type Level
l -> Term -> m Term
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Level -> Term
Level Level
l)
Sort
s -> do
String -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"getLevel, s = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort -> m Doc
prettyTCM Sort
s
TypeError -> m Term
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m Term) -> (Doc -> TypeError) -> Doc -> m Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> m Term) -> m Doc -> m Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"The sort of" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
t m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"should be of the form \"Set l\"")
(ty,rhs) <- addContext working_tel $ runNamesT [] $ do
let
raiseFrom :: Subst a => Telescope -> a -> a
raiseFrom Telescope
tel a
x = Int -> a -> a
forall a. Subst a => Int -> a -> a
raise (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
working_tel Int -> Int -> Int
forall a. Num a => a -> a -> a
- Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
tel) a
x
all_args = Telescope -> Args
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Telescope
working_tel :: Args
(gamma_args,phi:p:delta_args) = splitAt (size gamma) all_args
old_t <- open $ raiseFrom EmptyTel old_t
old_ps <- open $ raiseFrom EmptyTel old_ps
delta_args <- open delta_args
gamma_args_left <- open gamma_args_left
con_phi_p_left <- open con_phi_p_left
hdelta <- open $ raiseFrom gamma hdelta
delta_f <- bind "i" $ \ Var (TCMT IO)
i -> do
Telescope -> Term -> Telescope
forall t. Apply t => t -> Term -> t
apply1 (Telescope -> Term -> Telescope)
-> NamesT (TCMT IO) Telescope
-> NamesT (TCMT IO) (Term -> Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN Telescope)
-> NamesT (TCMT IO) [SubstArg Telescope]
-> NamesT (TCMT IO) 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 (Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
gamma_args_left NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
Var (TCMT IO)
i)) NamesT (TCMT IO) (Term -> Telescope)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Telescope
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Abs Term -> Term -> Term
Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs Term -> Term -> Term)
-> NamesT (TCMT IO) (Abs Term) -> NamesT (TCMT IO) (Term -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Term)
con_phi_p_left NamesT (TCMT IO) (Term -> Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
Var (TCMT IO)
i))
delta_f <- open delta_f
[phi,p] <- mapM (open . unArg) [phi,p]
delta_args_f <- bind "i" $ \ Var (TCMT IO)
i -> do
m <- Bool
-> Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) Args
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) m Args
trFillTel' Bool
True (Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> NamesT (TCMT IO) (Abs Telescope)
-> NamesT
(TCMT IO)
(Term
-> Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Telescope)
delta_f NamesT
(TCMT IO)
(Term
-> Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> NamesT (TCMT IO) Term
-> NamesT
(TCMT IO)
(Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
phi NamesT
(TCMT IO)
(Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> NamesT (TCMT IO) Args
-> NamesT
(TCMT IO) (Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Args
delta_args NamesT
(TCMT IO) (Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) (ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
Var (TCMT IO)
i
either __IMPOSSIBLE__ id <$> lift (runExceptT m)
delta_args_f <- open delta_args_f
old_t_f <- (open =<<) $ bind "i" $ \ Var (TCMT IO)
i -> do
g <- Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
gamma_args_left NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
Var (TCMT IO)
i
x <- lazyAbsApp <$> con_phi_p_left <*> i
d <- lazyAbsApp <$> delta_args_f <*> (cl primINeg <@> i)
args <- open $ g ++ [x] ++ map unArg d
applyN' old_t args
w <- (open =<<) $ bind "i" $ \ Var (TCMT IO)
i -> do
g <- Abs [Term] -> Term -> [Term]
Abs [Term] -> SubstArg [Term] -> [Term]
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs [Term] -> Term -> [Term])
-> NamesT (TCMT IO) (Abs [Term])
-> NamesT (TCMT IO) (Term -> [Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Term])
gamma_args_left NamesT (TCMT IO) (Term -> [Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Term]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
Var (TCMT IO)
i
x <- lazyAbsApp <$> con_phi_p_left <*> i
d <- lazyAbsApp <$> delta_args_f <*> (cl primINeg <@> i)
args <- open $ g ++ [x] ++ map unArg d
Def f <$> applyN' old_ps args
ps <- open ps
max <- primIMax
iz <- primIZero
alphas <- (open =<<) $ do
vs <- iApplyVars <$> ps
neg <- primINeg
zero <- primIZero
return $ foldr (\ Term
x Term
r -> Term
max Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Term
max Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
x, Term -> Arg Term
forall e. e -> Arg e
argN (Term
neg Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
x])], Term -> Arg Term
forall e. e -> Arg e
argN Term
r]) zero $ map var vs
sides <- (open =<<) $ do
neg <- primINeg
io <- primIOne
bind "i" $ \ Var (TCMT IO)
i -> do
vs <- [NamedArg DeBruijnPattern] -> [Int]
forall p. IApplyVars p => p -> [Int]
iApplyVars ([NamedArg DeBruijnPattern] -> [Int])
-> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
-> NamesT (TCMT IO) [Int]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [NamedArg DeBruijnPattern]
ps
tm <- lazyAbsApp <$> w <*> i
xs <- forM vs $ \ Int
v ->
((Term, Term) -> (Term, (Term, Term)))
-> NamesT (TCMT IO) (Term, Term)
-> NamesT (TCMT IO) (Term, (Term, Term))
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Int -> Term
var Int
v,) (NamesT (TCMT IO) (Term, Term)
-> NamesT (TCMT IO) (Term, (Term, Term)))
-> ((Term, Term) -> NamesT (TCMT IO) (Term, Term))
-> (Term, Term)
-> NamesT (TCMT IO) (Term, (Term, Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term, Term) -> NamesT (TCMT IO) (Term, Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce ((Term, Term) -> NamesT (TCMT IO) (Term, (Term, Term)))
-> (Term, Term) -> NamesT (TCMT IO) (Term, (Term, Term))
forall a b. (a -> b) -> a -> b
$ (Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
iz Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm, Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
v Term
io Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm)
phiv <- fromMaybe __IMPOSSIBLE__ . deBruijnView <$> phi
tm_phi <- reduce $ inplaceS phiv io `applySubst` tm
phi <- phi
return $ (phi,tm_phi) : concatMap (\(Term
v,(Term
l,Term
r)) -> [(Term
neg Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
v],Term
l),(Term
v,Term
r)]) xs
let imax Term
i Term
j = Term -> Args -> Term
forall t. Apply t => t -> Args -> t
apply Term
max (Args -> Term) -> Args -> Term
forall a b. (a -> b) -> a -> b
$ (Term -> Arg Term) -> [Term] -> Args
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Term
i,Term
j]
tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr
let
pOr NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty Term
phi Term
psi Term
u0 NamesT (TCMT IO) Term
u1 = do
[phi,psi] <- (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Term
phi,Term
psi]
pure tPOr <#> l
<@> phi <@> psi
<#> ilam "o" (\ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
ty) <@> noilam u0 <@> u1
noilam Term
u = do
u <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u
ilam "o" $ \ NamesT m Term
_ -> NamesT m Term
u
combine NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty [] = NamesT (TCMT IO) Term
forall a. HasCallStack => a
__IMPOSSIBLE__
combine NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty [(Term
psi,Term
u)] = Term -> NamesT (TCMT IO) Term
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 ((Term -> Term -> Term) -> Term -> [Term] -> Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr Term -> Term -> Term
imax Term
iz (((Term, Term) -> Term) -> [(Term, Term)] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Term, Term) -> Term
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
i = Abs (Dom Type) -> Term -> Dom Type
Abs (Dom Type) -> SubstArg (Dom Type) -> Dom Type
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs (Dom Type) -> Term -> Dom Type)
-> NamesT (TCMT IO) (Abs (Dom Type))
-> NamesT (TCMT IO) (Term -> Dom Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Dom Type))
old_t_f NamesT (TCMT IO) (Term -> Dom Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Dom Type)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
i
l <- (open =<<) $ lam "i" $ \ NamesT (TCMT IO) Term
i -> do
t <- Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Type)
-> NamesT (TCMT IO) (Dom Type) -> NamesT (TCMT IO) Type
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
lift $ getLevel t
((,) <$> ty (cl primIOne) <*>) $ do
n <- length . unAbs <$> sides
if n > 1 then
pure tComp <#> l <@> lam "i" (\ NamesT (TCMT IO) Term
i -> Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> (Dom Type -> Type) -> Dom Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Term)
-> NamesT (TCMT IO) (Dom Type) -> NamesT (TCMT IO) Term
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)
<@> (cl primIMax <@> phi <@> alphas)
<@> lam "i" (\ 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 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i) (Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> (Dom Type -> Type) -> Dom Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Term)
-> NamesT (TCMT IO) (Dom Type) -> NamesT (TCMT IO) Term
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) ([(Term, Term)] -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [(Term, Term)] -> NamesT (TCMT IO) Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Abs [(Term, Term)] -> Term -> [(Term, Term)]
Abs [(Term, Term)] -> SubstArg [(Term, Term)] -> [(Term, Term)]
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs [(Term, Term)] -> Term -> [(Term, Term)])
-> NamesT (TCMT IO) (Abs [(Term, Term)])
-> NamesT (TCMT IO) (Term -> [(Term, Term)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [(Term, Term)])
sides NamesT (TCMT IO) (Term -> [(Term, Term)])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [(Term, Term)]
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
i))
<@> (lazyAbsApp <$> w <*> primIZero)
else
pure tTrans <#> l <@> lam "i" (\ NamesT (TCMT IO) Term
i -> Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> (Dom Type -> Type) -> Dom Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Term)
-> NamesT (TCMT IO) (Dom Type) -> NamesT (TCMT IO) Term
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)
<@> phi
<@> (lazyAbsApp <$> w <*> primIZero)
reportSDoc "tc.cover.conid" 20 $ text "conid case for" <+> text (show f)
reportSDoc "tc.cover.conid" 20 $ text "tel =" <+> prettyTCM working_tel
reportSDoc "tc.cover.conid" 25 $ addContext working_tel $ prettyTCM rhs
let cl = Clause { clauseLHSRange :: Range
clauseLHSRange = Range
forall a. Range' a
noRange
, clauseFullRange :: Range
clauseFullRange = Range
forall a. Range' a
noRange
, clauseTel :: Telescope
clauseTel = Telescope
working_tel
, namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg DeBruijnPattern]
ps
, clauseBody :: Maybe Term
clauseBody = Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> Term -> Maybe Term
forall a b. (a -> b) -> a -> b
$ Term
rhs
, clauseType :: Maybe (Arg Type)
clauseType = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Arg Type -> Maybe (Arg Type)) -> Arg Type -> Maybe (Arg Type)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Type -> Arg Type
forall e. ArgInfo -> e -> Arg e
Arg (Dom Type -> ArgInfo
forall t e. Dom' t e -> ArgInfo
domInfo Dom Type
ty) (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
ty)
, clauseCatchall :: Bool
clauseCatchall = Bool
False
, clauseUnreachable :: Maybe Bool
clauseUnreachable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
, clauseRecursive :: Maybe Bool
clauseRecursive = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
, clauseEllipsis :: ExpandedEllipsis
clauseEllipsis = ExpandedEllipsis
NoEllipsis
, clauseExact :: Maybe Bool
clauseExact = Maybe Bool
forall a. Maybe a
Nothing
, clauseWhereModule :: Maybe ModuleName
clauseWhereModule = Maybe ModuleName
forall a. Maybe a
Nothing
}
addClauses f [cl]
return $ Just ((SplitCon conId,SplittingDone (size working_tel)),cl)
createMissingConIdClause QName
f Arg Int
n BlockingVar
x SplitClause
old_sc IInfo
NoInfo = Maybe ((SplitTag, SplitTree' SplitTag), Clause)
-> TCM (Maybe ((SplitTag, SplitTree' SplitTag), Clause))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ((SplitTag, SplitTree' SplitTag), Clause)
forall a. Maybe a
Nothing
createMissingHCompClause
:: QName
-> Arg Nat
-> BlockingVar
-> SplitClause
-> SplitClause
-> [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' Term)
_cps (Just Dom Type
t)) [Clause]
cs = QName
-> TCM ([(SplitTag, CoverResult)], [Clause])
-> TCM ([(SplitTag, CoverResult)], [Clause])
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
f (TCM ([(SplitTag, CoverResult)], [Clause])
-> TCM ([(SplitTag, CoverResult)], [Clause]))
-> TCM ([(SplitTag, CoverResult)], [Clause])
-> TCM ([(SplitTag, CoverResult)], [Clause])
forall a b. (a -> b) -> a -> b
$ do
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
tel (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"Trying to create right-hand side of type" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Dom Type -> m Doc
prettyTCM Dom Type
t
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
tel (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"ps = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps)
String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"tel = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
tel
io <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> TCMT IO (Maybe Term) -> TCMT IO Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuiltinId -> TCMT IO (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinIOne
iz <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIZero
let
cannotCreate :: MonadTCError m => Doc -> Closure (Abs Type) -> m a
cannotCreate Doc
doc Closure (Abs Type)
t = do
TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m a)
-> (SplitError -> TypeError) -> SplitError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SplitError -> TypeError
SplitError (SplitError -> m a) -> SplitError -> m a
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 = [NamedArg DeBruijnPattern] -> [Elim]
patternsToElims ([NamedArg DeBruijnPattern] -> [Elim])
-> [NamedArg DeBruijnPattern] -> [Elim]
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
old_t = Maybe (Dom Type) -> Dom Type
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
getLevel a
t = do
s <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ a -> Sort
forall a. LensSort a => a -> Sort
getSort a
t
case s of
Type Level
l -> Term -> m Term
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Level -> Term
Level Level
l)
Sort
s -> do
String -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.cover.hcomp" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"getLevel, s = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort -> m Doc
prettyTCM Sort
s
TypeError -> m Term
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m Term) -> (Doc -> TypeError) -> Doc -> m Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> m Term) -> m Doc -> m Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"The sort of" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
t m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"should be of the form \"Set l\"")
(gamma,hdelta@(ExtendTel hdom delta)) = splitTelescopeAt (size old_tel - (blockingVarNo x + 1)) old_tel
(working_tel,_deltaEx) = splitTelescopeAt (size gamma + 3 + size delta) tel
vs = [NamedArg SplitPattern] -> [Int]
forall p. IApplyVars p => p -> [Int]
iApplyVars (SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc)
alphab <- forM vs $ \ Int
i -> do
let
tm :: Term
tm = QName -> [Elim] -> Term
Def QName
f [Elim]
old_ps
(l,r) <- (Term, Term) -> TCMT IO (Term, Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
i Term
iz Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm, Int -> Term -> Substitution' Term
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
i Term
io Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm)
return $ (var i, (l, r))
cl <- do
(ty,rhs) <- addContext working_tel $ do
runNamesT [] $ do
tPOr <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr
tIMax <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMax
tIMin <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinIMin
tINeg <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinINeg
tHComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinHComp
tTrans <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinTrans
extra_ps <- open $ patternsToElims $ fromSplitPatterns $ drop (length old_ps) ps
let
ineg NamesT (TCMT IO) Term
j = Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j
imax NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
j = Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j
trFillTel' t (TCMT IO) (Abs Telescope)
a t (TCMT IO) Term
b t (TCMT IO) Args
c t (TCMT IO) Term
d = do
m <- Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) Args
trFillTel (Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> t (TCMT IO) (Abs Telescope)
-> t (TCMT IO)
(Term
-> Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t (TCMT IO) (Abs Telescope)
a t (TCMT IO)
(Term
-> Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> t (TCMT IO) Term
-> t (TCMT IO)
(Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall a b. t (TCMT IO) (a -> b) -> t (TCMT IO) a -> t (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t (TCMT IO) Term
b t (TCMT IO)
(Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> t (TCMT IO) Args
-> t (TCMT IO)
(Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall a b. t (TCMT IO) (a -> b) -> t (TCMT IO) a -> t (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t (TCMT IO) Args
c t (TCMT IO) (Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> t (TCMT IO) Term
-> t (TCMT IO) (ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall a b. t (TCMT IO) (a -> b) -> t (TCMT IO) a -> t (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t (TCMT IO) Term
d
x <- lift $ runExceptT m
case x of
Left Closure (Abs Type)
bad_t -> Doc -> Closure (Abs Type) -> t (TCMT IO) Args
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 -> Args -> t (TCMT IO) Args
forall a. a -> t (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Args
args
comp <- mkCompLazy "hcompClause"
let
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 = Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
la NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
bA
NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
phi
NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u
NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u0
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
(Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i))
(String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j -> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
la NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i) NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j) NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o)
NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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
hcompS <- lift $ do
hdom <- pure $ raise 3 hdom
let
[phi,u,u0] = map (pure . var) [2,1,0]
htype = Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> (Dom Type -> Type) -> Dom Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Term) -> Dom Type -> Term
forall a b. (a -> b) -> a -> b
$ Dom Type
hdom
lvl = Type -> TCMT IO Term
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 -> TCMT IO Term) -> Type -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
hdom
hc <- pure tHComp <#> lvl <#> htype
<#> phi
<@> u
<@> u0
return $ liftS (size delta) $ hc `consS` raiseS 3
hdom <- pure $ raise (3 + size delta) hdom
htype <- open $ unEl . unDom $ hdom
lvl <- open =<< (lift . getLevel $ unDom hdom)
[phi,u,u0] <- mapM (open . raise (size delta) . var) [2,1,0]
g <- open $ raise (3 + size delta) $ abstract hdelta (Def f old_ps)
old_t <- open $ raise (3 + size delta) $ abstract hdelta (unDom old_t)
let bapp f (Abs b)
a f (SubstArg b)
x = Abs b -> SubstArg b -> b
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs b -> SubstArg b -> b) -> f (Abs b) -> f (SubstArg b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Abs b)
a f (SubstArg b -> b) -> f (SubstArg b) -> f b
forall a b. f (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (SubstArg b)
x
(delta_fill :: NamesT TCM (Abs Args)) <- (open =<<) $ do
delta <- open $ raise (3 + size delta) delta
deltaf <- open =<< bind "i" (\ Var (TCMT IO)
i ->
(NamesT (TCMT IO) (Abs Telescope)
delta NamesT (TCMT IO) (Abs Telescope)
-> NamesT (TCMT IO) (SubstArg Telescope)
-> NamesT (TCMT IO) Telescope
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 NamesT (TCMT IO) Term
Var (TCMT IO)
i)))
args <- (open =<<) $ teleArgs <$> (lazyAbsApp <$> deltaf <*> pure iz)
bind "i" $ \ Var (TCMT IO)
i -> String -> NamesT (TCMT IO) Args -> NamesT (TCMT IO) Args
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a. MonadAddContext m => String -> m a -> m a
addContext (String
"i" :: String) (NamesT (TCMT IO) Args -> NamesT (TCMT IO) Args)
-> NamesT (TCMT IO) Args -> NamesT (TCMT IO) Args
forall a b. (a -> b) -> a -> b
$ do
NamesT (TCMT IO) (Abs Telescope)
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Args
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 (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
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 NamesT (TCMT IO) Term
Var (TCMT IO)
i)
let
apply_delta_fill NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
f = Term -> Args -> Term
forall t. Apply t => t -> Args -> t
apply (Term -> Args -> Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Args -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
f NamesT (TCMT IO) (Args -> Term)
-> NamesT (TCMT IO) Args -> NamesT (TCMT IO) Term
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (NamesT (TCMT IO) (Abs Args)
delta_fill NamesT (TCMT IO) (Abs Args)
-> NamesT (TCMT IO) (SubstArg Args) -> NamesT (TCMT IO) Args
forall {f :: * -> *} {b}.
(Applicative f, Subst b) =>
f (Abs b) -> f (SubstArg b) -> f b
`bapp` NamesT (TCMT IO) Term
NamesT (TCMT IO) (SubstArg Args)
i)
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 (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
g NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
v
ty <- do
return $ \ NamesT (TCMT IO) Term
i -> do
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
hd <- old_t
args <- delta_fill `bapp` i
lift $ piApplyM hd $ Arg (domInfo hdom) v : args
ty_level <- do
t <- bind "i" $ \ Var (TCMT IO)
x -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
ty NamesT (TCMT IO) Term
Var (TCMT IO)
x
s <- reduce $ getSort (absBody t)
reportSDoc "tc.cover.hcomp" 20 $ text "ty_level, s = " <+> prettyTCM s
case s of
Type Level
l -> Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (\ NamesT (TCMT IO) Term
_ -> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT (TCMT IO) Term) -> Term -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ Level -> Term
Level Level
l)
Sort
_ -> do cl <- TCM (Closure (Abs Type)) -> NamesT (TCMT IO) (Closure (Abs Type))
forall a. TCM a -> NamesT (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (Abs Type -> TCM (Closure (Abs Type))
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Abs Type
t)
liftTCM (cannotCreate "Cannot compose with type family:" cl)
let
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 = Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT (TCMT IO) Term
ty_level NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i)
NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
psi
NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT (TCMT IO) Term
_ -> Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Term
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) NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u0 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u1
alpha <- do
vars <- mapM (open . applySubst hcompS . fst) alphab
return $ foldr (imax . (\ 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)) (pure iz) vars
b <- do
sides <- forM alphab $ \ (Term
psi,(Term
side0,Term
side1)) -> do
psi <- Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall a b. (a -> b) -> a -> b
$ Substitution' Term
Substitution' (SubstArg Term)
hcompS Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
psi
[side0, side1] <- mapM (open . raise (3 + size delta) . abstract hdelta) [side0, side1]
return $ (ineg psi `imax` 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 (String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
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 (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
side0 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
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)
(String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
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 (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
side1 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
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
i = NamesT (TCMT IO) Term
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 (((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,
NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)]
-> NamesT (TCMT IO) Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
imax (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)
-> (NamesT (TCMT IO) Term,
NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamesT (TCMT IO) Term,
NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a, b) -> a
fst) (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
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)
return $ recurse sides
((,) <$> ty (pure io) <*>) $ do
comp ty_level
(lam "i" $ fmap unEl . ty)
(phi `imax` alpha)
(lam "i" $ \ NamesT (TCMT IO) Term
i ->
let rhs :: NamesT (TCMT IO) Term
rhs = (String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) 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)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
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 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o) NamesT (TCMT IO) Term
i)
in if [(Term, (Term, Term))] -> Bool
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)
)
(call u0 (pure iz))
reportSDoc "tc.cover.hcomp" 20 $ text "old_tel =" <+> prettyTCM tel
let n = Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
tel Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
3 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Abs Telescope -> Int
forall a. Sized a => a -> Int
size Abs Telescope
delta)
reportSDoc "tc.cover.hcomp" 20 $ text "n =" <+> text (show n)
(TelV deltaEx t,bs) <- telViewUpToPathBoundary' n ty
rhs <- pure $ raise n rhs `applyE` teleElims deltaEx bs
cxt <- getContextTelescope
reportSDoc "tc.cover.hcomp" 30 $ text "cxt = " <+> prettyTCM cxt
reportSDoc "tc.cover.hcomp" 30 $ text "tel = " <+> prettyTCM tel
reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "t = " <+> prettyTCM t
reportSDoc "tc.cover.hcomp" 20 $ addContext tel $ text "rhs = " <+> prettyTCM rhs
return $ Clause { clauseLHSRange = noRange
, clauseFullRange = noRange
, clauseTel = tel
, namedClausePats = fromSplitPatterns ps
, clauseBody = Just $ rhs
, clauseType = Just $ defaultArg t
, clauseCatchall = False
, clauseExact = Just True
, clauseRecursive = Nothing
, clauseUnreachable = Just False
, clauseEllipsis = NoEllipsis
, clauseWhereModule = Nothing
}
addClauses f [cl]
let result = CoverResult
{ coverSplitTree :: SplitTree' SplitTag
coverSplitTree = Int -> SplitTree' SplitTag
forall a. Int -> SplitTree' a
SplittingDone (Telescope -> Int
forall a. Sized a => a -> Int
size (Clause -> Telescope
clauseTel Clause
cl))
, coverUsedClauses :: IntSet
coverUsedClauses = Int -> IntSet
IntSet.singleton ([Clause] -> Int
forall a. [a] -> Int
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
}
hcompName <- fromMaybe __IMPOSSIBLE__ <$> getName' builtinHComp
return ([(SplitCon hcompName, result)], cs ++ [cl])
createMissingHCompClause QName
_ Arg Int
_ BlockingVar
_ SplitClause
_ (SClause Telescope
_ [NamedArg SplitPattern]
_ Substitution' SplitPattern
_ Map CheckpointId (Substitution' Term)
_ Maybe (Dom Type)
Nothing) [Clause]
_ = TCM ([(SplitTag, CoverResult)], [Clause])
forall a. HasCallStack => a
__IMPOSSIBLE__