{-# LANGUAGE NondecreasingIndentation #-}

module Agda.TypeChecking.Rules.Data where

import Prelude hiding (null, not, (&&), (||) )

import Control.Monad.Except ( MonadError(..), ExceptT(..), runExceptT )
import Control.Monad.Trans.Maybe
import Control.Exception as E

import Data.Set (Set)
import qualified Data.Set as Set

import Agda.Interaction.Options.Base

import qualified Agda.Syntax.Abstract as A
import qualified Agda.Syntax.Concrete.Name as C
import Agda.Syntax.Abstract.Views (deepUnscope)
import Agda.Syntax.Internal
import Agda.Syntax.Internal.Pattern
import Agda.Syntax.Common
import qualified Agda.Syntax.Common.Pretty as P
import Agda.Syntax.Position
import qualified Agda.Syntax.Info as Info
import Agda.Syntax.Scope.Monad

import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Compile
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Conversion
import {-# SOURCE #-} Agda.TypeChecking.CheckInternal
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Generalize
import Agda.TypeChecking.Implicit
import Agda.TypeChecking.InstanceArguments
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.Names
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Positivity.Occurrence (Occurrence(StrictPos))
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Primitive hiding (Nat)
import Agda.TypeChecking.Free
import Agda.TypeChecking.Forcing
import Agda.TypeChecking.Irrelevance
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Warnings (warning)

import {-# SOURCE #-} Agda.TypeChecking.Rules.Term ( isType_ )

import Agda.Utils.Boolean
import Agda.Utils.Either
import Agda.Utils.Function (applyWhen)
import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.List1 (pattern (:|) )
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import qualified Agda.Utils.Set1 as Set1
import Agda.Utils.Size
import qualified Agda.Utils.VarSet as VarSet

import Agda.Utils.Impossible

---------------------------------------------------------------------------
-- * Datatypes
---------------------------------------------------------------------------

-- | Type check a datatype definition. Assumes that the type has already been
--   checked.
checkDataDef :: A.DefInfo -> QName -> PositivityCheck -> UniverseCheck -> A.DataDefParams -> [A.Constructor] -> TCM ()
checkDataDef :: DefInfo
-> QName
-> PositivityCheck
-> UniverseCheck
-> DataDefParams
-> [Constructor]
-> TCM ()
checkDataDef DefInfo
i QName
name PositivityCheck
pc UniverseCheck
uc (A.DataDefParams Set Name
gpars [LamBinding]
ps) [Constructor]
cs =
    Call -> TCM () -> TCM ()
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Range -> QName -> [LamBinding] -> [Constructor] -> Call
CheckDataDef (QName -> Range
forall a. HasRange a => a -> Range
getRange QName
name) QName
name [LamBinding]
ps [Constructor]
cs) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do

        -- Add the datatype module
        ModuleName -> TCM ()
addSection (QName -> ModuleName
qnameToMName QName
name)

        -- Look up the type of the datatype.
        def <- Definition -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, ReadTCState m) =>
Definition -> m Definition
instantiateDef (Definition -> TCMT IO Definition)
-> TCMT IO Definition -> TCMT IO Definition
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
name
        t   <- instantiateFull $ defType def
        let npars =
              case Definition -> Defn
theDef Definition
def of
                DataOrRecSig Int
n DataOrRecord' ()
IsData -> Int
n
                Defn
_ -> Int
forall a. HasCallStack => a
__IMPOSSIBLE__

        -- If the data type is erased, then hard compile-time mode is
        -- entered.
        setHardCompileTimeModeIfErased' def $ do

        -- Make sure the shape of the type is visible
        let unTelV (TelV Tele (Dom (Type'' Term Term))
tel Type'' Term Term
a) = Tele (Dom (Type'' Term Term))
-> Type'' Term Term -> Type'' Term Term
telePi Tele (Dom (Type'' Term Term))
tel Type'' Term Term
a
        t <- unTelV <$> telView t

        parNames <- getGeneralizedParameters gpars name

        -- Top level free vars
        freeVars <- getContextSize

        -- The parameters are in scope when checking the constructors.
        dataDef <- bindGeneralizedParameters parNames t $ \ Tele (Dom (Type'' Term Term))
gtel Type'' Term Term
t0 ->
                   Int
-> [LamBinding]
-> Type'' Term Term
-> (Tele (Dom (Type'' Term Term))
    -> Type'' Term Term -> TCM DatatypeData)
-> TCM DatatypeData
forall a.
Int
-> [LamBinding]
-> Type'' Term Term
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
bindParameters (Int
npars Int -> Int -> Int
forall a. Num a => a -> a -> a
- [Maybe Name] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Maybe Name]
parNames) [LamBinding]
ps Type'' Term Term
t0 ((Tele (Dom (Type'' Term Term))
  -> Type'' Term Term -> TCM DatatypeData)
 -> TCM DatatypeData)
-> (Tele (Dom (Type'' Term Term))
    -> Type'' Term Term -> TCM DatatypeData)
-> TCM DatatypeData
forall a b. (a -> b) -> a -> b
$ \ Tele (Dom (Type'' Term Term))
ptel Type'' Term Term
t0 -> do

            -- The type we get from bindParameters is Θ -> s where Θ is the type of
            -- the indices. We count the number of indices and return s.
            -- We check that s is a sort.
            let TelV Tele (Dom (Type'' Term Term))
ixTel Type'' Term Term
s0 = Type'' Term Term -> TelV (Type'' Term Term)
telView' Type'' Term Term
t0
                nofIxs :: Int
nofIxs = Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
ixTel

            s <- TCMT IO Sort -> TCMT IO Sort
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
workOnTypes (TCMT IO Sort -> TCMT IO Sort) -> TCMT IO Sort -> TCMT IO Sort
forall a b. (a -> b) -> a -> b
$ do
              -- Andreas, 2016-11-02 issue #2290
              -- Trying to unify the sort with a fresh sort meta which is
              -- defined outside the index telescope is the most robust way
              -- to check independence of the indices.
              -- However, it might give the dreaded "Cannot instantiate meta..."
              -- error which we replace by a more understandable error
              -- in case of a suspected dependency.
              s <- TCMT IO Sort
newSortMetaBelowInf
              catchError_ (addContext ixTel $ equalType s0 $ raise nofIxs $ sort s) $ \ TCErr
err ->
                  if (Int -> Bool) -> [Int] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Int -> Type'' Term Term -> Bool
forall t. Free t => Int -> t -> Bool
`freeIn` Type'' Term Term
s0) [Int
0..Int
nofIxs Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1] then TypeError -> TCM ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM ()) -> TypeError -> TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> Type'' Term Term -> TypeError
SortCannotDependOnItsIndex QName
name Type'' Term Term
t0
                  else TCErr -> TCM ()
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
              reduce s

            withK   <- not <$> withoutKOption
            erasure <- optErasure <$> pragmaOptions
            -- Parameters are always hidden in constructors. If
            -- --erasure is used, then the parameters are erased for
            -- non-indexed data types, and if --with-K is active this
            -- applies also to indexed data types.
            let tel  = Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
gtel Tele (Dom (Type'' Term Term))
ptel
                tel' = Bool
-> (Dom (Type'' Term Term) -> Dom (Type'' Term Term))
-> Dom (Type'' Term Term)
-> Dom (Type'' Term Term)
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen (Bool
erasure Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
&& (Bool
withK Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Int
nofIxs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)) (Quantity -> Dom (Type'' Term Term) -> Dom (Type'' Term Term)
forall a. LensQuantity a => Quantity -> a -> a
applyQuantity Quantity
zeroQuantity) (Dom (Type'' Term Term) -> Dom (Type'' Term Term))
-> (Dom (Type'' Term Term) -> Dom (Type'' Term Term))
-> Dom (Type'' Term Term)
-> Dom (Type'' Term Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       Dom (Type'' Term Term) -> Dom (Type'' Term Term)
forall a. (LensHiding a, LensRelevance a) => a -> a
hideAndRelParams (Dom (Type'' Term Term) -> Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                       Tele (Dom (Type'' Term Term))
tel

            reportSDoc "tc.data.sort" 20 $ vcat
              [ "checking datatype" <+> prettyTCM name
              , nest 2 $ vcat
                [ "type (parameters instantiated):   " <+> prettyTCM t0
                , "type (full):   " <+> prettyTCM t
                , "sort:   " <+> prettyTCM s
                , "indices:" <+> text (show nofIxs)
                , "gparams:" <+> text (show parNames)
                , "params: " <+> text (show $ deepUnscope ps)
                ]
              ]
            let npars = Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
tel

            -- Change the datatype from an axiom to a datatype with no constructors.
            let dataDef = DatatypeData
                  { _dataPars :: Int
_dataPars       = Int
npars
                  , _dataIxs :: Int
_dataIxs        = Int
nofIxs
                  , _dataClause :: Maybe Clause
_dataClause     = Maybe Clause
forall a. Maybe a
Nothing
                  , _dataCons :: [QName]
_dataCons       = []     -- Constructors are added later
                  , _dataSort :: Sort
_dataSort       = Sort
s
                  , _dataAbstr :: IsAbstract
_dataAbstr      = DefInfo -> IsAbstract
forall t. DefInfo' t -> IsAbstract
Info.defAbstract DefInfo
i
                  , _dataMutual :: Maybe [QName]
_dataMutual     = Maybe [QName]
forall a. Maybe a
Nothing
                  , _dataPositivityCheck :: PositivityCheck
_dataPositivityCheck = PositivityCheck
pc
                  , _dataPathCons :: [QName]
_dataPathCons   = []     -- Path constructors are added later
                  , _dataTranspIx :: Maybe QName
_dataTranspIx   = Maybe QName
forall a. Maybe a
Nothing -- Generated later if nofIxs > 0.
                  , _dataTransp :: Maybe QName
_dataTransp     = Maybe QName
forall a. Maybe a
Nothing -- Added later
                  }

            escapeContext impossible npars $ do
              addConstant' name defaultArgInfo t $ DatatypeDefn dataDef
                -- polarity and argOcc.s determined by the positivity checker

            -- Check the types of the constructors
            pathCons <- forM cs $ \ Constructor
c -> do
              isPathCons <- QName
-> UniverseCheck
-> Tele (Dom (Type'' Term Term))
-> Int
-> Sort
-> Constructor
-> TCM IsPathCons
checkConstructor QName
name UniverseCheck
uc Tele (Dom (Type'' Term Term))
tel' Int
nofIxs Sort
s Constructor
c
              return $ if isPathCons == PathCons then Just (A.axiomName c) else Nothing


            -- cubical: the interval universe does not contain datatypes
            -- similar: SizeUniv, ...
            checkDataSort name s

            -- when `--without-K`, all the indices should fit in the
            -- sort of the datatype (see #3420).
            -- Andreas, 2019-07-16, issue #3916:
            -- NoUniverseCheck should also disable the index sort check!
            unless (uc == NoUniverseCheck) $
              whenM withoutKOption $ do
                let s' = case Sort
s of
                      Prop Level' Term
l -> Level' Term -> Sort
forall t. Level' t -> Sort' t
Type Level' Term
l
                      Sort
_      -> Sort
s
                checkIndexSorts s' ixTel

            -- Return the data definition
            return dataDef{ _dataPathCons = catMaybes pathCons
                          }

        let cons   = (Constructor -> QName) -> [Constructor] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map' Constructor -> QName
A.axiomName [Constructor]
cs  -- get constructor names

        (mtranspix, transpFun) <-
          ifM cubicalCompatibleOption
            (inTopContext $ do
              checkNoLocalRewrites name
              mtranspix <- defineTranspIx name
              transpFun <- defineTranspFun name mtranspix cons $
                           _dataPathCons dataDef
              return (mtranspix, transpFun))
            (return (Nothing, Nothing))

        -- Add the datatype to the signature with its constructors.
        -- It was previously added without them.
        addConstant' name defaultArgInfo t $ DatatypeDefn
            dataDef{ _dataCons = cons
                   , _dataTranspIx = mtranspix
                   , _dataTransp   = transpFun
                   }

-- | Make sure that the target universe admits data type definitions.
--   E.g. @IUniv@, @SizeUniv@ etc. do not accept new constructions.
checkDataSort :: QName -> Sort -> TCM ()
checkDataSort :: QName -> Sort -> TCM ()
checkDataSort QName
name Sort
s = QName -> TCM () -> TCM ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
name (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
  Sort
-> (Blocker -> Sort -> TCM ())
-> (NotBlocked -> Sort -> TCM ())
-> TCM ()
forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked Sort
s Blocker -> Sort -> TCM ()
postpone {-else-} ((NotBlocked -> Sort -> TCM ()) -> TCM ())
-> (NotBlocked -> Sort -> TCM ()) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \ NotBlocked
_ (Sort
s :: Sort) -> do
    let
      yes :: TCM ()
      yes :: TCM ()
yes = () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      no  :: TCM ()
      no :: TCM ()
no  = TypeError -> TCM ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM ()) -> TypeError -> TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> Sort -> TypeError
SortDoesNotAdmitDataDefinitions QName
name Sort
s
    case Sort
s of
      -- Sorts that admit data definitions.
      Univ Univ
_ Level' Term
_     -> TCM ()
yes
      Inf Univ
_ Integer
_      -> TCM ()
yes
      DefS QName
_ [Elim' Term]
_     -> TCM ()
yes
      -- Sorts that do not admit data definitions.
      Sort
SizeUniv     -> TCM ()
no
      Sort
LockUniv     -> TCM ()
no
      Sort
LevelUniv    -> TCM ()
no
      Sort
IntervalUniv -> TCM ()
no
      -- Blocked sorts.
      PiSort Dom' Term Term
_ Sort
_ Abs Sort
_ -> TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      FunSort Sort
_ Sort
_  -> TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      UnivSort Sort
_   -> TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      MetaS MetaId
_ [Elim' Term]
_    -> TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      DummyS [Char]
_     -> TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__
  where
    postpone :: Blocker -> Sort -> TCM ()
    postpone :: Blocker -> Sort -> TCM ()
postpone Blocker
b Sort
s = Blocker -> Constraint -> TCM ()
forall (m :: * -> *).
MonadConstraint m =>
Blocker -> Constraint -> m ()
addConstraint Blocker
b (Constraint -> TCM ()) -> Constraint -> TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> Sort -> Constraint
CheckDataSort QName
name Sort
s

-- | Ensure that the type is a sort.
--   If it is not directly a sort, compare it to a 'newSortMetaBelowInf'.
forceSort :: Type -> TCM Sort
forceSort :: Type'' Term Term -> TCMT IO Sort
forceSort Type'' Term Term
t = Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
t) TCMT IO Term -> (Term -> TCMT IO Sort) -> TCMT IO Sort
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  Sort Sort
s -> Sort -> TCMT IO Sort
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort
s
  Term
_      -> do
    s <- TCMT IO Sort
newSortMetaBelowInf
    equalType t (sort s)
    return s

-- | Type check a constructor declaration. Checks that the constructor targets
--   the datatype and that it fits inside the declared sort.
--   Returns the non-linear parameters.
checkConstructor
  :: QName         -- ^ Name of data type.
  -> UniverseCheck -- ^ Check universes?
  -> Telescope     -- ^ Parameter telescope.
  -> Nat           -- ^ Number of indices of the data type.
  -> Sort          -- ^ Sort of the data type.
  -> A.Constructor -- ^ Constructor declaration (type signature).
  -> TCM IsPathCons
checkConstructor :: QName
-> UniverseCheck
-> Tele (Dom (Type'' Term Term))
-> Int
-> Sort
-> Constructor
-> TCM IsPathCons
checkConstructor QName
d UniverseCheck
uc Tele (Dom (Type'' Term Term))
tel Int
nofIxs Sort
s (A.ScopedDecl ScopeInfo
scope (Constructor
con :| [])) = do
  ScopeInfo -> TCM ()
setScope ScopeInfo
scope
  QName
-> UniverseCheck
-> Tele (Dom (Type'' Term Term))
-> Int
-> Sort
-> Constructor
-> TCM IsPathCons
checkConstructor QName
d UniverseCheck
uc Tele (Dom (Type'' Term Term))
tel Int
nofIxs Sort
s Constructor
con
checkConstructor QName
d UniverseCheck
uc Tele (Dom (Type'' Term Term))
tel Int
nofIxs Sort
s con :: Constructor
con@(A.Axiom KindOfName
_ DefInfo
i ArgInfo
ai Maybe PragmaPolarities
Nothing QName
c Expr
e) =
    Call -> TCM IsPathCons -> TCM IsPathCons
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (QName
-> Tele (Dom (Type'' Term Term)) -> Sort -> Constructor -> Call
CheckConstructor QName
d Tele (Dom (Type'' Term Term))
tel Sort
s Constructor
con) (TCM IsPathCons -> TCM IsPathCons)
-> TCM IsPathCons -> TCM IsPathCons
forall a b. (a -> b) -> a -> b
$ do
{- WRONG
      -- Andreas, 2011-04-26: the following happens to the right of ':'
      -- we may use irrelevant arguments in a non-strict way in types
      t' <- workOnTypes $ do
-}
        QName -> Expr -> TCM ()
forall {m :: * -> *} {a} {a}.
(MonadDebug m, PrettyTCM a, PrettyTCM a) =>
a -> a -> m ()
debugEnter QName
c Expr
e
        -- Remember that we are of a suitable modality.
        Bool -> TCM () -> TCM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (ArgInfo -> Bool
forall a. LensRelevance a => a -> Bool
isRelevant ArgInfo
ai) TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__
        Bool -> TCM () -> TCM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless ((ArgInfo -> Bool
forall a. LensQuantity a => a -> Bool
isQuantityω (ArgInfo -> Bool) -> (ArgInfo -> Bool) -> ArgInfo -> Bool
forall a. Boolean a => a -> a -> a
|| ArgInfo -> Bool
forall a. LensQuantity a => a -> Bool
isQuantity0) ArgInfo
ai) TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__

        -- If the constructor is erased, then hard compile-time mode
        -- is entered.
        ArgInfo -> TCM IsPathCons -> TCM IsPathCons
forall q a. LensQuantity q => q -> TCM a -> TCM a
setHardCompileTimeModeIfErased' ArgInfo
ai (TCM IsPathCons -> TCM IsPathCons)
-> TCM IsPathCons -> TCM IsPathCons
forall a b. (a -> b) -> a -> b
$ do

        -- check that the type of the constructor is well-formed
        (t, isPathCons) <- Expr -> QName -> TCMT IO (Type'' Term Term, IsPathCons)
checkConstructorType Expr
e QName
d

        -- compute which constructor arguments are forced (only point constructors)
        forcedArgs <- if isPathCons == PointCons
                      then computeForcingAnnotations c t
                      else return []
        -- check that the sort (universe level) of the constructor type
        -- is contained in the sort of the data type
        -- (to avoid impredicative existential types)
        debugFitsIn s
        arity <- applyQuantityToJudgement ai $
          fitsIn IsData c uc forcedArgs t s
        -- this may have instantiated some metas in s, so we reduce
        s <- reduce s
        debugAdd c t

        (TelV fields _, boundary) <- telViewPathBoundary t

        -- We assume that the current context matches the parameters
        -- of the datatype in an empty context (c.f. getContextSize above).
        params <- getContextTelescope

        (con, comp, projNames) <- do
            -- Name for projection of ith field of constructor c is just c-i
            names <- forM [0 .. size fields - 1] $ \ Int
i ->
              [Char] -> TCMT IO QName
freshAbstractQName'_ ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ Name -> [Char]
forall a. Pretty a => a -> [Char]
P.prettyShow (QName -> Name
A.qnameName QName
c) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i

            -- nofIxs == 0 means the data type can be reconstructed
            -- by appling the QName d to the parameters.
            let dataT = Sort -> Term -> Type'' Term Term
forall t a. Sort' t -> a -> Type'' t a
El Sort
s (Term -> Type'' Term Term) -> Term -> Type'' Term Term
forall a b. (a -> b) -> a -> b
$ QName -> [Elim' Term] -> Term
Def QName
d ([Elim' Term] -> Term) -> [Elim' Term] -> Term
forall a b. (a -> b) -> a -> b
$ (Arg Term -> Elim' Term) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply ([Arg Term] -> [Elim' Term]) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> [Arg Term]
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom (Type'' Term Term))
params

            reportSDoc "tc.data.con.comp" 5 $ inTopContext $ vcat $
              [ "params =" <+> pretty params
              , "dataT  =" <+> pretty dataT
              , "fields =" <+> pretty fields
              , "names  =" <+> pretty names
              ]

            let con = QName -> DataOrRecord -> Induction -> [Arg QName] -> ConHead
ConHead QName
c DataOrRecord
forall p. DataOrRecord' p
IsData Induction
Inductive ([Arg QName] -> ConHead) -> [Arg QName] -> ConHead
forall a b. (a -> b) -> a -> b
$ (QName -> Arg ([Char], Type'' Term Term) -> Arg QName)
-> [QName] -> [Arg ([Char], Type'' Term Term)] -> [Arg QName]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' QName -> Arg ([Char], Type'' Term Term) -> Arg QName
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
(<$) [QName]
names ([Arg ([Char], Type'' Term Term)] -> [Arg QName])
-> [Arg ([Char], Type'' Term Term)] -> [Arg QName]
forall a b. (a -> b) -> a -> b
$ (Dom' Term ([Char], Type'' Term Term)
 -> Arg ([Char], Type'' Term Term))
-> [Dom' Term ([Char], Type'' Term Term)]
-> [Arg ([Char], Type'' Term Term)]
forall a b. (a -> b) -> [a] -> [b]
map' Dom' Term ([Char], Type'' Term Term)
-> Arg ([Char], Type'' Term Term)
forall t a. Dom' t a -> Arg a
argFromDom ([Dom' Term ([Char], Type'' Term Term)]
 -> [Arg ([Char], Type'' Term Term)])
-> [Dom' Term ([Char], Type'' Term Term)]
-> [Arg ([Char], Type'' Term Term)]
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term))
-> [Dom' Term ([Char], Type'' Term Term)]
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Tele (Dom (Type'' Term Term))
fields

            defineProjections d con params names fields dataT
            -- Andreas, 2024-01-05 issue #7048:
            -- Only define hcomp when --cubical=compatible.
            cubicalCompatible <- cubicalCompatibleOption
            -- Cannot compose indexed inductive types yet.
            comp <- if cubicalCompatible && nofIxs == 0 && Info.defAbstract i == ConcreteDef
                    then inTopContext $ defineCompData d con params names fields dataT boundary
                    else return emptyCompKit
            return (con, comp, Just names)

        -- add parameters to constructor type and put into signature
        escapeContext impossible (size tel) $ do
          erasure <- optErasure <$> pragmaOptions
          addConstant' c ai (telePi tel t) $ Constructor
              { conPars   = size tel
              , conArity  = arity
              , conSrcCon = con
              , conData   = d
              , conAbstr  = Info.defAbstract i
              , conComp   = comp
              , conProj   = projNames
              , conForced = forcedArgs
              , conErased = Nothing  -- computed during compilation to treeless
              , conErasure = erasure
              , conInline  = False
              }

        -- Add the constructor to the instance table, if needed
        case Info.defInstance i of
          InstanceDef KwRange
kwr -> QName -> TCM () -> TCM ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
c (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
            -- Including the range of the @instance@ keyword, like
            -- @(getRange (r,c))@, does not produce good results.
            -- Andreas, 2020-01-28, issue #4360:
            -- Use addTypedInstance instead of addNamedInstance
            -- to detect unusable instances.
            KwRange -> QName -> Type'' Term Term -> TCM ()
addTypedInstance KwRange
kwr QName
c Type'' Term Term
t
            -- addNamedInstance c d
          IsInstance
NotInstanceDef -> () -> TCM ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

        return isPathCons

  where
    -- Issue 3362: we need to do the `constructs` call inside the
    -- generalization, so unpack the A.Generalize
    checkConstructorType :: Expr -> QName -> TCMT IO (Type'' Term Term, IsPathCons)
checkConstructorType (A.ScopedExpr ScopeInfo
s Expr
e) QName
d = ScopeInfo
-> TCMT IO (Type'' Term Term, IsPathCons)
-> TCMT IO (Type'' Term Term, IsPathCons)
forall (m :: * -> *) a. ReadTCState m => ScopeInfo -> m a -> m a
evalWithScope ScopeInfo
s (TCMT IO (Type'' Term Term, IsPathCons)
 -> TCMT IO (Type'' Term Term, IsPathCons))
-> TCMT IO (Type'' Term Term, IsPathCons)
-> TCMT IO (Type'' Term Term, IsPathCons)
forall a b. (a -> b) -> a -> b
$ Expr -> QName -> TCMT IO (Type'' Term Term, IsPathCons)
checkConstructorType Expr
e QName
d
    checkConstructorType Expr
e QName
d = do
      let check :: Int -> Expr -> TCMT IO (Type'' Term Term, IsPathCons)
check Int
k Expr
e = do
            t <- TCMT IO (Type'' Term Term) -> TCMT IO (Type'' Term Term)
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
workOnTypes (TCMT IO (Type'' Term Term) -> TCMT IO (Type'' Term Term))
-> TCMT IO (Type'' Term Term) -> TCMT IO (Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ Expr -> TCMT IO (Type'' Term Term)
isType_ Expr
e
            -- check that the type of the constructor ends in the data type
            n <- getContextSize
            debugEndsIn t d (n - k)
            isPathCons <- constructs (n - k) k t d
            return (t, isPathCons)

      case Expr
e of
        A.Generalized Set1 QName
s Expr
e -> do
          (_, t, isPathCons) <- Set QName
-> TCMT IO (Type'' Term Term, IsPathCons)
-> TCM ([Maybe QName], Type'' Term Term, IsPathCons)
forall a.
Set QName
-> TCM (Type'' Term Term, a)
-> TCM ([Maybe QName], Type'' Term Term, a)
generalizeType' (Set1 QName -> Set QName
forall a. NESet a -> Set a
Set1.toSet Set1 QName
s) (Int -> Expr -> TCMT IO (Type'' Term Term, IsPathCons)
check Int
1 Expr
e)
          return (t, isPathCons)
        Expr
_ -> Int -> Expr -> TCMT IO (Type'' Term Term, IsPathCons)
check Int
0 Expr
e

    debugEnter :: a -> a -> m ()
debugEnter a
c a
e =
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.con" Int
5 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
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
"checking constructor" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
c TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
":" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
e
        ]
    debugEndsIn :: a -> a -> a -> m ()
debugEndsIn a
t a
d a
n =
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.con" Int
15 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
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
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"checking that"
              , 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
$ a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
t
              , TCMT IO Doc
"ends in" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
d
              ]
        , 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
"nofPars =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text (a -> [Char]
forall a. Show a => a -> [Char]
show a
n)
        ]
    debugFitsIn :: a -> m ()
debugFitsIn a
s =
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.con" Int
15 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ TCMT IO Doc
"checking that the type fits in"
        , 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
$ a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
s
        ]
    debugAdd :: a -> a -> m ()
debugAdd a
c a
t =
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.con" Int
5 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
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
"adding constructor" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
c TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
":" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
t
        ]
checkConstructor QName
_ UniverseCheck
_ Tele (Dom (Type'' Term Term))
_ Int
_ Sort
_ Constructor
_ = TCM IsPathCons
forall a. HasCallStack => a
__IMPOSSIBLE__ -- constructors are axioms

defineCompData ::
     QName         -- ^ Datatype name.
  -> ConHead       -- ^ Constructor.
  -> Telescope     -- ^ @Γ@ parameters.
  -> [QName]       -- ^ Projection names.
  -> Telescope     -- ^ @Γ ⊢ Φ@ field types.
  -> Type          -- ^ @Γ ⊢ T@ target type.
  -> Boundary      -- ^ @[(i,t_i,b_i)],  Γ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : B_i@
  -> TCM CompKit
defineCompData :: QName
-> ConHead
-> Tele (Dom (Type'' Term Term))
-> [QName]
-> Tele (Dom (Type'' Term Term))
-> Type'' Term Term
-> Boundary' Int Term
-> TCMT IO CompKit
defineCompData QName
d ConHead
con Tele (Dom (Type'' Term Term))
params [QName]
names Tele (Dom (Type'' Term Term))
fsT Type'' Term Term
t Boundary' Int Term
boundary = do
  required <- (SomeBuiltin -> TCMT IO (Maybe Term))
-> [SomeBuiltin] -> TCMT IO [Maybe 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 SomeBuiltin -> TCMT IO (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm'
    [ BuiltinId -> SomeBuiltin
forall a. IsBuiltin a => a -> SomeBuiltin
someBuiltin BuiltinId
builtinInterval
    , BuiltinId -> SomeBuiltin
forall a. IsBuiltin a => a -> SomeBuiltin
someBuiltin BuiltinId
builtinIZero
    , BuiltinId -> SomeBuiltin
forall a. IsBuiltin a => a -> SomeBuiltin
someBuiltin BuiltinId
builtinIOne
    , PrimitiveId -> SomeBuiltin
forall a. IsBuiltin a => a -> SomeBuiltin
someBuiltin PrimitiveId
builtinIMin
    , PrimitiveId -> SomeBuiltin
forall a. IsBuiltin a => a -> SomeBuiltin
someBuiltin PrimitiveId
builtinIMax
    , PrimitiveId -> SomeBuiltin
forall a. IsBuiltin a => a -> SomeBuiltin
someBuiltin PrimitiveId
builtinINeg
    , PrimitiveId -> SomeBuiltin
forall a. IsBuiltin a => a -> SomeBuiltin
someBuiltin PrimitiveId
builtinPOr
    , BuiltinId -> SomeBuiltin
forall a. IsBuiltin a => a -> SomeBuiltin
someBuiltin BuiltinId
builtinItIsOne
    ]
  if not (all isJust required) then return $ emptyCompKit else do
    checkNoLocalRewrites' d params
    hcomp  <- whenDefined (null boundary) [builtinHComp,builtinTrans]
      (defineKanOperationD DoHComp  d con params names fsT t boundary)
    transp <- whenDefined True            [builtinTrans]
      (defineKanOperationD DoTransp d con params names fsT t boundary)
    return $ CompKit
      { nameOfTransp = transp
      , nameOfHComp  = hcomp
      }
  where
    -- Δ^I, i : I |- sub Δ : Δ
    sub :: a -> Substitution' Term
sub a
tel = [ Int -> Term
var Int
n Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Int -> Term
var Int
0] | Int
n <- [Int
1..a -> Int
forall a. Sized a => a -> Int
size a
tel] ] [Term] -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Impossible -> Substitution' Term
forall a. Impossible -> Substitution' a
EmptyS Impossible
forall a. HasCallStack => a
__IMPOSSIBLE__
    withArgInfo :: Tele (Dom t) -> [e] -> [Arg e]
withArgInfo Tele (Dom t)
tel = (ArgInfo -> e -> Arg e) -> [ArgInfo] -> [e] -> [Arg e]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' ArgInfo -> e -> Arg e
forall e. ArgInfo -> e -> Arg e
Arg ((Dom' Term ([Char], t) -> ArgInfo)
-> [Dom' Term ([Char], t)] -> [ArgInfo]
forall a b. (a -> b) -> [a] -> [b]
map' Dom' Term ([Char], t) -> ArgInfo
forall t e. Dom' t e -> ArgInfo
domInfo ([Dom' Term ([Char], t)] -> [ArgInfo])
-> (Tele (Dom t) -> [Dom' Term ([Char], t)])
-> Tele (Dom t)
-> [ArgInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tele (Dom t) -> [Dom' Term ([Char], t)]
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList (Tele (Dom t) -> [ArgInfo]) -> Tele (Dom t) -> [ArgInfo]
forall a b. (a -> b) -> a -> b
$ Tele (Dom t)
tel)

    defineKanOperationD :: Command
-> QName
-> ConHead
-> Tele (Dom (Type'' Term Term))
-> [QName]
-> Tele (Dom (Type'' Term Term))
-> Type'' Term Term
-> Boundary' Int Term
-> TCMT IO (Maybe QName)
defineKanOperationD Command
cmd QName
d ConHead
con Tele (Dom (Type'' Term Term))
params [QName]
names Tele (Dom (Type'' Term Term))
fsT Type'' Term Term
t Boundary' Int Term
boundary = do
      let project :: Term -> QName -> Term
project = (\ Term
t QName
p -> Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply (QName -> [Elim' Term] -> Term
Def QName
p []) [Term -> Arg Term
forall e. e -> Arg e
argN Term
t])
      stuff <- Command
-> Maybe Term
-> (Term -> QName -> Term)
-> QName
-> Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term))
-> [Arg QName]
-> Type'' Term Term
-> TCM
     (Maybe
        ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
          [Dom (Type'' Term Term)], [Term]),
         Substitution' Term))
defineKanOperationForFields Command
cmd
                 (Bool -> Maybe ()
forall b (m :: * -> *). (IsBool b, MonadPlus m) => b -> m ()
guard (Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Boundary' Int Term -> Bool
forall a. Null a => a -> Bool
null Boundary' Int Term
boundary) Maybe () -> Maybe Term -> Maybe Term
forall a b. Maybe a -> Maybe b -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Term -> Maybe Term
forall a. a -> Maybe a
Just (ConHead -> ConInfo -> [Elim' Term] -> Term
Con ConHead
con ConInfo
ConOSystem ([Elim' Term] -> Term) -> [Elim' Term] -> Term
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> Boundary' Int Term -> [Elim' Term]
forall a.
DeBruijn a =>
Tele (Dom (Type'' Term Term)) -> Boundary' Int a -> [Elim' a]
teleElims Tele (Dom (Type'' Term Term))
fsT Boundary' Int Term
boundary))
                 Term -> QName -> Term
project QName
d Tele (Dom (Type'' Term Term))
params Tele (Dom (Type'' Term Term))
fsT ((QName -> Arg QName) -> [QName] -> [Arg QName]
forall a b. (a -> b) -> [a] -> [b]
map' QName -> Arg QName
forall e. e -> Arg e
argN [QName]
names) Type'' Term Term
t
      caseMaybe stuff (return Nothing) $ \ ((QName
theName, Tele (Dom (Type'' Term Term))
gamma , Type'' Term Term
ty, [Dom (Type'' Term Term)]
_cl_types , [Term]
bodies), Substitution' Term
theSub) -> do

      iz <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
      body <- do
        case cmd of
          Command
DoHComp -> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ ConHead -> ConInfo -> [Elim' Term] -> Term
Con ConHead
con ConInfo
ConOSystem ((Arg Term -> Elim' Term) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply ([Arg Term] -> [Elim' Term]) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> [Term] -> [Arg Term]
forall {t} {e}. Tele (Dom t) -> [e] -> [Arg e]
withArgInfo Tele (Dom (Type'' Term Term))
fsT [Term]
bodies)
          Command
DoTransp | Boundary' Int Term -> Bool
forall a. Null a => a -> Bool
null Boundary' Int Term
boundary {- && null ixs -} -> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ ConHead -> ConInfo -> [Elim' Term] -> Term
Con ConHead
con ConInfo
ConOSystem ((Arg Term -> Elim' Term) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply ([Arg Term] -> [Elim' Term]) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> [Term] -> [Arg Term]
forall {t} {e}. Tele (Dom t) -> [e] -> [Arg e]
withArgInfo Tele (Dom (Type'' Term Term))
fsT [Term]
bodies)
                   | Bool
otherwise -> do
            io <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
            tIMax <- primIMax
            tIMin <- primIMin
            tINeg <- primINeg
            tPOr  <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinPOr
            tHComp <- primHComp
            -- Δ = params
            -- Δ ⊢ Φ = fsT
            -- (δ : Δ) ⊢ T = R δ
            -- (δ : Δ) ⊢ con : Φ → R δ  -- no indexing
            -- boundary = [(i,t_i,u_i)]
            -- Δ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : B_i
            -- Δ.Φ | PiPath Φ boundary (R δ) |- teleElims fsT boundary : R δ
            -- Γ = ((δ : Δ^I), φ, us : Φ[δ 0]) = gamma
            -- Γ ⊢ ty = R (δ i1)
            -- (γ : Γ) ⊢ cl_types = (flatten Φ)[n ↦ f_n (transpR γ)]
            -- Γ ⊢ bodies : Φ[δ i1]
            -- Γ ⊢ t : ty
            -- Γ, i : I ⊢ theSub : Δ.Φ
            let

              -- Δ.Φ ⊢ u = Con con ConOSystem $ teleElims fsT boundary : R δ
              u = ConHead -> ConInfo -> [Elim' Term] -> Term
Con ConHead
con ConInfo
ConOSystem ([Elim' Term] -> Term) -> [Elim' Term] -> Term
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> Boundary' Int Term -> [Elim' Term]
forall a.
DeBruijn a =>
Tele (Dom (Type'' Term Term)) -> Boundary' Int a -> [Elim' a]
teleElims Tele (Dom (Type'' Term Term))
fsT Boundary' Int Term
boundary
              -- Γ ⊢ u
              the_u = Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
liftS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
fsT) Substitution' Term
d0 Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u
                where
                  -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ
                  d0 :: Substitution
                  d0 :: Substitution' Term
d0 = Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
wkS Int
1 -- Δ^I, φ : F ⊢ Δ
                             (Term -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
iz Substitution' Term
forall a. Substitution' a
IdS Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
params) -- Δ^I ⊢ Δ
                                       -- Δ^I , i:I ⊢ sub params : Δ
              the_phi = Int -> Term -> Term
forall a. Subst a => Int -> a -> a
raise (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
fsT) (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Int -> Term
var Int
0
              -- Γ ⊢ sigma : Δ.Φ
              -- sigma = [δ i1,bodies]
              -- sigma = theSub[i1]
              sigma = [Term] -> [Term]
forall a. [a] -> [a]
reverse [Term]
bodies [Term] -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Substitution' Term
d1
               where
                -- δ i1
                d1 :: Substitution
                d1 :: Substitution' Term
d1 = Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
wkS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
params) -- Γ ⊢ Δ
                       (Term -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
io Substitution' Term
forall a. Substitution' a
IdS Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
params) -- Δ^I ⊢ Δ
                                 -- Δ^I , i:I ⊢ sub params : Δ

              -- Δ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : R δ
              bs = Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> Boundary' Int Term
fullBoundary Tele (Dom (Type'' Term Term))
fsT Boundary' Int Term
boundary
              -- ψ = sigma `applySubst` map' (\ i → i ∨ ~ i) . map' fst $ boundary
              -- Γ ⊢ t : R (δ i1)
              w1' = ConHead -> ConInfo -> [Elim' Term] -> Term
Con ConHead
con ConInfo
ConOSystem ([Elim' Term] -> Term) -> [Elim' Term] -> Term
forall a b. (a -> b) -> a -> b
$ Substitution' Term
Substitution' (SubstArg [Elim' Term])
sigma Substitution' (SubstArg [Elim' Term])
-> [Elim' Term] -> [Elim' Term]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Tele (Dom (Type'' Term Term)) -> Boundary' Int Term -> [Elim' Term]
forall a.
DeBruijn a =>
Tele (Dom (Type'' Term Term)) -> Boundary' Int a -> [Elim' a]
teleElims Tele (Dom (Type'' Term Term))
fsT Boundary' Int Term
boundary
              -- (δ, φ, u0) : Γ ⊢
              -- w1 = hcomp (\ i → R (δ i1))
              --            (\ i → [ ψ ↦ α (~ i), φ ↦ u0])
              --            w1'
              imax NamesT (TCMT IO) Term
x NamesT (TCMT IO) Term
y = 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
x 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
y
              ineg NamesT (TCMT IO) Term
r = 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
r
              lvlOfType = (\ (Type Level' Term
l) -> Level' Term -> Term
Level Level' Term
l) (Sort -> Term)
-> (Type'' Term Term -> Sort) -> Type'' Term Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type'' Term Term -> Sort
forall a. LensSort a => a -> Sort
getSort
              pOr NamesT (TCMT IO) (Type'' Term Term)
la NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
j 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
<#> (Type'' Term Term -> Term
lvlOfType (Type'' Term Term -> Term)
-> NamesT (TCMT IO) (Type'' Term Term) -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Type'' Term 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
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
<#> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT (TCMT IO) Term
_ -> Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl (Type'' Term Term -> Term)
-> NamesT (TCMT IO) (Type'' Term Term) -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Type'' Term 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
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
              absAp m (Abs r)
x m (SubstArg r)
y = (Abs r -> SubstArg r -> r) -> m (Abs r) -> m (SubstArg r) -> m r
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Abs r -> SubstArg r -> r
forall a. Subst a => Abs a -> SubstArg a -> a
absApp m (Abs r)
x m (SubstArg r)
y

              mkFace (Term
r,(Term
u1,Term
u2)) = Names
-> NamesT (TCMT IO) (Abs (Term, Term))
-> TCMT IO (Abs (Term, Term))
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) (Abs (Term, Term)) -> TCMT IO (Abs (Term, Term)))
-> NamesT (TCMT IO) (Abs (Term, Term))
-> TCMT IO (Abs (Term, Term))
forall a b. (a -> b) -> a -> b
$ do
                -- Γ
                phi <- Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
the_phi  -- (δ , φ , us) ⊢ φ
                -- Γ ⊢ ty = Abs i. R (δ i)
                ty <- open (Abs "i" $ (liftS 1 (raiseS (size gamma - size params)) `composeS` sub params) `applySubst` t)

                bind "i" $ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> do
                  -- Γ, i
                  r  <- Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> (Term -> Term)
-> Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) 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)
theSub (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall a b. (a -> b) -> a -> b
$ Term
r
                  u1 <- open . applySubst theSub $ u1
                  u2 <- open . applySubst theSub $ u2
                  psi <- imax r (ineg r)
                  let
                    -- Γ, i ⊢ squeeze u = primTrans (\ j -> ty [i := i ∨ j]) (φ ∨ i) u
                    squeeze NamesT (TCMT IO) Term
u = 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
primTrans
                                          NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT (TCMT IO) Term
j -> Type'' Term Term -> Term
lvlOfType (Type'' Term Term -> Term)
-> NamesT (TCMT IO) (Type'' Term Term) -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Type'' Term Term))
ty NamesT (TCMT IO) (Abs (Type'' Term Term))
-> NamesT (TCMT IO) (SubstArg (Type'' Term Term))
-> NamesT (TCMT IO) (Type'' Term Term)
forall {m :: * -> *} {r}.
(Monad m, Subst r) =>
m (Abs r) -> m (SubstArg r) -> m r
`absAp` (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
imax NamesT (TCMT IO) Term
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i 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
<@> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT (TCMT IO) Term
j -> Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl (Type'' Term Term -> Term)
-> NamesT (TCMT IO) (Type'' Term Term) -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Type'' Term Term))
ty NamesT (TCMT IO) (Abs (Type'' Term Term))
-> NamesT (TCMT IO) (SubstArg (Type'' Term Term))
-> NamesT (TCMT IO) (Type'' Term Term)
forall {m :: * -> *} {r}.
(Monad m, Subst r) =>
m (Abs r) -> m (SubstArg r) -> m r
`absAp` (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
imax NamesT (TCMT IO) Term
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i 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
phi NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
`imax` NamesT (TCMT IO) Term
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
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
u
                  alpha <- pOr (ty `absAp` i)
                              (ineg r)
                              r
                           (ilam "o" $ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
squeeze NamesT (TCMT IO) Term
u1) (ilam "o" $ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
squeeze NamesT (TCMT IO) Term
u2)
                  return $ (psi, alpha)

            -- Γ ⊢ Abs i. [(ψ_n,α_n : [ψ] → R (δ i))]
            faces <- mapM mkFace $ theBoundary $ tmBoundary bs

            runNamesT [] $ do
                -- Γ
                w1' <- open w1'
                phi <- open the_phi
                u   <- open the_u
                -- R (δ i1)
                ty <- open ty
                faces <- mapM (\ Abs (Term, Term)
x -> (NamesT (TCMT IO) Term
 -> NamesT (TCMT IO) (Abs Term)
 -> (NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term)))
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Term))
-> NamesT
     (TCMT IO) (NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs 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.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> (Abs Term -> Term)
-> Abs Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Impossible -> Abs Term -> Term
forall a. Subst a => Impossible -> Abs a -> a
noabsApp Impossible
forall a. HasCallStack => a
__IMPOSSIBLE__ (Abs Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> Abs Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall a b. (a -> b) -> a -> b
$ ((Term, Term) -> Term) -> Abs (Term, Term) -> Abs Term
forall a b. (a -> b) -> Abs a -> Abs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst Abs (Term, Term)
x) (Abs Term -> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Term))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Term -> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Term)))
-> Abs Term -> NamesT (TCMT IO) (NamesT (TCMT IO) (Abs Term))
forall a b. (a -> b) -> a -> b
$ ((Term, Term) -> Term) -> Abs (Term, Term) -> Abs Term
forall a b. (a -> b) -> Abs a -> Abs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> b
snd Abs (Term, Term)
x)) faces
                let
                  thePsi = (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) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
imax (((NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))
 -> NamesT (TCMT IO) Term)
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
-> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))
-> NamesT (TCMT IO) Term
forall a b. (a, b) -> a
fst [(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
faces)
                  hcomp NamesT (TCMT IO) (Type'' Term Term)
ty NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
sys NamesT (TCMT IO) Term
a0 = 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
<#> (Type'' Term Term -> Term
lvlOfType (Type'' Term Term -> Term)
-> NamesT (TCMT IO) (Type'' Term Term) -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Type'' Term Term)
ty)
                                                    NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl (Type'' Term Term -> Term)
-> NamesT (TCMT IO) (Type'' Term Term) -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Type'' Term Term)
ty)
                                                    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
sys
                                                    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
a0
                let
                 sys = [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> do
                  let
                    recurse :: [(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
-> NamesT (TCMT IO) Term
recurse [(NamesT (TCMT IO) Term
psi,NamesT (TCMT IO) (Abs Term)
alpha)] = NamesT (TCMT IO) (Abs Term)
alpha NamesT (TCMT IO) (Abs Term)
-> NamesT (TCMT IO) (SubstArg Term) -> NamesT (TCMT IO) Term
forall {m :: * -> *} {r}.
(Monad m, Subst r) =>
m (Abs r) -> m (SubstArg r) -> m r
`absAp` (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
ineg NamesT (TCMT IO) Term
i)
                    recurse ((NamesT (TCMT IO) Term
psi,NamesT (TCMT IO) (Abs Term)
alpha):[(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
xs) = NamesT (TCMT IO) (Type'' Term Term)
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
pOr NamesT (TCMT IO) (Type'' Term Term)
ty
                                                   NamesT (TCMT IO) Term
psi  NamesT (TCMT IO) Term
theOr
                                                   (NamesT (TCMT IO) (Abs Term)
alpha NamesT (TCMT IO) (Abs Term)
-> NamesT (TCMT IO) (SubstArg Term) -> NamesT (TCMT IO) Term
forall {m :: * -> *} {r}.
(Monad m, Subst r) =>
m (Abs r) -> m (SubstArg r) -> m r
`absAp` (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
ineg NamesT (TCMT IO) Term
i)) ([(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
-> NamesT (TCMT IO) Term
recurse [(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
xs)
                      where
                        theOr :: NamesT (TCMT IO) Term
theOr = (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) -> [a] -> a
forall (t :: * -> *) a. Foldable t => (a -> a -> a) -> t a -> a
foldl1 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
imax (((NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))
 -> NamesT (TCMT IO) Term)
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
-> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))
-> NamesT (TCMT IO) Term
forall a b. (a, b) -> a
fst [(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
xs)
                    recurse [] = NamesT (TCMT IO) Term
forall a. HasCallStack => a
__IMPOSSIBLE__
                    sys_alpha :: NamesT (TCMT IO) Term
sys_alpha = [(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
-> NamesT (TCMT IO) Term
recurse [(NamesT (TCMT IO) Term, NamesT (TCMT IO) (Abs Term))]
faces
                  NamesT (TCMT IO) (Type'' Term Term)
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
pOr NamesT (TCMT IO) (Type'' Term Term)
ty
                                                   NamesT (TCMT IO) Term
thePsi    NamesT (TCMT IO) Term
phi
                                                   NamesT (TCMT IO) Term
sys_alpha ([Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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
u)
                hcomp ty (thePsi `imax` phi) sys w1'


      let

        -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ
        d0 :: Substitution
        d0 = Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
wkS Int
1 -- Δ^I, φ : F ⊢ Δ
                       (Term -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
iz Substitution' Term
forall a. Substitution' a
IdS Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
params) -- Δ^I ⊢ Δ
                                 -- Δ^I , i:I ⊢ sub params : Δ

        -- Δ.Φ ⊢ u = Con con ConOSystem $ teleElims fsT boundary : R δ
--        u = Con con ConOSystem $ teleElims fsT boundary
        up = ConHead
-> ConPatternInfo
-> [Arg (Named_ (Pattern' DBPatVar))]
-> Pattern' DBPatVar
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
con (PatternInfo
-> Bool
-> Bool
-> Maybe (Arg (Type'' Term Term))
-> Bool
-> ConPatternInfo
ConPatternInfo PatternInfo
defaultPatternInfo Bool
False Bool
False Maybe (Arg (Type'' Term Term))
forall a. Maybe a
Nothing Bool
False) ([Arg (Named_ (Pattern' DBPatVar))] -> Pattern' DBPatVar)
-> [Arg (Named_ (Pattern' DBPatVar))] -> Pattern' DBPatVar
forall a b. (a -> b) -> a -> b
$
               Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [Arg (Named_ (Pattern' DBPatVar))]
forall a.
DeBruijn a =>
Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [NamedArg (Pattern' a)]
telePatterns (Substitution' Term
Substitution' (SubstArg (Tele (Dom (Type'' Term Term))))
d0 Substitution' (SubstArg (Tele (Dom (Type'' Term Term))))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Tele (Dom (Type'' Term Term))
fsT) (Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
liftS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
fsT) Substitution' Term
d0 Substitution' (SubstArg (Boundary' Int Term))
-> Boundary' Int Term -> Boundary' Int Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Boundary' Int Term
boundary)
--        gamma' = telFromList $ take' (size gamma - 1) $ telToList gamma

        -- (δ , φ , fs : Φ[d0]) ⊢ u[liftS Φ d0]
        -- (δ , φ, u) : Γ ⊢ body
        -- Δ ⊢ Φ = fsT
        -- (δ , φ , fs : Φ[d0]) ⊢ u[liftS Φ d0] `consS` raiseS Φ : Γ
--        (tel',theta) = (abstract gamma' (d0 `applySubst` fsT), (liftS (size fsT) d0 `applySubst` u) `consS` raiseS (size fsT))

      let
        pats | Boundary' Int Term -> Bool
forall a. Null a => a -> Bool
null Boundary' Int Term
boundary = Tele (Dom (Type'' Term Term)) -> [Arg (Named_ (Pattern' DBPatVar))]
forall a t. DeBruijn a => Tele (Dom t) -> [NamedArg a]
teleNamedArgs Tele (Dom (Type'' Term Term))
gamma
             | Bool
otherwise     = Int
-> [Arg (Named_ (Pattern' DBPatVar))]
-> [Arg (Named_ (Pattern' DBPatVar))]
forall a. Int -> [a] -> [a]
take' (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
fsT) (Tele (Dom (Type'' Term Term)) -> [Arg (Named_ (Pattern' DBPatVar))]
forall a t. DeBruijn a => Tele (Dom t) -> [NamedArg a]
teleNamedArgs Tele (Dom (Type'' Term Term))
gamma) [Arg (Named_ (Pattern' DBPatVar))]
-> [Arg (Named_ (Pattern' DBPatVar))]
-> [Arg (Named_ (Pattern' DBPatVar))]
forall a. [a] -> [a] -> [a]
++! [Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar))
forall e. e -> Arg e
argN (Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar)))
-> Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar))
forall a b. (a -> b) -> a -> b
$ Pattern' DBPatVar -> Named_ (Pattern' DBPatVar)
forall a name. a -> Named name a
unnamed (Pattern' DBPatVar -> Named_ (Pattern' DBPatVar))
-> Pattern' DBPatVar -> Named_ (Pattern' DBPatVar)
forall a b. (a -> b) -> a -> b
$ Pattern' DBPatVar
up]
        clause = Clause
          { clauseTel :: Tele (Dom (Type'' Term Term))
clauseTel         = Tele (Dom (Type'' Term Term))
gamma
          , clauseType :: Maybe (Arg (Type'' Term Term))
clauseType        = Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term))
forall a. a -> Maybe a
Just (Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term)))
-> (Type'' Term Term -> Arg (Type'' Term Term))
-> Type'' Term Term
-> Maybe (Arg (Type'' Term Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type'' Term Term -> Arg (Type'' Term Term)
forall e. e -> Arg e
argN (Type'' Term Term -> Maybe (Arg (Type'' Term Term)))
-> Type'' Term Term -> Maybe (Arg (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ Type'' Term Term
ty
          , namedClausePats :: [Arg (Named_ (Pattern' DBPatVar))]
namedClausePats   = [Arg (Named_ (Pattern' DBPatVar))]
pats
          , clauseFullRange :: Range
clauseFullRange   = Range
forall a. Range' a
noRange
          , clauseLHSRange :: Range
clauseLHSRange    = Range
forall a. Range' a
noRange
          , clauseCatchall :: Catchall
clauseCatchall    = Catchall
forall a. Null a => a
empty
          , 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
body
          , clauseRecursive :: ClauseRecursive
clauseRecursive   = ClauseRecursive
MaybeRecursive
              -- Andreas 2020-02-06 TODO
              -- Or: NotRecursive;  is it known to be non-recursive?
          , 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
          }
        cs = [Clause
clause]
      addClauses theName cs
      (mst, _, cc) <- inTopContext (compileClauses Nothing cs)
      whenJust mst $ setSplitTree theName
      setCompiledClauses theName cc
      setTerminates theName $ Just True
      return $ Just theName

    whenDefined :: Bool -> t a -> m (Maybe a) -> m (Maybe a)
whenDefined Bool
False t a
_ m (Maybe a)
_ = Maybe a -> m (Maybe a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe a
forall a. Maybe a
Nothing
    whenDefined Bool
True t a
xs m (Maybe a)
m = do
      xs <- (a -> m (Maybe Term)) -> t a -> m (t (Maybe 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) -> t a -> m (t b)
mapM a -> m (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' t a
xs
      if all isJust xs then m else return Nothing

-- Andrea: TODO handle Irrelevant fields somehow.
-- | Define projections for non-indexed data types (families don't work yet).
--   Of course, these projections are partial functions in general.
--
--   Precondition: we are in the context Γ of the data type parameters.
defineProjections :: QName      -- datatype name
                  -> ConHead
                  -> Telescope  -- Γ parameters
                  -> [QName]    -- projection names
                  -> Telescope  -- Γ ⊢ Φ field types
                  -> Type       -- Γ ⊢ T target type
                  -> TCM ()
defineProjections :: QName
-> ConHead
-> Tele (Dom (Type'' Term Term))
-> [QName]
-> Tele (Dom (Type'' Term Term))
-> Type'' Term Term
-> TCM ()
defineProjections QName
dataName ConHead
con Tele (Dom (Type'' Term Term))
params [QName]
names Tele (Dom (Type'' Term Term))
fsT Type'' Term Term
t = do
  let
    -- Γ , (d : T) ⊢ Φ[n ↦ proj n d]
    fieldTypes :: [Dom (Type'' Term Term)]
fieldTypes = ([ QName -> [Elim' Term] -> Term
Def QName
f [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Int -> Term
var Int
0] | QName
f <- [QName] -> [QName]
forall a. [a] -> [a]
reverse [QName]
names ] [Term] -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS Int
1) Substitution' (SubstArg [Dom (Type'' Term Term)])
-> [Dom (Type'' Term Term)] -> [Dom (Type'' Term Term)]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst`
                    Tele (Dom (Type'' Term Term)) -> [Dom (Type'' Term Term)]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel Tele (Dom (Type'' Term Term))
fsT  -- Γ , Φ ⊢ Φ
    -- ⊢ Γ , (d : T)
    projTel :: Tele (Dom (Type'' Term Term))
projTel    = Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
params (Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type'' Term Term -> Dom (Type'' Term Term)
forall a. a -> Dom a
defaultDom Type'' Term Term
t) ([Char]
-> Tele (Dom (Type'' Term Term))
-> Abs (Tele (Dom (Type'' Term Term)))
forall a. [Char] -> a -> Abs a
Abs [Char]
"d" Tele (Dom (Type'' Term Term))
forall a. Tele a
EmptyTel))
    np :: Int
np         = Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
params

  [(Int, QName, Dom (Type'' Term Term))]
-> ((Int, QName, Dom (Type'' Term Term)) -> TCM ()) -> TCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Int]
-> [QName]
-> [Dom (Type'' Term Term)]
-> [(Int, QName, Dom (Type'' Term Term))]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (Int -> [Int]
forall a. Integral a => a -> [a]
downFrom ([Dom (Type'' Term Term)] -> Int
forall a. Sized a => a -> Int
size [Dom (Type'' Term Term)]
fieldTypes)) [QName]
names [Dom (Type'' Term Term)]
fieldTypes) (((Int, QName, Dom (Type'' Term Term)) -> TCM ()) -> TCM ())
-> ((Int, QName, Dom (Type'' Term Term)) -> TCM ()) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \ (Int
i,QName
projName,Dom (Type'' Term Term)
ty) -> do
    let
      projType :: Dom (Type'' Term Term)
projType = Tele (Dom (Type'' Term Term))
-> Type'' Term Term -> Type'' Term Term
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
projTel (Type'' Term Term -> Type'' Term Term)
-> Dom (Type'' Term Term) -> Dom (Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom (Type'' Term Term)
ty
      cpi :: ConPatternInfo
cpi    = PatternInfo
-> Bool
-> Bool
-> Maybe (Arg (Type'' Term Term))
-> Bool
-> ConPatternInfo
ConPatternInfo PatternInfo
defaultPatternInfo Bool
False Bool
False (Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term))
forall a. a -> Maybe a
Just (Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term)))
-> Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ Type'' Term Term -> Arg (Type'' Term Term)
forall e. e -> Arg e
argN (Type'' Term Term -> Arg (Type'' Term Term))
-> Type'' Term Term -> Arg (Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ Int -> Type'' Term Term -> Type'' Term Term
forall a. Subst a => Int -> a -> a
raise (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
fsT) Type'' Term Term
t) Bool
False
      conp :: Arg (Named_ (Pattern' DBPatVar))
conp   = Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar))
forall a. a -> NamedArg a
defaultNamedArg (Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar)))
-> Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar))
forall a b. (a -> b) -> a -> b
$ ConHead
-> ConPatternInfo
-> [Arg (Named_ (Pattern' DBPatVar))]
-> Pattern' DBPatVar
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
con ConPatternInfo
cpi ([Arg (Named_ (Pattern' DBPatVar))] -> Pattern' DBPatVar)
-> [Arg (Named_ (Pattern' DBPatVar))] -> Pattern' DBPatVar
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> [Arg (Named_ (Pattern' DBPatVar))]
forall a t. DeBruijn a => Tele (Dom t) -> [NamedArg a]
teleNamedArgs Tele (Dom (Type'' Term Term))
fsT
      sigma :: Substitution' Term
sigma  = ConHead -> ConInfo -> [Elim' Term] -> Term
Con ConHead
con ConInfo
ConOSystem ((Arg Term -> Elim' Term) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply ([Arg Term] -> [Elim' Term]) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> [Arg Term]
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom (Type'' Term Term))
fsT) Term -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
`consS` Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
fsT)
      clause :: Clause
clause = Clause
forall a. Null a => a
empty
          { clauseTel         = abstract params fsT
          , namedClausePats   = [ conp ]
          , clauseBody        = Just $ var i
          , clauseType        = Just $ argN $ applySubst sigma $ unDom ty
          , clauseRecursive   = NotRecursive  -- non-recursive
          , clauseUnreachable = Just False
          }

    [Char] -> Int -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.proj" Int
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> TCMT IO Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCMT IO Doc
"proj" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Int, Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
(Int, Dom (Type'' Term Term)) -> m Doc
prettyTCM (Int
i,Dom (Type'' Term Term)
ty)
      , 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
sep [ QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
projName, TCMT IO Doc
":", Dom (Type'' Term Term) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Dom (Type'' Term Term) -> m Doc
prettyTCM Dom (Type'' Term Term)
projType ]
      ]

    -- Andreas, 2020-02-14, issue #4437
    -- Define data projections as projection-like from the start.
    TCM () -> TCM ()
forall a. TCM a -> TCM a
noMutualBlock (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
      let cs :: [Clause]
cs = [ Clause
clause ]
      (mst, _, cc) <- Maybe (QName, Type'' Term Term)
-> [Clause]
-> TCMT IO (Maybe SplitTree, Bool, CompiledClauses' Term)
compileClauses Maybe (QName, Type'' Term Term)
forall a. Maybe a
Nothing [Clause]
cs
      fun          <- emptyFunctionData <&> \FunctionData
fun -> FunctionData
fun
                { _funClauses    = cs
                , _funCompiled   = Just cc
                , _funSplitTree  = mst
                , _funProjection = Right Projection
                    { projProper   = Nothing
                    , projOrig     = projName
                    , projFromType = Arg (getArgInfo ty) dataName
                    , projIndex    = np + 1
                    , projLams     = ProjLams $ map' (argFromDom . fmap fst) $ telToList projTel
                    }
                , _funMutual     = Just []
                , _funTerminates = Just True
                }
      lang <- getLanguage
      inTopContext $ addConstant projName $
        (defaultDefn defaultArgInfo projName (unDom projType) lang $ FunctionDefn fun)
          { defNoCompilation  = True
          , defArgOccurrences = [StrictPos]
          }

      reportSDoc "tc.data.proj.fun" 60 $ inTopContext $ vcat
        [ "proj" <+> prettyTCM i
        , nest 2 $ pretty fun
        ]


freshAbstractQName'_ :: String -> TCM QName
freshAbstractQName'_ :: [Char] -> TCMT IO QName
freshAbstractQName'_ = Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
noFixity' (Name -> TCMT IO QName)
-> ([Char] -> Name) -> [Char] -> TCMT IO QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Name
C.simpleName

-- | I am not sure what the generated transport functions should look like
--   in the presence of local rewrite rule parameters.
--   The easiest solution is to just refuse to generate the transport function,
--   and throw a type error.
checkNoLocalRewrites :: QName -> TCM ()
checkNoLocalRewrites :: QName -> TCM ()
checkNoLocalRewrites QName
d = do
  def <- QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
d
  case theDef def of
    Datatype { dataPars :: Defn -> Int
dataPars = Int
npars
             , dataIxs :: Defn -> Int
dataIxs = Int
nixs
             , dataSort :: Defn -> Sort
dataSort = Sort
s}
     -> do
      let t :: Type'' Term Term
t = Definition -> Type'' Term Term
defType Definition
def
      TelV params t' <- Int -> Type'' Term Term -> TCMT IO (TelV (Type'' Term Term))
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Int -> Type'' Term Term -> m (TelV (Type'' Term Term))
telViewUpTo Int
npars Type'' Term Term
t
      checkNoLocalRewrites' d params
    Defn
_ -> TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__

checkNoLocalRewrites' :: QName -> Tele (Dom Type) -> TCM ()
checkNoLocalRewrites' :: QName -> Tele (Dom (Type'' Term Term)) -> TCM ()
checkNoLocalRewrites' QName
d Tele (Dom (Type'' Term Term))
tel = Bool -> TCM () -> TCM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (VarSet -> Bool
VarSet.null (VarSet -> Bool) -> VarSet -> Bool
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> VarSet
theRewVars Tele (Dom (Type'' Term Term))
tel) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$
  TypeError -> TCM ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM ()) -> TypeError -> TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
CannotGenerateTransportLocalRewrite QName
d

-- | Defines and returns the name of the `transpIx` function.
defineTranspIx :: QName  -- ^ datatype name
               -> TCM (Maybe QName)
defineTranspIx :: QName -> TCMT IO (Maybe QName)
defineTranspIx QName
d = do
  def <- QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
d
  case theDef def of
    Datatype { dataPars :: Defn -> Int
dataPars = Int
npars
             , dataIxs :: Defn -> Int
dataIxs = Int
nixs
             , dataSort :: Defn -> Sort
dataSort = Sort
s}
     -> do
      let t :: Type'' Term Term
t = Definition -> Type'' Term Term
defType Definition
def
      [Char] -> Int -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.ixs" Int
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
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
"name :" 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
d
        , TCMT IO Doc
"type :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
t
        , TCMT IO Doc
"npars:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Int -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Int
npars
        , TCMT IO Doc
"nixs :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Int -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Int
nixs
        ]
      if Int
nixs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0 then Maybe QName -> TCMT IO (Maybe QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QName
forall a. Maybe a
Nothing else do
      trIx <- [Char] -> TCMT IO QName
freshAbstractQName'_ ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char]
"transpX-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Name -> [Char]
forall a. Pretty a => a -> [Char]
P.prettyShow (QName -> Name
A.qnameName QName
d)
      TelV params t' <- telViewUpTo npars t
      TelV ixs    dT <- telViewUpTo nixs t'
      -- params     ⊢ s
      -- params     ⊢ ixs
      -- params.ixs ⊢ dT
      reportSDoc "tc.data.ixs" 20 $ vcat
        [ "params :" <+> prettyTCM params
        , "ixs    :" <+> addContext params (prettyTCM ixs)
        , "dT     :" <+> addContext params (addContext ixs $ prettyTCM dT)
        ]
      -- theType <- abstract params <$> undefined
      interval <- primIntervalType
      let deltaI = Type'' Term Term
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
expTelescope Type'' Term Term
interval Tele (Dom (Type'' Term Term))
ixs
      iz <- primIZero
      io@(Con c _ _) <- primIOne
      imin <- getPrimitiveTerm builtinIMin
      imax <- getPrimitiveTerm builtinIMax
      ineg <- getPrimitiveTerm builtinINeg
      transp <- getPrimitiveTerm builtinTrans
      por <- getPrimitiveTerm builtinPOr
      one <- primItIsOne
      -- reportSDoc "trans.rec" 20 $ text $ show params
      -- reportSDoc "trans.rec" 20 $ text $ show deltaI
      -- reportSDoc "trans.rec" 10 $ text $ show fsT

      -- let thePrefix = "transp-"
      -- theName <- freshAbstractQName'_ $ thePrefix ++! P.prettyShow (A.qnameName name)

      -- reportSLn "trans.rec" 5 $ ("Generated name: " ++! show theName ++! " " ++! showQNameId theName)

      -- record type in 'exponentiated' context
      -- (params : Γ)(ixs : Δ^I), i : I |- T[params, ixs i]
      let rect' = Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
ixs Substitution' (SubstArg (Type'' Term Term))
-> Type'' Term Term -> Type'' Term Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Sort -> Term -> Type'' Term Term
forall t a. Sort' t -> a -> Type'' t a
El (Int -> Sort -> Sort
forall a. Subst a => Int -> a -> a
raise (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
ixs) Sort
s) (QName -> [Elim' Term] -> Term
Def QName
d (Tele (Dom (Type'' Term Term)) -> Boundary' Int Term -> [Elim' Term]
forall a.
DeBruijn a =>
Tele (Dom (Type'' Term Term)) -> Boundary' Int a -> [Elim' a]
teleElims (Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
params Tele (Dom (Type'' Term Term))
ixs) Boundary' Int Term
forall a. Null a => a
empty))
      addContext params $ reportSDoc "tc.data.ixs" 20 $ "deltaI:" <+> prettyTCM deltaI
      addContext params $ addContext deltaI $ addContext ("i"::String, defaultDom interval) $ do
        reportSDoc "tc.data.ixs" 20 $ "rect':" <+> pretty (sub ixs)
        reportSDoc "tc.data.ixs" 20 $ "rect':" <+> pretty rect'

      theType <- (abstract (setHiding Hidden <$> params) <$>) . (abstract deltaI <$>) $ runNamesT [] $ do
                  rect' <- open (runNames [] $ bind "i" $ \ forall b. (Subst b, DeBruijn b) => NamesT Identity b
x -> let NamesT Identity Term
_ = NamesT Identity Term
forall b. (Subst b, DeBruijn b) => NamesT Identity b
x NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall a. a -> a -> a
`asTypeOf` Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term
forall a. HasCallStack => a
undefined :: Term) in
                                                                 Type'' Term Term -> NamesT Identity (Type'' Term Term)
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type'' Term Term
rect')
                  nPi' "phi" (primIntervalType) $ \ NamesT (TCMT IO) Term
phi ->
                   (Abs (Type'' Term Term) -> Term -> Type'' Term Term
Abs (Type'' Term Term)
-> SubstArg (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Type'' Term Term) -> Term -> Type'' Term Term)
-> NamesT (TCMT IO) (Abs (Type'' Term Term))
-> NamesT (TCMT IO) (Term -> Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Type'' Term Term))
rect' NamesT (TCMT IO) (Term -> Type'' Term Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' 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
<*> 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) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *).
HasOptions m =>
m (Type'' Term Term)
-> m (Type'' Term Term) -> m (Type'' Term Term)
--> (Abs (Type'' Term Term) -> Term -> Type'' Term Term
Abs (Type'' Term Term)
-> SubstArg (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Type'' Term Term) -> Term -> Type'' Term Term)
-> NamesT (TCMT IO) (Abs (Type'' Term Term))
-> NamesT (TCMT IO) (Term -> Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Type'' Term Term))
rect' NamesT (TCMT IO) (Term -> Type'' Term Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' 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
<*> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)

      reportSDoc "tc.data.ixs" 20 $ "transpIx:" <+> prettyTCM theType
      let
        ctel = Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
params (Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
deltaI (Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type'' Term Term -> Dom (Type'' Term Term)
forall a. a -> Dom a
defaultDom (Type'' Term Term -> Dom (Type'' Term Term))
-> Type'' Term Term -> Dom (Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ Int
-> SubstArg (Type'' Term Term)
-> Type'' Term Term
-> Type'' Term Term
forall a. Subst a => Int -> SubstArg a -> a -> a
subst Int
0 Term
SubstArg (Type'' Term Term)
iz Type'' Term Term
rect') ([Char]
-> Tele (Dom (Type'' Term Term))
-> Abs (Tele (Dom (Type'' Term Term)))
forall a. [Char] -> a -> Abs a
Abs [Char]
"t" Tele (Dom (Type'' Term Term))
forall a. Tele a
EmptyTel)
        ps = Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [Arg (Named_ (Pattern' DBPatVar))]
forall a.
DeBruijn a =>
Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [NamedArg (Pattern' a)]
telePatterns Tele (Dom (Type'' Term Term))
ctel Boundary' Int Term
forall a. Null a => a
empty
        cpi = ConPatternInfo
noConPatternInfo { conPType = Just (defaultArg interval) }
        pat :: NamedArg (Pattern' DBPatVar)
        pat = Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar))
forall a. a -> NamedArg a
defaultNamedArg (Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar)))
-> Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar))
forall a b. (a -> b) -> a -> b
$ ConHead
-> ConPatternInfo
-> [Arg (Named_ (Pattern' DBPatVar))]
-> Pattern' DBPatVar
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c ConPatternInfo
cpi []
        clause = Clause
forall a. Null a => a
empty
          { clauseTel         = ctel
          , namedClausePats   = init ps ++! [pat, last ps]

          , clauseBody        = Just $ var 0
          , clauseType        = Just $ defaultArg $ raise 1 $ subst 0 io rect'
          , clauseRecursive   = NotRecursive -- non-recursive
          , clauseUnreachable = Just False
          }

      noMutualBlock $ do
        let cs = [ Clause
clause ]
--        we do not compile clauses as that leads to throwing missing clauses errors.
--        (mst, _, cc) <- compileClauses Nothing cs
        fun <- emptyFunctionData <&> \FunctionData
fun -> FunctionData
fun
                  { _funClauses    = cs
               --   , _funCompiled   = Just cc
               --   , _funSplitTree  = mst
                  , _funProjection = Left MaybeProjection
                  , _funMutual     = Just []
                  , _funTerminates = Just True
                  , _funIsKanOp    = Just d
                  }
        inTopContext $ do
         reportSDoc "tc.transpx.type" 15 $ vcat
           [ "type of" <+> prettyTCM trIx <+> ":"
           , nest 2 $ prettyTCM theType
           ]

         addConstant trIx $
          (defaultDefn defaultArgInfo trIx theType (Cubical CErased) $ FunctionDefn fun)
            { defNoCompilation  = True
            }

        -- reportSDoc "tc.data.proj.fun" 60 $ inTopContext $ vcat
        --   [ "proj" <+> prettyTCM i
        --   , nest 2 $ pretty fun
        --   ]
      -- addContext ctel $ do
      --   let es = teleElims ctel []
      --   r <- reduce $ Def trIx es
      --   reportSDoc "tc.data.ixs" 20 $ "reducedx:" <+> prettyTCM r
      --   r <- reduce $ Def trIx (init es ++! [Apply $ argN io, last es])
      --   reportSDoc "tc.data.ixs" 20 $ "reduced1:" <+> prettyTCM r
      return $ Just trIx
    Defn
_ -> TCMT IO (Maybe QName)
forall a. HasCallStack => a
__IMPOSSIBLE__
  where

    -- Γ, Δ^I, i : I |- sub (Γ ⊢ Δ) : Γ, Δ
    sub :: a -> Substitution' Term
sub a
tel = Int -> Substitution' Term
expS (Int -> Substitution' Term) -> Int -> Substitution' Term
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Sized a => a -> Int
size a
tel


defineTranspFun :: QName -- ^ datatype
                -> Maybe QName -- ^ transpX "constructor"
                -> [QName]     -- ^ constructor names
                -> [QName]     -- ^ path cons
                -> TCM (Maybe QName) -- transp function for the datatype.
defineTranspFun :: QName -> Maybe QName -> [QName] -> [QName] -> TCMT IO (Maybe QName)
defineTranspFun QName
d Maybe QName
mtrX [QName]
cons [QName]
pathCons = do
  def <- QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
d
  case theDef def of
    Datatype { dataPars :: Defn -> Int
dataPars = Int
npars
             , dataIxs :: Defn -> Int
dataIxs = Int
nixs
             , dataSort :: Defn -> Sort
dataSort = s :: Sort
s@(Type Level' Term
_)
--             , dataCons = cons -- not there yet
             }
     -> do
      let t :: Type'' Term Term
t = Definition -> Type'' Term Term
defType Definition
def
      [Char] -> Int -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp" Int
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
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
"name :" 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
d
        , TCMT IO Doc
"type :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
t
        , TCMT IO Doc
"npars:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Int -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Int
npars
        , TCMT IO Doc
"nixs :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Int -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Int
nixs
        ]
      trD <- [Char] -> TCMT IO QName
freshAbstractQName'_ ([Char] -> TCMT IO QName) -> [Char] -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char]
"transp" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Name -> [Char]
forall a. Pretty a => a -> [Char]
P.prettyShow (QName -> Name
A.qnameName QName
d)
      TelV params t' <- telViewUpTo npars t
      TelV ixs    dT <- telViewUpTo nixs t'

      let tel = Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
params Tele (Dom (Type'' Term Term))
ixs
      mixs <- runMaybeT $ traverse (traverse (MaybeT . toLType)) ixs
      caseMaybe mixs (return Nothing) $ \ Tele (Dom LType)
_ -> do

      io@(Con io_c _ []) <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
      iz <- primIZero

      interval <- primIntervalType
      let telI = Type'' Term Term
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
expTelescope Type'' Term Term
interval Tele (Dom (Type'' Term Term))
tel
          sigma = Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
tel
          dTs = (Substitution' Term
Substitution' (SubstArg (Type'' Term Term))
sigma Substitution' (SubstArg (Type'' Term Term))
-> Type'' Term Term -> Type'' Term Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Sort -> Term -> Type'' Term Term
forall t a. Sort' t -> a -> Type'' t a
El Sort
s (QName -> [Elim' Term] -> Term
Def QName
d ([Elim' Term] -> Term) -> [Elim' Term] -> Term
forall a b. (a -> b) -> a -> b
$ (Arg Term -> Elim' Term) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply ([Arg Term] -> [Elim' Term]) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> [Arg Term]
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom (Type'' Term Term))
tel))

      theType <- (abstract telI <$>) $ runNamesT [] $ do
                  dT <- open $ Abs "i" $ dTs
                  nPi' "phi" primIntervalType $ \ NamesT (TCMT IO) Term
phi ->
                   (Abs (Type'' Term Term) -> Term -> Type'' Term Term
Abs (Type'' Term Term)
-> SubstArg (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Type'' Term Term) -> Term -> Type'' Term Term)
-> NamesT (TCMT IO) (Abs (Type'' Term Term))
-> NamesT (TCMT IO) (Term -> Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Type'' Term Term))
dT NamesT (TCMT IO) (Term -> Type'' Term Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' 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
<*> 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) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *).
HasOptions m =>
m (Type'' Term Term)
-> m (Type'' Term Term) -> m (Type'' Term Term)
--> (Abs (Type'' Term Term) -> Term -> Type'' Term Term
Abs (Type'' Term Term)
-> SubstArg (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Type'' Term Term) -> Term -> Type'' Term Term)
-> NamesT (TCMT IO) (Abs (Type'' Term Term))
-> NamesT (TCMT IO) (Term -> Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Type'' Term Term))
dT NamesT (TCMT IO) (Term -> Type'' Term Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' 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
<*> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)


      reportSDoc "tc.data.transp" 20 $ "transpD:" <+> prettyTCM theType


      noMutualBlock $ do
        fun <- emptyFunction
        inTopContext $ addConstant trD $
          (defaultDefn defaultArgInfo trD theType (Cubical CErased) fun)
        let
          ctel = Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
telI (Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type'' Term Term -> Dom (Type'' Term Term)
forall a. a -> Dom a
defaultDom (Type'' Term Term -> Dom (Type'' Term Term))
-> Type'' Term Term -> Dom (Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ Int
-> SubstArg (Type'' Term Term)
-> Type'' Term Term
-> Type'' Term Term
forall a. Subst a => Int -> SubstArg a -> a -> a
subst Int
0 Term
SubstArg (Type'' Term Term)
iz Type'' Term Term
dTs) ([Char]
-> Tele (Dom (Type'' Term Term))
-> Abs (Tele (Dom (Type'' Term Term)))
forall a. [Char] -> a -> Abs a
Abs [Char]
"t" Tele (Dom (Type'' Term Term))
forall a. Tele a
EmptyTel)
          ps = Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [Arg (Named_ (Pattern' DBPatVar))]
forall a.
DeBruijn a =>
Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [NamedArg (Pattern' a)]
telePatterns Tele (Dom (Type'' Term Term))
ctel Boundary' Int Term
forall a. Null a => a
empty
          cpi = ConPatternInfo
noConPatternInfo { conPType = Just (defaultArg interval)
                                 , conPFallThrough = True
                                 }
          pat :: NamedArg (Pattern' DBPatVar)
          pat = Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar))
forall a. a -> NamedArg a
defaultNamedArg (Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar)))
-> Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar))
forall a b. (a -> b) -> a -> b
$ ConHead
-> ConPatternInfo
-> [Arg (Named_ (Pattern' DBPatVar))]
-> Pattern' DBPatVar
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
io_c ConPatternInfo
cpi []
          clause = Clause
forall a. Null a => a
empty
            { clauseTel         = ctel
            , namedClausePats   = init ps ++! [pat, last ps]

            , clauseBody        = Just $ var 0
            , clauseType        = Just $ defaultArg $ raise 1 $ subst 0 io dTs
            , clauseRecursive   = NotRecursive  -- non-recursive
            , clauseUnreachable = Just False
            }
        let debugNoTransp c
cl = c -> (Abs a -> m ()) -> m ()
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure c
cl ((Abs a -> m ()) -> m ()) -> (Abs a -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ Abs a
t -> do
              [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ ([Char], Dom (Type'' Term Term)) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
([Char], Dom (Type'' Term Term)) -> m a -> m a
addContext ([Char]
"i" :: String, Dom (Type'' Term Term)
HasCallStack => Dom (Type'' Term Term)
__DUMMY_DOM__) (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
                TCMT IO Doc
"could not transp" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM (Abs a -> a
forall a. Subst a => Abs a -> a
absBody Abs a
t)
        -- TODO: if no params nor indexes trD phi u0 = u0.
        ecs <- tryTranspError $ (clause:) <$> defineConClause trD (not $ null pathCons) mtrX npars nixs ixs telI sigma dTs cons
        caseEitherM (pure ecs) (\ Closure (Abs (Type'' Term Term))
cl -> Closure (Abs (Type'' Term Term)) -> TCM ()
forall {m :: * -> *} {c} {a}.
(MonadTCEnv m, ReadTCState m, LensClosure c (Abs a), MonadDebug m,
 PrettyTCM a, Subst a) =>
c -> m ()
debugNoTransp Closure (Abs (Type'' Term Term))
cl TCM () -> TCMT IO (Maybe QName) -> TCMT IO (Maybe QName)
forall a b. TCMT IO a -> TCMT IO b -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Maybe QName -> TCMT IO (Maybe QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QName
forall a. Maybe a
Nothing) $ \ [Clause]
cs -> do
        (mst, _, cc) <- Maybe (QName, Type'' Term Term)
-> [Clause]
-> TCMT IO (Maybe SplitTree, Bool, CompiledClauses' Term)
compileClauses Maybe (QName, Type'' Term Term)
forall a. Maybe a
Nothing [Clause]
cs
        fun <- emptyFunctionData <&> \FunctionData
fun -> FunctionData
fun
                  { _funClauses    = cs
                  , _funCompiled   = Just cc
                  , _funSplitTree  = mst
                  , _funProjection = Left MaybeProjection
                  , _funMutual     = Just []
                  , _funTerminates = Just True
                  , _funIsKanOp    = Just d
                  }
        inTopContext $ addConstant trD $
          (defaultDefn defaultArgInfo trD theType (Cubical CErased) $ FunctionDefn fun)
            { defNoCompilation  = True
            }
        reportSDoc "tc.data.transp" 20 $ sep
          [ "transp: compiled clauses of " <+> prettyTCM trD
          , nest 2 $ return $ P.pretty cc
          ]

        return $ Just trD


    Datatype {} -> Maybe QName -> TCMT IO (Maybe QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QName
forall a. Maybe a
Nothing
    Defn
_           -> TCMT IO (Maybe QName)
forall a. HasCallStack => a
__IMPOSSIBLE__
  where
    -- Γ, Δ^I, i : I |- sub (Γ ⊢ Δ) : Γ, Δ
    sub :: a -> Substitution' Term
sub a
tel = Int -> Substitution' Term
expS (a -> Int
forall a. Sized a => a -> Int
size a
tel)

defineConClause :: QName -- ^ trD
                -> Bool  -- ^ HIT
                -> Maybe QName -- ^ trX
                -> Nat  -- ^ npars = size Δ
                -> Nat  -- ^ nixs = size X
                -> Telescope -- ^ Δ ⊢ X
                -> Telescope -- ^ (Δ.X)^I
                -> Substitution -- ^ (Δ.X)^I, i : I ⊢ σ : Δ.X
                -> Type       -- ^ (Δ.X)^I, i : I ⊢ D[δ i,x i] -- datatype
                -> [QName]      -- ^ Constructors
                -> TCM [Clause]
defineConClause :: QName
-> Bool
-> Maybe QName
-> Int
-> Int
-> Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term))
-> Substitution' Term
-> Type'' Term Term
-> [QName]
-> TCM [Clause]
defineConClause QName
trD' Bool
isHIT Maybe QName
mtrX Int
npars Int
nixs Tele (Dom (Type'' Term Term))
xTel' Tele (Dom (Type'' Term Term))
telI Substitution' Term
sigma Type'' Term Term
dT' [QName]
cnames = do

  Bool -> TCM () -> TCM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (Maybe QName -> Bool
forall a. Maybe a -> Bool
isNothing Maybe QName
mtrX Bool -> Bool -> Bool
forall a. Eq a => a -> a -> Bool
== (Int
nixs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
0)) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ TCM ()
forall a. HasCallStack => a
__IMPOSSIBLE__

  io <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
  iz <- primIZero
  tHComp <- primHComp
  tINeg <- primINeg
  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 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 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
  let hcomp NamesT (TCMT IO) (Type'' Term Term)
ty [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys NamesT (TCMT IO) Term
u0 = do
          ty <- NamesT (TCMT IO) (Type'' Term Term)
ty
          LEl l ty <- fromMaybe __IMPOSSIBLE__ <$> toLType ty
          l <- open $ Level l
          ty <- open $ ty
          face <- (foldr max (pure iz) $ map' fst $ sys)
          sys <- lam "i'" $ \ 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
forall (m :: * -> *).
HasBuiltins m =>
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
combineSys NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
ty [(NamesT (TCMT IO) Term
phi, 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
phi,NamesT (TCMT IO) Term
u) <- [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys]
          pure tHComp <#> l <#> ty <#> pure face <@> pure sys <@> u0
  interval <- primIntervalType
  let intervalTel [Char]
nm = Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type'' Term Term -> Dom (Type'' Term Term)
forall a. a -> Dom a
defaultDom Type'' Term Term
interval) ([Char]
-> Tele (Dom (Type'' Term Term))
-> Abs (Tele (Dom (Type'' Term Term)))
forall a. [Char] -> a -> Abs a
Abs [Char]
nm Tele (Dom (Type'' Term Term))
forall a. Tele a
EmptyTel)

  let (parI,ixsI) = splitTelescopeAt npars telI
  let
    abstract_trD :: Monad m => (Vars m -> Vars m -> Vars m -> NamesT m Telescope) -> NamesT m Telescope
    abstract_trD Vars m
-> Vars m -> Vars m -> NamesT m (Tele (Dom (Type'' Term Term)))
k = do
               ixsI <- AbsN (Tele (Dom (Type'' Term Term)))
-> NamesT m (NamesT m (AbsN (Tele (Dom (Type'' Term Term)))))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (AbsN (Tele (Dom (Type'' Term Term)))
 -> NamesT m (NamesT m (AbsN (Tele (Dom (Type'' Term Term))))))
-> AbsN (Tele (Dom (Type'' Term Term)))
-> NamesT m (NamesT m (AbsN (Tele (Dom (Type'' Term Term)))))
forall a b. (a -> b) -> a -> b
$ Names
-> Tele (Dom (Type'' Term Term))
-> AbsN (Tele (Dom (Type'' Term Term)))
forall a. Names -> a -> AbsN a
AbsN (Tele (Dom (Type'' Term Term)) -> Names
teleNames Tele (Dom (Type'' Term Term))
parI) Tele (Dom (Type'' Term Term))
ixsI
               parI <- open parI
               abstractN parI $ \ Vars m
delta -> do
               NamesT m (Tele (Dom (Type'' Term Term)))
-> (Vars m -> NamesT m (Tele (Dom (Type'' Term Term))))
-> NamesT m (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *) a.
(Monad m, Abstract a) =>
NamesT m (Tele (Dom (Type'' Term Term)))
-> (Vars m -> NamesT m a) -> NamesT m a
abstractN (NamesT m (AbsN (Tele (Dom (Type'' Term Term))))
ixsI NamesT m (AbsN (Tele (Dom (Type'' Term Term))))
-> [NamesT m (SubstArg (Tele (Dom (Type'' Term Term))))]
-> NamesT m (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT m Term]
[NamesT m (SubstArg (Tele (Dom (Type'' Term Term))))]
Vars m
delta) ((Vars m -> NamesT m (Tele (Dom (Type'' Term Term))))
 -> NamesT m (Tele (Dom (Type'' Term Term))))
-> (Vars m -> NamesT m (Tele (Dom (Type'' Term Term))))
-> NamesT m (Tele (Dom (Type'' Term Term)))
forall a b. (a -> b) -> a -> b
$ \ Vars m
x -> do
               NamesT m (Tele (Dom (Type'' Term Term)))
-> (Vars m -> NamesT m (Tele (Dom (Type'' Term Term))))
-> NamesT m (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *) a.
(Monad m, Abstract a) =>
NamesT m (Tele (Dom (Type'' Term Term)))
-> (Vars m -> NamesT m a) -> NamesT m a
abstractN (Tele (Dom (Type'' Term Term))
-> NamesT m (Tele (Dom (Type'' Term Term)))
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tele (Dom (Type'' Term Term))
 -> NamesT m (Tele (Dom (Type'' Term Term))))
-> Tele (Dom (Type'' Term Term))
-> NamesT m (Tele (Dom (Type'' Term Term)))
forall a b. (a -> b) -> a -> b
$ [Char] -> Tele (Dom (Type'' Term Term))
intervalTel [Char]
"phi") ((Vars m -> NamesT m (Tele (Dom (Type'' Term Term))))
 -> NamesT m (Tele (Dom (Type'' Term Term))))
-> (Vars m -> NamesT m (Tele (Dom (Type'' Term Term))))
-> NamesT m (Tele (Dom (Type'' Term Term)))
forall a b. (a -> b) -> a -> b
$ \ Vars m
phi -> do
               Vars m
-> Vars m -> Vars m -> NamesT m (Tele (Dom (Type'' Term Term)))
k [NamesT m b]
Vars m
delta [NamesT m b]
Vars m
x [NamesT m b]
Vars m
phi
    bind_trD :: Monad m => (ArgVars m -> ArgVars m -> ArgVars m -> NamesT m b) ->
                NamesT m (AbsN (AbsN (AbsN b)))
    bind_trD ArgVars m -> ArgVars m -> ArgVars m -> NamesT m b
k = do
      [Arg [Char]]
-> (ArgVars m -> NamesT m (AbsN (AbsN b)))
-> NamesT m (AbsN (AbsN (AbsN b)))
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
teleArgNames Tele (Dom (Type'' Term Term))
parI) ((ArgVars m -> NamesT m (AbsN (AbsN b)))
 -> NamesT m (AbsN (AbsN (AbsN b))))
-> (ArgVars m -> NamesT m (AbsN (AbsN b)))
-> NamesT m (AbsN (AbsN (AbsN b)))
forall a b. (a -> b) -> a -> b
$ \ ArgVars m
delta_ps -> do
      [Arg [Char]]
-> (ArgVars m -> NamesT m (AbsN b)) -> NamesT m (AbsN (AbsN b))
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
teleArgNames Tele (Dom (Type'' Term Term))
ixsI) ((ArgVars m -> NamesT m (AbsN b)) -> NamesT m (AbsN (AbsN b)))
-> (ArgVars m -> NamesT m (AbsN b)) -> NamesT m (AbsN (AbsN b))
forall a b. (a -> b) -> a -> b
$ \ ArgVars m
x_ps -> do
      [Arg [Char]] -> (ArgVars m -> NamesT m b) -> NamesT m (AbsN b)
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
teleArgNames (Tele (Dom (Type'' Term Term)) -> [Arg [Char]])
-> Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> Tele (Dom (Type'' Term Term))
intervalTel [Char]
"phi") ((ArgVars m -> NamesT m b) -> NamesT m (AbsN b))
-> (ArgVars m -> NamesT m b) -> NamesT m (AbsN b)
forall a b. (a -> b) -> a -> b
$ \ ArgVars m
phi_ps -> do
      ArgVars m -> ArgVars m -> ArgVars m -> NamesT m b
k [NamesT m (Arg b)]
ArgVars m
delta_ps [NamesT m (Arg b)]
ArgVars m
x_ps [NamesT m (Arg b)]
ArgVars m
phi_ps
  let trD = [Arg [Char]]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN (AbsN Term)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
teleArgNames Tele (Dom (Type'' Term Term))
parI) ((ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN (AbsN Term)))
 -> NamesT (TCMT IO) (AbsN (AbsN (AbsN Term))))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN (AbsN Term)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
delta ->
            [Arg [Char]]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN Term))
-> NamesT (TCMT IO) (AbsN (AbsN Term))
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
teleArgNames Tele (Dom (Type'' Term Term))
ixsI) ((ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN Term))
 -> NamesT (TCMT IO) (AbsN (AbsN Term)))
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN Term))
-> NamesT (TCMT IO) (AbsN (AbsN Term))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x ->
            Names
-> (Vars (TCMT IO) -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) (AbsN Term)
forall (m :: * -> *) a.
Monad m =>
Names -> (Vars m -> NamesT m a) -> NamesT m (AbsN a)
bindN [[Char]
"phi",[Char]
"u0"]           ((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
phi,NamesT (TCMT IO) Term
u0] ->
              ((QName -> [Elim' Term] -> Term
Def QName
trD' [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply`) ([Arg Term] -> 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)] -> NamesT (TCMT IO) [Arg 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) (Arg Term)]
ArgVars (TCMT IO)
delta [NamesT (TCMT IO) (Arg Term)]
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) (Arg Term)]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) (Arg Term)]
ArgVars (TCMT IO)
x)) 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
u0
  -- [Δ] ⊢ X
  let xTel = AbsN (Tele (Dom (Type'' Term Term)))
-> NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN (Tele (Dom (Type'' Term Term)))
 -> NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term)))))
-> AbsN (Tele (Dom (Type'' Term Term)))
-> NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
forall a b. (a -> b) -> a -> b
$ Names
-> Tele (Dom (Type'' Term Term))
-> AbsN (Tele (Dom (Type'' Term Term)))
forall a. Names -> a -> AbsN a
AbsN (Tele (Dom (Type'' Term Term)) -> Names
teleNames Tele (Dom (Type'' Term Term))
parI) Tele (Dom (Type'' Term Term))
xTel'
  -- [δ : Δ^I, x : X^I, i : I] ⊢ D (δ i) (x i)
  let dT = AbsN (Type'' Term Term)
-> NamesT (TCMT IO) (AbsN (Type'' Term Term))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN (Type'' Term Term)
 -> NamesT (TCMT IO) (AbsN (Type'' Term Term)))
-> AbsN (Type'' Term Term)
-> NamesT (TCMT IO) (AbsN (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ Names -> Type'' Term Term -> AbsN (Type'' Term Term)
forall a. Names -> a -> AbsN a
AbsN (Tele (Dom (Type'' Term Term)) -> Names
teleNames Tele (Dom (Type'' Term Term))
parI Names -> Names -> Names
forall a. [a] -> [a] -> [a]
++! Tele (Dom (Type'' Term Term)) -> Names
teleNames Tele (Dom (Type'' Term Term))
ixsI Names -> Names -> Names
forall a. [a] -> [a] -> [a]
++! [[Char]
"i"]) Type'' Term Term
dT'

  let hcompComputes = Bool -> Bool
forall a. Boolean a => a -> a
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
isHIT Bool -> Bool -> Bool
forall a. Boolean a => a -> a -> a
|| Int
nixs Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0
  c_HComp <- if hcompComputes then return [] else do
      reportSDoc "tc.data.transp.con" 20 $ "======================="
      reportSDoc "tc.data.transp.con" 20 $ "hcomp"
      qHComp <- fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinHComp
      hcomp_ty <- defType <$> getConstInfo qHComp
      gamma <- runNamesT [] $ do
               ixsI <- open $ AbsN (teleNames parI) ixsI
               parI <- open parI
               abstract_trD $ \ Vars (TCMT IO)
delta Vars (TCMT IO)
x Vars (TCMT IO)
_ -> do
               LEl l ty <- LType -> Maybe LType -> LType
forall a. a -> Maybe a -> a
fromMaybe LType
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe LType -> LType)
-> (Type'' Term Term -> NamesT (TCMT IO) (Maybe LType))
-> Type'' Term Term
-> NamesT (TCMT IO) LType
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Type'' Term Term -> NamesT (TCMT IO) (Maybe LType)
forall (m :: * -> *).
MonadReduce m =>
Type'' Term Term -> m (Maybe LType)
toLType (Type'' Term Term -> NamesT (TCMT IO) LType)
-> NamesT (TCMT IO) (Type'' Term Term) -> NamesT (TCMT IO) LType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (NamesT (TCMT IO) (AbsN (Type'' Term Term))
dT NamesT (TCMT IO) (AbsN (Type'' Term Term))
-> [NamesT (TCMT IO) (SubstArg (Type'' Term Term))]
-> NamesT (TCMT IO) (Type'' Term Term)
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)
delta [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
Vars (TCMT IO)
x [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz]))
               -- (φ : I), (I → Partial φ (D (δ i0) (x i0))), D (δ i0) (x i0)
               TelV args _ <- lift $ telView =<< piApplyM hcomp_ty [Level l,ty]
               unless (size args == 3) __IMPOSSIBLE__
               pure args
      res <- runNamesT [] $ do
        let hcompArgs = ([Char] -> Arg [Char]) -> Names -> [Arg [Char]]
forall a b. (a -> b) -> [a] -> [b]
map' [Char] -> Arg [Char]
forall e. e -> Arg e
argN [[Char]
"phi",[Char]
"u",[Char]
"u0"]
        bind_trD $ \ ArgVars (TCMT IO)
delta_ps ArgVars (TCMT IO)
x_ps ArgVars (TCMT IO)
phi_ps -> do
        let x :: [NamesT (TCMT IO) Term]
x = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
x_ps
        let delta :: [NamesT (TCMT IO) Term]
delta = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
delta_ps
        let [NamesT (TCMT IO) Term
phi] = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
phi_ps
        [Arg [Char]]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT
     (TCMT IO)
     (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg [Char]]
hcompArgs ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO)
       ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
 -> NamesT
      (TCMT IO)
      (AbsN
         ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term)))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT
     (TCMT IO)
     (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
as0 -> do -- as0 : aTel[delta 0]
        let
          origPHComp :: NamesT (TCMT IO) (Pattern' DBPatVar)
origPHComp = do
            LEl l t <- LType -> Maybe LType -> LType
forall a. a -> Maybe a -> a
fromMaybe LType
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe LType -> LType)
-> (Type'' Term Term -> NamesT (TCMT IO) (Maybe LType))
-> Type'' Term Term
-> NamesT (TCMT IO) LType
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Type'' Term Term -> NamesT (TCMT IO) (Maybe LType)
forall (m :: * -> *).
MonadReduce m =>
Type'' Term Term -> m (Maybe LType)
toLType (Type'' Term Term -> NamesT (TCMT IO) LType)
-> NamesT (TCMT IO) (Type'' Term Term) -> NamesT (TCMT IO) LType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (NamesT (TCMT IO) (AbsN (Type'' Term Term))
dT NamesT (TCMT IO) (AbsN (Type'' Term Term))
-> [NamesT (TCMT IO) (SubstArg (Type'' Term Term))]
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
delta [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz]))
            let ds = (Term -> Arg (Named_ (Pattern' DBPatVar)))
-> [Term] -> [Arg (Named_ (Pattern' DBPatVar))]
forall a b. (a -> b) -> [a] -> [b]
map' (Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar))
forall e. e -> Arg e
argH (Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar)))
-> (Term -> Named_ (Pattern' DBPatVar))
-> Term
-> Arg (Named_ (Pattern' DBPatVar))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern' DBPatVar -> Named_ (Pattern' DBPatVar)
forall a name. a -> Named name a
unnamed (Pattern' DBPatVar -> Named_ (Pattern' DBPatVar))
-> (Term -> Pattern' DBPatVar)
-> Term
-> Named_ (Pattern' DBPatVar)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Pattern' DBPatVar
forall a. Term -> Pattern' a
dotP) [Level' Term -> Term
Level Level' Term
l, Term
t]
            sequence as0 >>= \case
              ps0 :: [Arg (Named_ (Pattern' DBPatVar))]
ps0@[Arg (Named_ (Pattern' DBPatVar))
_hphi,Arg (Named_ (Pattern' DBPatVar))
_u,Arg (Named_ (Pattern' DBPatVar))
_u0] ->
                Pattern' DBPatVar -> NamesT (TCMT IO) (Pattern' DBPatVar)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Pattern' DBPatVar -> NamesT (TCMT IO) (Pattern' DBPatVar))
-> Pattern' DBPatVar -> NamesT (TCMT IO) (Pattern' DBPatVar)
forall a b. (a -> b) -> a -> b
$! PatternInfo
-> QName -> [Arg (Named_ (Pattern' DBPatVar))] -> Pattern' DBPatVar
forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
defaultPatternInfo QName
qHComp ([Arg (Named_ (Pattern' DBPatVar))] -> Pattern' DBPatVar)
-> [Arg (Named_ (Pattern' DBPatVar))] -> Pattern' DBPatVar
forall a b. (a -> b) -> a -> b
$! [Arg (Named_ (Pattern' DBPatVar))]
ds [Arg (Named_ (Pattern' DBPatVar))]
-> [Arg (Named_ (Pattern' DBPatVar))]
-> [Arg (Named_ (Pattern' DBPatVar))]
forall a. [a] -> [a] -> [a]
++! [Arg (Named_ (Pattern' DBPatVar))]
ps0
              [Arg (Named_ (Pattern' DBPatVar))]
_ -> NamesT (TCMT IO) (Pattern' DBPatVar)
forall a. HasCallStack => a
__IMPOSSIBLE__
          psHComp :: NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
psHComp = [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
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) (Arg (Named_ (Pattern' DBPatVar)))]
 -> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))])
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
forall a b. (a -> b) -> a -> b
$ [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
delta_ps [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
x_ps [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
phi_ps [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
forall a. [a] -> [a] -> [a]
++! [Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar))
forall e. e -> Arg e
argN (Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar)))
-> (Pattern' DBPatVar -> Named_ (Pattern' DBPatVar))
-> Pattern' DBPatVar
-> Arg (Named_ (Pattern' DBPatVar))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern' DBPatVar -> Named_ (Pattern' DBPatVar)
forall a name. a -> Named name a
unnamed (Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar)))
-> NamesT (TCMT IO) (Pattern' DBPatVar)
-> NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Pattern' DBPatVar)
origPHComp]
        let
          rhsTy :: NamesT (TCMT IO) (Type'' Term Term)
rhsTy = NamesT (TCMT IO) (AbsN (Type'' Term Term))
dT NamesT (TCMT IO) (AbsN (Type'' Term Term))
-> [NamesT (TCMT IO) (SubstArg (Type'' Term Term))]
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
delta [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io])
        -- trD δ x φ (hcomp [hφ ↦ u] u0) ↦ rhsHComp
        let rhsHComp :: NamesT (TCMT IO) Term
rhsHComp = do
              let [NamesT (TCMT IO) Term
hphi,NamesT (TCMT IO) Term
u,NamesT (TCMT IO) Term
u0] = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
as0
              -- TODO: should trD be transp for the datatype?
              let baseHComp :: NamesT (TCMT IO) Term
baseHComp = NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trD 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)))]
delta 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))]
x 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)
phi,NamesT (TCMT IO) Term
NamesT (TCMT IO) (SubstArg Term)
u0]
              let sideHComp :: NamesT (TCMT IO) Term
sideHComp = [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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
                     NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trD 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)))]
delta 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))]
x 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)
phi,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) (Type'' Term Term)
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
hcomp NamesT (TCMT IO) (Type'' Term Term)
rhsTy [(NamesT (TCMT IO) Term
hphi, NamesT (TCMT IO) Term
sideHComp)] NamesT (TCMT IO) Term
baseHComp
        (,,) ([Arg (Named_ (Pattern' DBPatVar))]
 -> Type'' Term Term
 -> Term
 -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
-> NamesT
     (TCMT IO)
     (Type'' Term Term
      -> Term
      -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
psHComp NamesT
  (TCMT IO)
  (Type'' Term Term
   -> Term
   -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT (TCMT IO) (Type'' Term Term)
-> NamesT
     (TCMT IO)
     (Term
      -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term 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) (Type'' Term Term)
rhsTy NamesT
  (TCMT IO)
  (Term
   -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT (TCMT IO) Term
-> NamesT
     (TCMT IO)
     ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term 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
rhsHComp
      let (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ res
      (:[]) <$> mkClause gamma ps rhsTy rhs


  c_trX   <- caseMaybe mtrX (pure []) $ \ QName
trX -> do
        [Char] -> Int -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Int
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"======================="
        [Char] -> Int -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Int
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
trX
        gamma <- Names
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
-> TCMT IO (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
 -> TCMT IO (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
-> TCMT IO (Tele (Dom (Type'' Term Term)))
forall a b. (a -> b) -> a -> b
$ do
                     ixsI <- AbsN (Tele (Dom (Type'' Term Term)))
-> NamesT
     (TCMT IO) (NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term)))))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (AbsN (Tele (Dom (Type'' Term Term)))
 -> NamesT
      (TCMT IO)
      (NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))))
-> AbsN (Tele (Dom (Type'' Term Term)))
-> NamesT
     (TCMT IO) (NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term)))))
forall a b. (a -> b) -> a -> b
$ Names
-> Tele (Dom (Type'' Term Term))
-> AbsN (Tele (Dom (Type'' Term Term)))
forall a. Names -> a -> AbsN a
AbsN (Tele (Dom (Type'' Term Term)) -> Names
teleNames Tele (Dom (Type'' Term Term))
parI) Tele (Dom (Type'' Term Term))
ixsI
                     parI <- open parI
                     abstract_trD $ \ Vars (TCMT IO)
delta Vars (TCMT IO)
_ Vars (TCMT IO)
_ -> do
                     let delta0_refl :: [NamesT (TCMT IO) Term]
delta0_refl = [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)
delta ((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 -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> 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) (Tele (Dom (Type'' Term Term)))
-> (Vars (TCMT IO)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *) a.
(Monad m, Abstract a) =>
NamesT m (Tele (Dom (Type'' Term Term)))
-> (Vars m -> NamesT m a) -> NamesT m a
abstractN (NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
ixsI NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom (Type'' Term Term))))]
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term 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 (Tele (Dom (Type'' Term Term))))]
delta0_refl) ((Vars (TCMT IO)
  -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
 -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> (Vars (TCMT IO)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
x' -> do
                     NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
-> (Vars (TCMT IO)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *) a.
(Monad m, Abstract a) =>
NamesT m (Tele (Dom (Type'' Term Term)))
-> (Vars m -> NamesT m a) -> NamesT m a
abstractN (Tele (Dom (Type'' Term Term))
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tele (Dom (Type'' Term Term))
 -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> Tele (Dom (Type'' Term Term))
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
forall a b. (a -> b) -> a -> b
$ [Char] -> Tele (Dom (Type'' Term Term))
intervalTel [Char]
"phi'") ((Vars (TCMT IO)
  -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
 -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> (Vars (TCMT IO)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
_ -> do
                     ty <- NamesT (TCMT IO) (AbsN (Type'' Term Term))
dT NamesT (TCMT IO) (AbsN (Type'' Term Term))
-> [NamesT (TCMT IO) (SubstArg (Type'' Term Term))]
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
delta0_refl [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
Vars (TCMT IO)
x' [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz])
                     pure $ ExtendTel (defaultDom ty) $ Abs "t" EmptyTel
        res <- runNamesT [] $
          bind_trD $ \ ArgVars (TCMT IO)
delta_ps ArgVars (TCMT IO)
x_ps ArgVars (TCMT IO)
phi_ps -> do
          let x :: [NamesT (TCMT IO) Term]
x = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
x_ps
          let delta :: [NamesT (TCMT IO) Term]
delta = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
delta_ps
          let [NamesT (TCMT IO) Term
phi] = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
phi_ps
          --- pattern matching args below
          [Arg [Char]]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         (AbsN
            (AbsN
               ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))))
-> NamesT
     (TCMT IO)
     (AbsN
        (AbsN
           (AbsN
              ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))))
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg ((Arg [Char] -> Arg [Char]) -> [Arg [Char]] -> [Arg [Char]]
forall a b. (a -> b) -> [a] -> [b]
map' (([Char] -> [Char]) -> Arg [Char] -> Arg [Char]
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! [Char]
"'")) (Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
teleArgNames Tele (Dom (Type'' Term Term))
ixsI)) ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO)
       (AbsN
          (AbsN
             ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))))
 -> NamesT
      (TCMT IO)
      (AbsN
         (AbsN
            (AbsN
               ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term)))))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         (AbsN
            (AbsN
               ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))))
-> NamesT
     (TCMT IO)
     (AbsN
        (AbsN
           (AbsN
              ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
x'_ps -> do
          let x' :: [NamesT (TCMT IO) Term]
x' = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
x'_ps :: [NamesT TCM Term]
          let phi'name :: [Arg [Char]]
phi'name = Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
teleArgNames (Tele (Dom (Type'' Term Term)) -> [Arg [Char]])
-> Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
forall a b. (a -> b) -> a -> b
$ [Char] -> Tele (Dom (Type'' Term Term))
intervalTel [Char]
"phi'"
          [Arg [Char]]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         (AbsN
            ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term)))
-> NamesT
     (TCMT IO)
     (AbsN
        (AbsN
           ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term)))
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg [Char]]
phi'name ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO)
       (AbsN
          ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term)))
 -> NamesT
      (TCMT IO)
      (AbsN
         (AbsN
            ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         (AbsN
            ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term)))
-> NamesT
     (TCMT IO)
     (AbsN
        (AbsN
           ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term)))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
phi'_ps -> do
          let phi's :: [NamesT (TCMT IO) Term]
phi's = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
phi'_ps
          [Arg [Char]]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT
     (TCMT IO)
     (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [[Char] -> Arg [Char]
forall e. e -> Arg e
argN [Char]
"t"] ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO)
       ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
 -> NamesT
      (TCMT IO)
      (AbsN
         ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term)))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT
     (TCMT IO)
     (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
as0 -> do
          let deltaArg :: NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Arg Term]
deltaArg NamesT (TCMT IO) Term
i = do
                i <- NamesT (TCMT IO) Term
i
                xs <- sequence delta_ps
                pure $ map' (fmap (`apply` [argN i])) xs

          let
            origPTrX :: NamesT (TCMT IO) (Pattern' DBPatVar)
origPTrX = do
              x'_ps <- [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
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) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
x'_ps
              phi'_ps <- sequence phi'_ps
              ds <- map' (setHiding Hidden . fmap (unnamed . dotP)) <$> deltaArg (pure iz)
              ps0 <- sequence as0
              unless (length ps0 == 1) __IMPOSSIBLE__
              pure $ DefP defaultPatternInfo trX $ ds ++! x'_ps ++! phi'_ps ++! ps0
            psTrX :: NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
psTrX = [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
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) (Arg (Named_ (Pattern' DBPatVar)))]
 -> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))])
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
forall a b. (a -> b) -> a -> b
$ [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
delta_ps [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
x_ps [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
phi_ps [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
forall a. [a] -> [a] -> [a]
++! [Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar))
forall e. e -> Arg e
argN (Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar)))
-> (Pattern' DBPatVar -> Named_ (Pattern' DBPatVar))
-> Pattern' DBPatVar
-> Arg (Named_ (Pattern' DBPatVar))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern' DBPatVar -> Named_ (Pattern' DBPatVar)
forall a name. a -> Named name a
unnamed (Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar)))
-> NamesT (TCMT IO) (Pattern' DBPatVar)
-> NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Pattern' DBPatVar)
origPTrX]

            rhsTy :: NamesT (TCMT IO) (Type'' Term Term)
rhsTy = NamesT (TCMT IO) (AbsN (Type'' Term Term))
dT NamesT (TCMT IO) (AbsN (Type'' Term Term))
-> [NamesT (TCMT IO) (SubstArg (Type'' Term Term))]
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
delta [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io])

          -- trD δ x φ (trX x' φ' t) ↦ rhsTrx
          let rhsTrX :: NamesT (TCMT IO) Term
rhsTrX = do
                let [NamesT (TCMT IO) Term
t] = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
as0
                let [NamesT (TCMT IO) Term
phi'] = [NamesT (TCMT IO) Term]
phi's
                let telXdeltai :: NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
telXdeltai = [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
 -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom (Type'' Term Term))))]
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
applyN NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
xTel ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i) [NamesT (TCMT IO) Term]
delta)
                let reflx1 :: [NamesT (TCMT IO) Term]
reflx1 = [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]
x ((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
q -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
q 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
io
                let symx' :: [NamesT (TCMT IO) Term]
symx' = [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]
x' ((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
q' -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> NamesT (TCMT IO) Term
q' 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
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg NamesT (TCMT IO) Term
i
                x_tr <- (Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Arg 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.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) ([Arg Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathTel' NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
telXdeltai [NamesT (TCMT IO) Term]
symx' [NamesT (TCMT IO) Term]
reflx1 NamesT (TCMT IO) Term
phi' [NamesT (TCMT IO) Term]
x
                let baseTrX = NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trD 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)))]
delta 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))]
x_tr 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
phi 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
phi',NamesT (TCMT IO) Term
NamesT (TCMT IO) (SubstArg Term)
t]
                let sideTrX = [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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 -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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
                      let trD_f :: NamesT (TCMT IO) Term
trD_f = NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
trD 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) 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]
delta (\ NamesT (TCMT IO) Term
p -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> 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
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 -> 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
j))
                                      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) 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]
x_tr (\ NamesT (TCMT IO) Term
p -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> 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
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 -> 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
j))
                                      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
phi 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
phi') 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) (SubstArg Term)
t]
                      let x_tr_f :: NamesT (TCMT IO) [Arg Term]
x_tr_f = (Abs [Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg 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 ((Abs (Arg Term) -> Arg Term) -> [Abs (Arg Term)] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Abs [Char]
n (Arg ArgInfo
i Term
t)) -> ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo ([Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
n Term
t)) ([Abs (Arg Term)] -> [Arg Term])
-> (Abs [Arg Term] -> [Abs (Arg Term)])
-> Abs [Arg Term]
-> [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs [Arg Term] -> [Abs (Arg Term)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => Abs (m a) -> m (Abs a)
sequence) (NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> a -> b
$
                           [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) [Arg Term])
 -> NamesT (TCMT IO) (Abs [Arg Term]))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> do
                            j <- NamesT (TCMT IO) Term
j
                            map' (fmap (`apply` [argN j])) <$> trFillPathTel' telXdeltai symx' reflx1 phi' x (neg i)
                      let args :: NamesT (TCMT IO) [Arg Term]
args = ([Arg Term] -> [Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
(++) ((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map' (Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) ([Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Arg Term]
deltaArg (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)) NamesT (TCMT IO) [Arg Term]
x_tr_f
                      (Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply (QName -> [Elim' Term] -> Term
Def QName
trX []) ([Arg Term] -> 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]
args) 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 :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
`max` NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg 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
trD_f
                hcomp rhsTy [(phi,sideTrX),(phi',lam "i" $ \ NamesT (TCMT IO) Term
_ -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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
baseTrX)]
                            baseTrX

          (,,) ([Arg (Named_ (Pattern' DBPatVar))]
 -> Type'' Term Term
 -> Term
 -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
-> NamesT
     (TCMT IO)
     (Type'' Term Term
      -> Term
      -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
psTrX NamesT
  (TCMT IO)
  (Type'' Term Term
   -> Term
   -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT (TCMT IO) (Type'' Term Term)
-> NamesT
     (TCMT IO)
     (Term
      -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term 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) (Type'' Term Term)
rhsTy NamesT
  (TCMT IO)
  (Term
   -> ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT (TCMT IO) Term
-> NamesT
     (TCMT IO)
     ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term 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
rhsTrX


        let (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ unAbsN $ unAbsN $ res
        (:[]) <$> mkClause gamma ps rhsTy rhs

  fmap ((c_HComp ++! c_trX) ++) $ forM cnames $ \ QName
cname -> do
    def <- QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
cname
    let
      Constructor
       { conPars = npars'
       , conArity = nargs
       , conSrcCon = chead
       } = theDef def
    do
        let tcon = Definition -> Type'' Term Term
defType Definition
def

        reportSDoc "tc.data.transp.con" 20 $ "======================="
        reportSDoc "tc.data.transp.con" 20 $ "tcon:" <+> prettyTCM (conName chead) <+> prettyTCM tcon

        unless (conName chead == cname && npars' == npars) $ __IMPOSSIBLE__


        TelV prm tcon' <- telViewUpTo npars' tcon
        -- Δ ⊢ aTel
        -- Δ.aTel ⊢ ty
        -- Δ.aTel ⊢ [(φ,(l,r))] = boundary : ty
        (TelV aTel ty, boundary) <- telViewUpToPathBoundary nargs tcon'

        Def _ es <- unEl <$> reduce ty
        -- Δ.aTel ⊢ con_ixs : X
        let con_ixs = [Elim' Term] -> [Arg Term]
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims ([Elim' Term] -> [Arg Term]) -> [Elim' Term] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$ Int -> [Elim' Term] -> [Elim' Term]
forall a. Int -> [a] -> [a]
drop Int
npars [Elim' Term]
es

        reportSDoc "tc.data.transp.con" 20 $
          addContext prm $ "aTel:" <+> prettyTCM aTel
        reportSDoc "tc.data.transp.con" 20 $
          addContext prm $ addContext aTel $ "ty:" <+> prettyTCM ty
        reportSDoc "tc.data.transp.con" 20 $
          addContext prm $ addContext aTel $ "boundary:" <+> prettyTCM boundary

        gamma <- runNamesT [] $ do
                     ixsI <- open $ AbsN (teleNames parI) ixsI
                     aTel <- open $ AbsN (teleNames prm) aTel
                     parI <- open parI
                     abstract_trD $ \ Vars (TCMT IO)
delta Vars (TCMT IO)
_ Vars (TCMT IO)
_ -> do
                     let args :: NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
args = NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
aTel NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom (Type'' Term Term))))]
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term 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) Term)
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (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]
Vars (TCMT IO)
delta
                     NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
args
        res <- runNamesT [] $ do
          let aTelNames = Tele (Dom (Type'' Term Term)) -> Names
teleNames Tele (Dom (Type'' Term Term))
aTel
              aTelArgs = Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
teleArgNames Tele (Dom (Type'' Term Term))
aTel
          con_ixs <- open $ AbsN (teleNames prm ++! teleNames aTel) $ map' unArg con_ixs
          bndry <- open $ AbsN (teleNames prm ++! teleNames aTel) $ tmBoundary boundary
          u    <- open $ AbsN (teleNames prm ++! aTelNames) $ Con chead ConOSystem (teleElims aTel boundary)
          aTel <- open $ AbsN (teleNames prm) aTel
          -- bsys : Abs Δ.Args ([phi] → ty)
          (bsysFace,bsys) <- do
            p <- bindN (teleNames prm ++! aTelNames) $ \ Vars (TCMT IO)
ts -> do
              LEl l ty <- LType -> Maybe LType -> LType
forall a. a -> Maybe a -> a
fromMaybe LType
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe LType -> LType)
-> NamesT (TCMT IO) (Maybe LType) -> NamesT (TCMT IO) LType
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type'' Term Term -> NamesT (TCMT IO) (Maybe LType)
forall (m :: * -> *).
MonadReduce m =>
Type'' Term Term -> m (Maybe LType)
toLType Type'' Term Term
ty
              l <- open (Level l)
              ty <- open ty
              bs <- bndry `applyN` ts
              xs <- mapM (\(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) Term, NamesT (TCMT IO) Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
phi NamesT
  (TCMT IO)
  (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) 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) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u) $ do
                (i,(l,r)) <- theBoundary bs
                let pElem Term
t = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultIrrelevantArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
NoAbs [Char]
"o" Term
t
                [(tINeg `apply` [argN i],pElem l),(i,pElem r)]
              combineSys' l ty xs
            (,) <$> open (fst <$> p) <*> open (snd <$> p)
          bind_trD $ \ ArgVars (TCMT IO)
delta_ps ArgVars (TCMT IO)
x_ps ArgVars (TCMT IO)
phi_ps -> do
          let x :: [NamesT (TCMT IO) Term]
x = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
x_ps
          let delta :: [NamesT (TCMT IO) Term]
delta = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
delta_ps
          let [NamesT (TCMT IO) Term
phi] = (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
phi_ps
          --- pattern matching args below
          [Arg [Char]]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT
     (TCMT IO)
     (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
forall (m :: * -> *) a.
Monad m =>
[Arg [Char]] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg [Char]]
aTelArgs ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO)
       ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
 -> NamesT
      (TCMT IO)
      (AbsN
         ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term)))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
-> NamesT
     (TCMT IO)
     (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type'' Term Term, Term))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
as0 -> do -- as0 : aTel[delta 0]

          let aTel0 :: NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
aTel0 = NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
aTel NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom (Type'' Term Term))))]
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term 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) Term)
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (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]
delta

          -- telePatterns is not context invariant, so we need an open here where the context ends in aTel0.
          ps0 <- ([Arg (Named_ (Pattern' DBPatVar))]
-> NamesT
     (TCMT IO) (NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))])
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Arg (Named_ (Pattern' DBPatVar))]
 -> NamesT
      (TCMT IO) (NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]))
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
-> NamesT
     (TCMT IO) (NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
 -> NamesT
      (TCMT IO) (NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]))
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
-> NamesT
     (TCMT IO) (NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))])
forall a b. (a -> b) -> a -> b
$ (Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [Arg (Named_ (Pattern' DBPatVar))]
forall a.
DeBruijn a =>
Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [NamedArg (Pattern' a)]
telePatterns (Tele (Dom (Type'' Term Term))
 -> Boundary' Int Term -> [Arg (Named_ (Pattern' DBPatVar))])
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
-> NamesT
     (TCMT IO)
     (Boundary' Int Term -> [Arg (Named_ (Pattern' DBPatVar))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
aTel0 NamesT
  (TCMT IO)
  (Boundary' Int Term -> [Arg (Named_ (Pattern' DBPatVar))])
-> NamesT (TCMT IO) (Boundary' Int Term)
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
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
<*> (Boundary' Term Term -> Boundary' Int Term
forall a. Boundary' Term a -> Boundary' Int a
varBoundary (Boundary' Term Term -> Boundary' Int Term)
-> NamesT (TCMT IO) (Boundary' Term Term)
-> NamesT (TCMT IO) (Boundary' Int Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (AbsN (Boundary' Term Term))
-> [NamesT (TCMT IO) (SubstArg (Boundary' Term Term))]
-> NamesT (TCMT IO) (Boundary' Term Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
applyN NamesT (TCMT IO) (AbsN (Boundary' Term Term))
bndry ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (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]
delta [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! (NamesT (TCMT IO) (Arg Term) -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (Arg Term)] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' ((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)]
ArgVars (TCMT IO)
as0)))

          let deltaArg NamesT (TCMT IO) Term
i = do
                i <- NamesT (TCMT IO) Term
i
                xs <- sequence delta_ps
                pure $ map' (fmap (`apply` [argN i])) xs

          let
            origP = ConHead
-> ConPatternInfo
-> [Arg (Named_ (Pattern' DBPatVar))]
-> Pattern' DBPatVar
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
chead ConPatternInfo
noConPatternInfo ([Arg (Named_ (Pattern' DBPatVar))] -> Pattern' DBPatVar)
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
-> NamesT (TCMT IO) (Pattern' DBPatVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
ps0
            ps = [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
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) (Arg (Named_ (Pattern' DBPatVar)))]
 -> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))])
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
forall a b. (a -> b) -> a -> b
$ [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
delta_ps [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
x_ps [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
ArgVars (TCMT IO)
phi_ps [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
-> [NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))]
forall a. [a] -> [a] -> [a]
++! [Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar))
forall e. e -> Arg e
argN (Named_ (Pattern' DBPatVar) -> Arg (Named_ (Pattern' DBPatVar)))
-> (Pattern' DBPatVar -> Named_ (Pattern' DBPatVar))
-> Pattern' DBPatVar
-> Arg (Named_ (Pattern' DBPatVar))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern' DBPatVar -> Named_ (Pattern' DBPatVar)
forall a name. a -> Named name a
unnamed (Pattern' DBPatVar -> Arg (Named_ (Pattern' DBPatVar)))
-> NamesT (TCMT IO) (Pattern' DBPatVar)
-> NamesT (TCMT IO) (Arg (Named_ (Pattern' DBPatVar)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Pattern' DBPatVar)
origP]
          let
            orig = Pattern' DBPatVar -> Term
patternToTerm (Pattern' DBPatVar -> Term)
-> NamesT (TCMT IO) (Pattern' DBPatVar) -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Pattern' DBPatVar)
origP
            rhsTy = NamesT (TCMT IO) (AbsN (Type'' Term Term))
dT NamesT (TCMT IO) (AbsN (Type'' Term Term))
-> [NamesT (TCMT IO) (SubstArg (Type'' Term Term))]
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
delta [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io])

          (,,) <$> ps <*> rhsTy <*> do

          -- Declared Constructors.
          let aTelI = [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
 -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
aTel NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom (Type'' Term Term))))]
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term 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) Term)
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i) [NamesT (TCMT IO) Term]
delta

          eas1 <- (=<<) (lift . runExceptT) $ transpTel <$> aTelI <*> phi <*> sequence as0

          caseEitherM (pure eas1) (lift . lift . E.throw . CannotTransp) $ \ [Arg Term]
as1 -> do

          as1 <- (Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Arg 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.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term]
as1

          as01 <- (open =<<) $ bind "i" $ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> do
            eas01 <- (ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term]
 -> NamesT
      (TCMT IO) (Either (Closure (Abs (Type'' Term Term))) [Arg Term]))
-> NamesT
     (TCMT IO)
     (ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term])
-> NamesT
     (TCMT IO) (Either (Closure (Abs (Type'' Term Term))) [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) (TCMT IO (Either (Closure (Abs (Type'' Term Term))) [Arg Term])
-> NamesT
     (TCMT IO) (Either (Closure (Abs (Type'' Term Term))) [Arg Term])
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO (Either (Closure (Abs (Type'' Term Term))) [Arg Term])
 -> NamesT
      (TCMT IO) (Either (Closure (Abs (Type'' Term Term))) [Arg Term]))
-> (ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term]
    -> TCMT IO (Either (Closure (Abs (Type'' Term Term))) [Arg Term]))
-> ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term]
-> NamesT
     (TCMT IO) (Either (Closure (Abs (Type'' Term Term))) [Arg Term])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term]
-> TCMT IO (Either (Closure (Abs (Type'' Term Term))) [Arg Term])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT) (NamesT
   (TCMT IO)
   (ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term])
 -> NamesT
      (TCMT IO) (Either (Closure (Abs (Type'' Term Term))) [Arg Term]))
-> NamesT
     (TCMT IO)
     (ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term])
-> NamesT
     (TCMT IO) (Either (Closure (Abs (Type'' Term Term))) [Arg Term])
forall a b. (a -> b) -> a -> b
$ Abs (Tele (Dom (Type'' Term Term)))
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term]
trFillTel (Abs (Tele (Dom (Type'' Term Term)))
 -> Term
 -> [Arg Term]
 -> Term
 -> ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
-> NamesT
     (TCMT IO)
     (Term
      -> [Arg Term]
      -> Term
      -> ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
aTelI NamesT
  (TCMT IO)
  (Term
   -> [Arg Term]
   -> Term
   -> ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) Term
-> NamesT
     (TCMT IO)
     ([Arg Term]
      -> Term
      -> ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg 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
phi NamesT
  (TCMT IO)
  ([Arg Term]
   -> Term
   -> ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) [Arg Term]
-> NamesT
     (TCMT IO)
     (Term
      -> ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg 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) (Arg Term)] -> NamesT (TCMT IO) [Arg 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) (Arg Term)]
ArgVars (TCMT IO)
as0 NamesT
  (TCMT IO)
  (Term
   -> ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) Term
-> NamesT
     (TCMT IO)
     (ExceptT (Closure (Abs (Type'' Term Term))) (TCMT IO) [Arg 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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i
            caseEitherM (pure eas01) (lift . lift . E.throw . CannotTransp) pure

          let argApp m (f b)
a m Term
t = (f b -> Term -> f b) -> m (f b) -> m Term -> m (f b)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (\ f b
a Term
t -> (b -> b) -> f b -> f b
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (b -> [Arg Term] -> b
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
t]) f b
a) m (f b)
a m Term
t
          let
            argLam :: Monad m => String -> (Var m -> NamesT m (Arg Term)) -> NamesT m (Arg Term)
            argLam [Char]
n Var m -> NamesT m (Arg Term)
f = (\ (Abs [Char]
n (Arg ArgInfo
i Term
t)) -> ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
n Term
t) (Abs (Arg Term) -> Arg Term)
-> NamesT m (Abs (Arg Term)) -> NamesT m (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
-> (Var m -> NamesT m (Arg Term)) -> NamesT m (Abs (Arg Term))
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"n" Var m -> NamesT m (Arg Term)
f
          let cas1 = 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)
u ([NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (SubstArg 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]
forall a b. (a -> b) -> [a] -> [b]
map' (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
io) [NamesT (TCMT IO) Term]
delta [NamesT (TCMT IO) (SubstArg Term)]
-> [NamesT (TCMT IO) (SubstArg Term)]
-> [NamesT (TCMT IO) (SubstArg Term)]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
[NamesT (TCMT IO) (SubstArg Term)]
as1

          let base | Maybe QName
Nothing <- Maybe QName
mtrX = NamesT (TCMT IO) Term
cas1
                   | Just QName
trX <- Maybe QName
mtrX = do
                       let theTel :: NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
theTel = [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
-> NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"j" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
 -> NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term))))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
-> NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
 -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom (Type'' Term Term))))]
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
applyN NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
xTel ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i NamesT (TCMT IO) Term
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j) [NamesT (TCMT IO) Term]
delta)
                       let theLeft :: NamesT (TCMT IO) [Term]
theLeft = 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
$ [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) [Term])
 -> NamesT (TCMT IO) (Abs [Term]))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> do
                             as01 <- (Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Arg 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.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) ([Arg Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Abs [Arg Term] -> Term -> [Arg Term]
Abs [Arg Term] -> SubstArg [Arg Term] -> [Arg Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Arg Term] -> Term -> [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
-> NamesT (TCMT IO) (Term -> [Arg Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Arg Term])
as01 NamesT (TCMT IO) (Term -> [Arg Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Arg 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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i)
                             con_ixs `applyN` (map' (<@> i) delta ++! as01)
                       theLeft <- (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.
(Monad 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]
theLeft
                       theRight <- (mapM open =<<) $ lamTel $ bind "i" $ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> do
                         NamesT (TCMT IO) (AbsN [Term])
con_ixs 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) Term)
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (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
io) [NamesT (TCMT IO) Term]
delta [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
as1)

                       trx' <- transpPathPTel' theTel x theRight phi theLeft
                       let args = ([Arg Term] -> [Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
(++) ((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map' (Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) ([Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Arg Term]
deltaArg (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)) ([Arg Term]
-> (Arg Term -> NamesT (TCMT IO) (Arg Term))
-> NamesT (TCMT IO) [Arg Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Arg Term]
trx' ((Arg Term -> NamesT (TCMT IO) (Arg Term))
 -> NamesT (TCMT IO) [Arg Term])
-> (Arg Term -> NamesT (TCMT IO) (Arg Term))
-> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> a -> b
$ \ Arg Term
q' -> do
                                                                       q' <- Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) (Arg Term))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open Arg Term
q'
                                                                       argLam "i" $ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> NamesT (TCMT IO) (Arg Term)
q' NamesT (TCMT IO) (Arg Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Arg Term)
forall {m :: * -> *} {b} {f :: * -> *}.
(Monad m, Apply b, Functor f) =>
m (f b) -> m Term -> m (f b)
`argApp` 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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i)
                       (apply (Def trX []) <$> args) <@> phi <@> cas1


          if null boundary then base else do

          -- We have to correct the boundary for path constructors.

          -- bline : Abs I ([phi] → ty)
          let blineFace = 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)
bsysFace ([NamesT (TCMT IO) (SubstArg Term)] -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) (SubstArg 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]
forall a b. (a -> b) -> [a] -> [b]
map' (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
io) [NamesT (TCMT IO) Term]
delta [NamesT (TCMT IO) (SubstArg Term)]
-> [NamesT (TCMT IO) (SubstArg Term)]
-> [NamesT (TCMT IO) (SubstArg Term)]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
[NamesT (TCMT IO) (SubstArg Term)]
as1
          let bline = do
                let theTel :: NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
theTel = [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
-> NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"j" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
 -> NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term))))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
-> NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
 -> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term)))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term))))
-> NamesT (TCMT IO) (Abs (Tele (Dom (Type'' Term Term))))
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom (Type'' Term Term))))]
-> NamesT (TCMT IO) (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
applyN NamesT (TCMT IO) (AbsN (Tele (Dom (Type'' Term Term))))
xTel ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i NamesT (TCMT IO) Term
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j) [NamesT (TCMT IO) Term]
delta)
                let theLeft :: NamesT (TCMT IO) [Term]
theLeft = 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
$ [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) [Term])
 -> NamesT (TCMT IO) (Abs [Term]))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> do
                      as01 <- (Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Arg 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.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) ([Arg Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Abs [Arg Term] -> Term -> [Arg Term]
Abs [Arg Term] -> SubstArg [Arg Term] -> [Arg Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Arg Term] -> Term -> [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
-> NamesT (TCMT IO) (Term -> [Arg Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Arg Term])
as01 NamesT (TCMT IO) (Term -> [Arg Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Arg 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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i)
                      con_ixs `applyN` (map' (<@> i) delta ++! as01)
                theLeft <- (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.
(Monad 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]
theLeft
                theRight <- (mapM open =<<) $ lamTel $ bind "i" $ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> do
                  NamesT (TCMT IO) (AbsN [Term])
con_ixs 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) Term)
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> [a] -> [b]
map' (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
io) [NamesT (TCMT IO) Term]
delta [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term] -> [NamesT (TCMT IO) Term]
forall a. [a] -> [a] -> [a]
++! [NamesT (TCMT IO) Term]
as1)
                let q2_f = [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) [Term])
 -> NamesT (TCMT IO) (Abs [Term]))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> (Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg ([Arg Term] -> [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) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) [Arg Term]
trFillPathPTel' NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
theTel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
theRight NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
theLeft NamesT (TCMT IO) Term
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i

                lam "i" $ \ NamesT (TCMT IO) Term
i -> do
                let v0 :: NamesT (TCMT IO) Term
v0 = do
                     as01 <- (Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Arg 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.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) ([Arg Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Abs [Arg Term] -> Term -> [Arg Term]
Abs [Arg Term] -> SubstArg [Arg Term] -> [Arg Term]
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs [Arg Term] -> Term -> [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
-> NamesT (TCMT IO) (Term -> [Arg Term])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs [Arg Term])
as01 NamesT (TCMT IO) (Term -> [Arg Term])
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Arg 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)
                     applyN bsys $ map' (<@> i) delta ++! as01
                let squeezedv0 :: NamesT (TCMT IO) Term
squeezedv0 = [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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
                      let
                        delta_f :: [NamesT TCM Term]
                        delta_f :: [NamesT (TCMT IO) Term]
delta_f = [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]
delta ((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 -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
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
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)
                      x_f <- ((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.
(Monad 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
$ [Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
Monad m =>
[Char]
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind [Char]
"j" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) [Term])
 -> NamesT (TCMT IO) (Abs [Term]))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
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])
q2_f 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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j) 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
i
                      trD `applyN` delta_f `applyN` x_f `applyN` [phi `max` i, v0 <..> o]

                Maybe QName
-> NamesT (TCMT IO) Term
-> (QName -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe QName
mtrX NamesT (TCMT IO) Term
squeezedv0 ((QName -> NamesT (TCMT IO) Term) -> NamesT (TCMT IO) Term)
-> (QName -> NamesT (TCMT IO) Term) -> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ QName
trX -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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
                  q2 <- NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathPTel' NamesT (TCMT IO) (Abs (Abs (Tele (Dom (Type'' Term Term)))))
theTel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
theRight NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
theLeft
                  let args = ([Arg Term] -> [Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
(++) ((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map' (Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) ([Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) [Arg Term]
deltaArg (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io))
                                         ([Arg Term]
-> (Arg Term -> NamesT (TCMT IO) (Arg Term))
-> NamesT (TCMT IO) [Arg Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Arg Term]
q2 ((Arg Term -> NamesT (TCMT IO) (Arg Term))
 -> NamesT (TCMT IO) [Arg Term])
-> (Arg Term -> NamesT (TCMT IO) (Arg Term))
-> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> a -> b
$ \ Arg Term
q' -> do
                                            q' <- Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) (Arg Term))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open Arg Term
q'
                                            argLam "j" $ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> NamesT (TCMT IO) (Arg Term)
q' NamesT (TCMT IO) (Arg Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Arg Term)
forall {m :: * -> *} {b} {f :: * -> *}.
(Monad m, Apply b, Functor f) =>
m (f b) -> m Term -> m (f b)
`argApp` (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
forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
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
i))

                  (apply (Def trX []) <$> args) <@> (neg i `max` phi) <@> (squeezedv0 <..> o)
          hcomp
             rhsTy
             [(blineFace,lam "i" $ \ NamesT (TCMT IO) Term
i -> NamesT (TCMT IO) Term
bline 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
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg NamesT (TCMT IO) Term
i))
             ,(phi      ,lam "i" $ \ NamesT (TCMT IO) Term
_ -> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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
orig)
             ]
             base

        let
          (ps,rhsTy,rhs) = unAbsN $ unAbsN $ unAbsN $ unAbsN $ res
        mkClause gamma ps rhsTy rhs
  where
    mkClause :: Tele (Dom (Type'' Term Term))
-> [Arg (Named_ (Pattern' DBPatVar))]
-> Type'' Term Term
-> Term
-> m Clause
mkClause Tele (Dom (Type'' Term Term))
gamma [Arg (Named_ (Pattern' DBPatVar))]
ps Type'' Term Term
rhsTy Term
rhs = do
      let
        c :: Clause
c = Clause
            { clauseTel :: Tele (Dom (Type'' Term Term))
clauseTel         = Tele (Dom (Type'' Term Term))
gamma
            , clauseType :: Maybe (Arg (Type'' Term Term))
clauseType        = Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term))
forall a. a -> Maybe a
Just (Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term)))
-> (Type'' Term Term -> Arg (Type'' Term Term))
-> Type'' Term Term
-> Maybe (Arg (Type'' Term Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type'' Term Term -> Arg (Type'' Term Term)
forall e. e -> Arg e
argN (Type'' Term Term -> Maybe (Arg (Type'' Term Term)))
-> Type'' Term Term -> Maybe (Arg (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ Type'' Term Term
rhsTy
            , namedClausePats :: [Arg (Named_ (Pattern' DBPatVar))]
namedClausePats   = [Arg (Named_ (Pattern' DBPatVar))]
ps
            , clauseFullRange :: Range
clauseFullRange   = Range
forall a. Range' a
noRange
            , clauseLHSRange :: Range
clauseLHSRange    = Range
forall a. Range' a
noRange
            , clauseCatchall :: Catchall
clauseCatchall    = Catchall
forall a. Null a => a
empty
            , 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
            , clauseRecursive :: ClauseRecursive
clauseRecursive   = ClauseRecursive
MaybeRecursive
            -- it is indirectly recursive through transp, does it count?
            , 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
            }
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
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
<+> Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
gamma
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
gamma (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"ps   :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Elim' Term] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Elim' Term] -> m Doc
prettyTCM ([Arg (Named_ (Pattern' DBPatVar))] -> [Elim' Term]
patternsToElims [Arg (Named_ (Pattern' DBPatVar))]
ps)
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
gamma (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"type :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
rhsTy
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
gamma (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"body :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
rhs

      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Int
30 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$
        Tele (Dom (Type'' Term Term)) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
gamma (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"c:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Clause -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Clause
c
      Clause -> m Clause
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Clause
c


defineKanOperationForFields
  :: Command
  -> (Maybe Term)            -- ^ PathCons, Δ.Φ ⊢ u : R δ
  -> (Term -> QName -> Term) -- ^ how to apply a "projection" to a term
  -> QName       -- ^ some name, e.g. record name
  -> Telescope   -- ^ param types Δ
  -> Telescope   -- ^ fields' types Δ ⊢ Φ
  -> [Arg QName] -- ^ fields' names
  -> Type        -- ^ record type Δ ⊢ T
  -> TCM (Maybe ((QName, Telescope, Type, [Dom Type], [Term]), Substitution))
defineKanOperationForFields :: Command
-> Maybe Term
-> (Term -> QName -> Term)
-> QName
-> Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term))
-> [Arg QName]
-> Type'' Term Term
-> TCM
     (Maybe
        ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
          [Dom (Type'' Term Term)], [Term]),
         Substitution' Term))
defineKanOperationForFields Command
cmd Maybe Term
pathCons Term -> QName -> Term
project QName
name Tele (Dom (Type'' Term Term))
params Tele (Dom (Type'' Term Term))
fsT [Arg QName]
fns Type'' Term Term
rect =
   case Command
cmd of
       Command
DoTransp -> MaybeT
  (TCMT IO)
  ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
    [Dom (Type'' Term Term)], [Term]),
   Substitution' Term)
-> TCM
     (Maybe
        ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
          [Dom (Type'' Term Term)], [Term]),
         Substitution' Term))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   (TCMT IO)
   ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
     [Dom (Type'' Term Term)], [Term]),
    Substitution' Term)
 -> TCM
      (Maybe
         ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
           [Dom (Type'' Term Term)], [Term]),
          Substitution' Term)))
-> MaybeT
     (TCMT IO)
     ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
       [Dom (Type'' Term Term)], [Term]),
      Substitution' Term)
-> TCM
     (Maybe
        ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
          [Dom (Type'' Term Term)], [Term]),
         Substitution' Term))
forall a b. (a -> b) -> a -> b
$ do
         fsT' <- (Dom (Type'' Term Term) -> MaybeT (TCMT IO) (Dom CType))
-> Tele (Dom (Type'' Term Term))
-> MaybeT (TCMT IO) (Tele (Dom CType))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tele a -> f (Tele b)
traverse ((Type'' Term Term -> MaybeT (TCMT IO) CType)
-> Dom (Type'' Term Term) -> MaybeT (TCMT IO) (Dom CType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dom' Term a -> f (Dom' Term b)
traverse (TCMT IO (Maybe CType) -> MaybeT (TCMT IO) CType
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (TCMT IO (Maybe CType) -> MaybeT (TCMT IO) CType)
-> (Type'' Term Term -> TCMT IO (Maybe CType))
-> Type'' Term Term
-> MaybeT (TCMT IO) CType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type'' Term Term -> TCMT IO (Maybe CType)
forall (m :: * -> *).
MonadReduce m =>
Type'' Term Term -> m (Maybe CType)
toCType)) Tele (Dom (Type'' Term Term))
fsT
         lift $ defineTranspForFields pathCons project name params fsT' fns rect
       Command
DoHComp -> MaybeT
  (TCMT IO)
  ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
    [Dom (Type'' Term Term)], [Term]),
   Substitution' Term)
-> TCM
     (Maybe
        ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
          [Dom (Type'' Term Term)], [Term]),
         Substitution' Term))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   (TCMT IO)
   ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
     [Dom (Type'' Term Term)], [Term]),
    Substitution' Term)
 -> TCM
      (Maybe
         ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
           [Dom (Type'' Term Term)], [Term]),
          Substitution' Term)))
-> MaybeT
     (TCMT IO)
     ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
       [Dom (Type'' Term Term)], [Term]),
      Substitution' Term)
-> TCM
     (Maybe
        ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
          [Dom (Type'' Term Term)], [Term]),
         Substitution' Term))
forall a b. (a -> b) -> a -> b
$ do
         fsT' <- (Dom (Type'' Term Term) -> MaybeT (TCMT IO) (Dom LType))
-> Tele (Dom (Type'' Term Term))
-> MaybeT (TCMT IO) (Tele (Dom LType))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Tele a -> f (Tele b)
traverse ((Type'' Term Term -> MaybeT (TCMT IO) LType)
-> Dom (Type'' Term Term) -> MaybeT (TCMT IO) (Dom LType)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Dom' Term a -> f (Dom' Term b)
traverse (TCMT IO (Maybe LType) -> MaybeT (TCMT IO) LType
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT (TCMT IO (Maybe LType) -> MaybeT (TCMT IO) LType)
-> (Type'' Term Term -> TCMT IO (Maybe LType))
-> Type'' Term Term
-> MaybeT (TCMT IO) LType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type'' Term Term -> TCMT IO (Maybe LType)
forall (m :: * -> *).
MonadReduce m =>
Type'' Term Term -> m (Maybe LType)
toLType)) Tele (Dom (Type'' Term Term))
fsT
         rect' <- MaybeT $ toLType rect
         lift $ defineHCompForFields project name params fsT' fns rect'


-- invariant: resulting tel Γ is such that Γ = ... , (φ : I), (a0 : ...)
--            where a0 has type matching the arguments of primTrans.
defineTranspForFields
  :: (Maybe Term)            -- ^ PathCons, Δ.Φ ⊢ u : R δ
  -> (Term -> QName -> Term) -- ^ how to apply a "projection" to a term
  -> QName       -- ^ some name, e.g. record name
  -> Telescope   -- ^ param types Δ
  -> Tele (Dom CType)   -- ^ fields' types Δ ⊢ Φ
  -> [Arg QName] -- ^ fields' names
  -> Type        -- ^ record type Δ ⊢ T
  -> TCM ((QName, Telescope, Type, [Dom Type], [Term]), Substitution)
     -- ^ @((name, tel, rtype, clause_types, bodies), sigma)@
     --   name: name of transport function for this constructor/record. clauses still missing.
     --   tel: Ξ telescope for the RHS, Ξ ⊃ (Δ^I, φ : I), also Ξ ⊢ us0 : Φ[δ 0]
     --   rtype: Ξ ⊢ T' := T[δ 1]
     --   clause_types: Ξ ⊢ Φ' := Φ[δ 1]
     --   bodies: Ξ ⊢ us1 : Φ'
     --   sigma:  Ξ, i : I ⊢ σ : Δ.Φ -- line [δ 0,us0] ≡ [δ 0,us1]
defineTranspForFields :: Maybe Term
-> (Term -> QName -> Term)
-> QName
-> Tele (Dom (Type'' Term Term))
-> Tele (Dom CType)
-> [Arg QName]
-> Type'' Term Term
-> TCMT
     IO
     ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
       [Dom (Type'' Term Term)], [Term]),
      Substitution' Term)
defineTranspForFields Maybe Term
pathCons Term -> QName -> Term
applyProj QName
name Tele (Dom (Type'' Term Term))
params Tele (Dom CType)
fsT [Arg QName]
fns Type'' Term Term
rect = do
  interval <- TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m (Type'' Term Term)
primIntervalType
  let deltaI = Type'' Term Term
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
expTelescope Type'' Term Term
interval Tele (Dom (Type'' Term Term))
params
  iz <- primIZero
  io <- primIOne
  imin <- getPrimitiveTerm builtinIMin
  imax <- getPrimitiveTerm builtinIMax
  ineg <- getPrimitiveTerm builtinINeg
  transp <- getPrimitiveTerm builtinTrans
  -- por <- getPrimitiveTerm "primPOr"
  -- one <- primItIsOne
  reportSDoc "trans.rec" 20 $ pretty params
  reportSDoc "trans.rec" 20 $ pretty deltaI
  reportSDoc "trans.rec" 10 $ pretty fsT

  let thePrefix = [Char]
"transp-"
  theName <- freshAbstractQName'_ $ thePrefix ++! P.prettyShow (A.qnameName name)

  reportSLn "trans.rec" 5 $ ("Generated name: " ++! show theName ++! " " ++! showQNameId theName)

  theType <- (abstract deltaI <$>) $ runNamesT [] $ do
              rect' <- open (runNames [] $ bind "i" $ \ forall b. (Subst b, DeBruijn b) => NamesT Identity b
x -> let NamesT Identity Term
_ = NamesT Identity Term
forall b. (Subst b, DeBruijn b) => NamesT Identity b
x NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall a. a -> a -> a
`asTypeOf` Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term
forall a. HasCallStack => a
undefined :: Term) in
                                                             Type'' Term Term -> NamesT Identity (Type'' Term Term)
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type'' Term Term
rect')
              nPi' "phi" primIntervalType $ \ NamesT (TCMT IO) Term
phi ->
               (Abs (Type'' Term Term) -> Term -> Type'' Term Term
Abs (Type'' Term Term)
-> SubstArg (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Type'' Term Term) -> Term -> Type'' Term Term)
-> NamesT (TCMT IO) (Abs (Type'' Term Term))
-> NamesT (TCMT IO) (Term -> Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Type'' Term Term))
rect' NamesT (TCMT IO) (Term -> Type'' Term Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' 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
<*> 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) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *).
HasOptions m =>
m (Type'' Term Term)
-> m (Type'' Term Term) -> m (Type'' Term Term)
--> (Abs (Type'' Term Term) -> Term -> Type'' Term Term
Abs (Type'' Term Term)
-> SubstArg (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Type'' Term Term) -> Term -> Type'' Term Term)
-> NamesT (TCMT IO) (Abs (Type'' Term Term))
-> NamesT (TCMT IO) (Term -> Type'' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Type'' Term Term))
rect' NamesT (TCMT IO) (Term -> Type'' Term Term)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' 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
<*> Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)

  reportSDoc "trans.rec" 20 $ prettyTCM theType
  reportSDoc "trans.rec" 60 $ text $ "sort = " ++! show (getSort rect')

  lang <- getLanguage
  fun  <- emptyFunctionData
  noMutualBlock $ addConstant theName $
    (defaultDefn defaultArgInfo theName theType lang
       (FunctionDefn fun{ _funTerminates = Just True
                        , _funIsKanOp    = Just name
                        }))
      { defNoCompilation = True }
  -- ⊢ Γ = gamma = (δ : Δ^I) (φ : I) (u0 : R (δ i0))
  -- Γ ⊢     rtype = R (δ i1)
  TelV gamma rtype <- telView theType


  let
      -- (γ : Γ) ⊢ transpR γ : rtype
      theTerm = QName -> [Elim' Term] -> Term
Def QName
theName [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` Tele (Dom (Type'' Term Term)) -> [Arg Term]
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom (Type'' Term Term))
gamma

      -- (γ : Γ) ⊢ (flatten Φ[δ i1])[n ↦ f_n (transpR γ)]
      clause_types = [Term] -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a
parallelS [Term
theTerm Term -> QName -> Term
`applyProj` (Arg QName -> QName
forall e. Arg e -> e
unArg Arg QName
fn)
                               | Arg QName
fn <- [Arg QName] -> [Arg QName]
forall a. [a] -> [a]
reverse [Arg QName]
fns] Substitution' (SubstArg [Dom CType]) -> [Dom CType] -> [Dom CType]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst`
                       Tele (Dom CType) -> [Dom CType]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel (Int -> Term -> Substitution' Term
forall a. DeBruijn a => Int -> a -> Substitution' a
singletonS Int
0 Term
io Substitution' (SubstArg (Tele (Dom CType)))
-> Tele (Dom CType) -> Tele (Dom CType)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Tele (Dom CType)
fsT') -- Γ, Φ[δ i1] ⊢ flatten Φ[δ i1]

      -- Γ, i : I ⊢ [δ i] : Δ
      delta_i = (Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
liftS Int
1 (Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
deltaI)) Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
params) -- Defined but not used

      -- Γ, i : I ⊢ Φ[δ i]
      fsT' = (Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
liftS Int
1 (Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
deltaI)) Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
params)  Substitution' (SubstArg (Tele (Dom CType)))
-> Tele (Dom CType) -> Tele (Dom CType)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst`
               Tele (Dom CType)
fsT -- Δ ⊢ Φ
      lam_i = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Term -> Abs Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"i"



      -- (δ , φ , u0) : Γ ⊢ φ : I
      -- the_phi = var 1
      -- -- (δ , φ , u0) : Γ ⊢ u0 : R (δ i0)
      -- the_u0  = var 0

      -- Γ' = (δ : Δ^I, φ : I)
      gamma' = [Dom' Term ([Char], Type'' Term Term)]
-> Tele (Dom (Type'' Term Term))
telFromList ([Dom' Term ([Char], Type'' Term Term)]
 -> Tele (Dom (Type'' Term Term)))
-> [Dom' Term ([Char], Type'' Term Term)]
-> Tele (Dom (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ Int
-> [Dom' Term ([Char], Type'' Term Term)]
-> [Dom' Term ([Char], Type'' Term Term)]
forall a. Int -> [a] -> [a]
take' (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) ([Dom' Term ([Char], Type'' Term Term)]
 -> [Dom' Term ([Char], Type'' Term Term)])
-> [Dom' Term ([Char], Type'' Term Term)]
-> [Dom' Term ([Char], Type'' Term Term)]
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term))
-> [Dom' Term ([Char], Type'' Term Term)]
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Tele (Dom (Type'' Term Term))
gamma

      -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ
      d0 :: Substitution
      d0 = Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
wkS Int
1 -- Δ^I, φ : F ⊢ Δ
                       (Term -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
iz Substitution' Term
forall a. Substitution' a
IdS Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
params) -- Δ^I ⊢ Δ
                                 -- Δ^I , i:I ⊢ sub params : Δ

      -- Ξ , Ξ ⊢ θ : Γ, Ξ ⊢ φ, Ξ ⊢ u : R (δ i0), Ξ ⊢ us : Φ[δ i0]
      (tel,theta,the_phi,the_u0, the_fields) =
        case pathCons of
          -- (δ : Δ).Φ ⊢ u : R δ
          Just Term
u -> (Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
gamma' (Substitution' Term
Substitution' (SubstArg (Tele (Dom (Type'' Term Term))))
d0 Substitution' (SubstArg (Tele (Dom (Type'' Term Term))))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` (Dom CType -> Dom (Type'' Term Term))
-> Tele (Dom CType) -> Tele (Dom (Type'' Term Term))
forall a b. (a -> b) -> Tele a -> Tele b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CType -> Type'' Term Term) -> Dom CType -> Dom (Type'' Term Term)
forall a b. (a -> b) -> Dom' Term a -> Dom' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap CType -> Type'' Term Term
fromCType) Tele (Dom CType)
fsT) -- Ξ = δ : Δ^I, φ : F, _ : Φ[δ i0]
                    , (Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
liftS (Tele (Dom CType) -> Int
forall a. Sized a => a -> Int
size Tele (Dom CType)
fsT) Substitution' Term
d0 Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u) Term -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
`consS` Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS (Tele (Dom CType) -> Int
forall a. Sized a => a -> Int
size Tele (Dom CType)
fsT)
                    , Int -> Term -> Term
forall a. Subst a => Int -> a -> a
raise (Tele (Dom CType) -> Int
forall a. Sized a => a -> Int
size Tele (Dom CType)
fsT) (Int -> Term
var Int
0)
                    , (Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
liftS (Tele (Dom CType) -> Int
forall a. Sized a => a -> Int
size Tele (Dom CType)
fsT) Substitution' Term
d0 Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u)
                    , Int -> [Term] -> [Term]
forall a. Int -> [a] -> [a]
drop (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma') ([Term] -> [Term]) -> [Term] -> [Term]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg ([Arg Term] -> [Term]) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> [Arg Term]
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom (Type'' Term Term))
tel)
          Maybe Term
Nothing -> (Tele (Dom (Type'' Term Term))
gamma, Substitution' Term
forall a. Substitution' a
IdS, Int -> Term
var Int
1, Int -> Term
var Int
0, (Arg QName -> Term) -> [Arg QName] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' (\ Arg QName
fname -> Int -> Term
var Int
0 Term -> QName -> Term
`applyProj` Arg QName -> QName
forall e. Arg e -> e
unArg Arg QName
fname) [Arg QName]
fns )

      fsT_tel = (Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
liftS Int
1 (Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
tel Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
deltaI)) Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
params) Substitution' (SubstArg (Tele (Dom CType)))
-> Tele (Dom CType) -> Tele (Dom CType)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Tele (Dom CType)
fsT

      iMin Term
x Term
y = Term
imin Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
x, Term -> Arg Term
forall e. e -> Arg e
argN Term
y]
      iMax Term
x Term
y = Term
imax Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
x, Term -> Arg Term
forall e. e -> Arg e
argN Term
y]
      iNeg Term
x = Term
ineg Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
x]

      -- .. ⊢ field : filled_ty' i0
      mkBody (Term
field, Dom CType
filled_ty') = do
        let
          filled_ty :: Term
filled_ty = Term -> Term
lam_i (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl (Type'' Term Term -> Term)
-> (Dom CType -> Type'' Term Term) -> Dom CType -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CType -> Type'' Term Term
fromCType (CType -> Type'' Term Term)
-> (Dom CType -> CType) -> Dom CType -> Type'' Term Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom CType -> CType
forall t e. Dom' t e -> e
unDom) Dom CType
filled_ty'
          -- Γ ⊢ l : I -> Level of filled_ty
        -- sort <- reduce $ getSort $ unDom filled_ty'
        case Dom CType -> CType
forall t e. Dom' t e -> e
unDom Dom CType
filled_ty' of
          LType (LEl Level' Term
l Term
_) -> do
            let lvl :: Term
lvl = Term -> Term
lam_i (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Level' Term -> Term
Level Level' Term
l
            Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Names -> NamesT Identity Term -> Term
forall a. Names -> NamesT Identity a -> a
runNames [] (NamesT Identity Term -> Term) -> NamesT Identity Term -> Term
forall a b. (a -> b) -> a -> b
$ do
             lvl <- Term -> NamesT Identity (NamesT Identity Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
lvl
             phi <- open the_phi
             field <- open field
             pure transp <#> lvl <@> pure filled_ty
                                 <@> phi
                                 <@> field
          -- interval arg
          ClosedType{}  ->
            Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> TCMT IO Term) -> Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Names -> NamesT Identity Term -> Term
forall a. Names -> NamesT Identity a -> a
runNames [] (NamesT Identity Term -> Term) -> NamesT Identity Term -> Term
forall a b. (a -> b) -> a -> b
$ do
              field <- Term -> NamesT Identity (NamesT Identity Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
field
              field
  let
        -- ' Ξ , i : I ⊢ τ = [(\ j → δ (i ∧ j)), φ ∨ ~ i, u] : Ξ
        tau = [Term] -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a
parallelS ([Term] -> Substitution' Term) -> [Term] -> Substitution' Term
forall a b. (a -> b) -> a -> b
$ [Term]
us [Term] -> [Term] -> [Term]
forall a. [a] -> [a] -> [a]
++! (Term
phi Term -> Term -> Term
`iMax` Term -> Term
iNeg (Int -> Term
var Int
0))
                        Term -> [Term] -> [Term]
forall a. a -> [a] -> [a]
: (Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' (\ Term
d -> ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"i" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ Int -> Term -> Term
forall a. Subst a => Int -> a -> a
raise Int
1 Term
d Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> 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 -> Term -> Term
iMin (Int -> Term
var Int
0) (Int -> Term
var Int
1))]) [Term]
ds
         where
          -- Ξ, i : I
          ([Term]
us, Term
phi:[Term]
ds) = Int -> [Term] -> ([Term], [Term])
forall a. Int -> [a] -> ([a], [a])
splitAt' (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
tel Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma') ([Term] -> ([Term], [Term])) -> [Term] -> ([Term], [Term])
forall a b. (a -> b) -> a -> b
$ [Term] -> [Term]
forall a. [a] -> [a]
reverse (Int -> [Term] -> [Term]
forall a. Subst a => Int -> a -> a
raise Int
1 ((Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg (Tele (Dom (Type'' Term Term)) -> [Arg Term]
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom (Type'' Term Term))
tel)))

  let
    go [Term]
acc [] = [Term] -> TCMT IO [Term]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go [Term]
acc ((Term
fname,Dom CType
field_ty) : [(Term, Dom CType)]
ps) = do
      -- Ξ, i : I, Φ[δ i]|_f ⊢ Φ_f = field_ty
      -- Ξ ⊢ b : field_ty [i := i1][acc]
      -- Ξ ⊢ parallesS acc : Φ[δ i1]|_f
      -- Ξ , i : I ⊢ τ = [(\ j → δ (i ∨ j), φ ∨ ~ i, us] : Ξ
      -- Ξ , i : I ⊢ parallesS (acc[τ]) : Φ[δ i1]|_f
      -- Ξ, i : I ⊢ field_ty [parallesS (acc[τ])]
      let
        filled_ty :: Dom CType
filled_ty = [Term] -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a
parallelS (Substitution' Term
Substitution' (SubstArg [Term])
tau Substitution' (SubstArg [Term]) -> [Term] -> [Term]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` [Term]
acc) Substitution' (SubstArg (Dom CType)) -> Dom CType -> Dom CType
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Dom CType
field_ty
      b <- (Term, Dom CType) -> TCMT IO Term
mkBody (Term
fname,Dom CType
filled_ty)
      bs <- go (b : acc) ps
      return $ b : bs

  bodys <- go [] (zip' the_fields (map' (fmap snd) $ telToList fsT_tel)) -- ∀ f.  Ξ, i : I, Φ[δ i]|_f ⊢ Φ[δ i]_f
  let
    -- Ξ, i : I ⊢ ... : Δ.Φ
    theSubst = [Term] -> [Term]
forall a. [a] -> [a]
reverse (Substitution' Term
Substitution' (SubstArg [Term])
tau Substitution' (SubstArg [Term]) -> [Term] -> [Term]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` [Term]
bodys) [Term] -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# (Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
liftS Int
1 (Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
tel Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
deltaI)) Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
params)
  return $ ((theName, tel, theta `applySubst` rtype, map' (fmap fromCType) clause_types, bodys), theSubst)
  where
    -- record type in 'exponentiated' context
    -- (params : Δ^I), i : I |- T[params i]
    rect' :: Type'' Term Term
rect' = Tele (Dom (Type'' Term Term)) -> Substitution' Term
forall {a}. Sized a => a -> Substitution' Term
sub Tele (Dom (Type'' Term Term))
params Substitution' (SubstArg (Type'' Term Term))
-> Type'' Term Term -> Type'' Term Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Type'' Term Term
rect
    -- Δ^I, i : I |- sub Δ : Δ
    sub :: a -> Substitution' Term
sub a
tel = Int -> Substitution' Term
expS (Int -> Substitution' Term) -> Int -> Substitution' Term
forall a b. (a -> b) -> a -> b
$ a -> Int
forall a. Sized a => a -> Int
size a
tel

-- invariant: resulting tel Γ is such that Γ = (δ : Δ), (φ : I), (u : ...), (a0 : R δ))
--            where u and a0 have types matching the arguments of primHComp.
defineHCompForFields
  :: (Term -> QName -> Term) -- ^ how to apply a "projection" to a term
  -> QName       -- ^ some name, e.g. record name
  -> Telescope   -- ^ param types Δ
  -> Tele (Dom LType)   -- ^ fields' types Δ ⊢ Φ
  -> [Arg QName] -- ^ fields' names
  -> LType        -- ^ record type (δ : Δ) ⊢ R[δ]
  -> TCM ((QName, Telescope, Type, [Dom Type], [Term]),Substitution)
defineHCompForFields :: (Term -> QName -> Term)
-> QName
-> Tele (Dom (Type'' Term Term))
-> Tele (Dom LType)
-> [Arg QName]
-> LType
-> TCMT
     IO
     ((QName, Tele (Dom (Type'' Term Term)), Type'' Term Term,
       [Dom (Type'' Term Term)], [Term]),
      Substitution' Term)
defineHCompForFields Term -> QName -> Term
applyProj QName
name Tele (Dom (Type'' Term Term))
params Tele (Dom LType)
fsT [Arg QName]
fns LType
rect = do
  interval <- TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m (Type'' Term Term)
primIntervalType
  let delta = Tele (Dom (Type'' Term Term))
params
  iz <- primIZero
  io <- primIOne
  imin <- getPrimitiveTerm builtinIMin
  imax <- getPrimitiveTerm builtinIMax
  tIMax <- getPrimitiveTerm builtinIMax
  ineg <- getPrimitiveTerm builtinINeg
  hcomp <- getPrimitiveTerm builtinHComp
  transp <- getPrimitiveTerm builtinTrans
  por <- getPrimitiveTerm builtinPOr
  one <- primItIsOne
  reportSDoc "comp.rec" 20 $ text $ show params
  reportSDoc "comp.rec" 20 $ text $ show delta
  reportSDoc "comp.rec" 10 $ text $ show fsT

  let thePrefix = [Char]
"hcomp-"
  theName <- freshAbstractQName'_ $ thePrefix ++! P.prettyShow (A.qnameName name)

  reportSLn "hcomp.rec" 5 $ ("Generated name: " ++! show theName ++! " " ++! showQNameId theName)

  theType <- (abstract delta <$>) $ runNamesT [] $ do
              rect <- open $ fromLType rect
              nPi' "phi" primIntervalType $ \ NamesT (TCMT IO) Term
phi ->
               [Char]
-> NamesT (TCMT IO) (Type'' Term Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' Term Term))
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *).
(MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m (Type'' Term Term)
-> (NamesT m Term -> NamesT m (Type'' Term Term))
-> NamesT m (Type'' Term Term)
nPi' [Char]
"i" NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m (Type'' Term Term)
primIntervalType (\ NamesT (TCMT IO) Term
i ->
                [Char]
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' Term Term))
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m (Type'' Term Term))
-> NamesT m (Type'' Term Term)
pPi' [Char]
"o" NamesT (TCMT IO) Term
phi ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' Term Term))
 -> NamesT (TCMT IO) (Type'' Term Term))
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Type'' Term Term))
-> NamesT (TCMT IO) (Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) (Type'' Term Term)
rect) NamesT (TCMT IO) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *).
HasOptions m =>
m (Type'' Term Term)
-> m (Type'' Term Term) -> m (Type'' Term Term)
-->
               NamesT (TCMT IO) (Type'' Term Term)
rect NamesT (TCMT IO) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
-> NamesT (TCMT IO) (Type'' Term Term)
forall (m :: * -> *).
HasOptions m =>
m (Type'' Term Term)
-> m (Type'' Term Term) -> m (Type'' Term Term)
--> NamesT (TCMT IO) (Type'' Term Term)
rect

  reportSDoc "hcomp.rec" 20 $ prettyTCM theType
  reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++! show (lTypeLevel rect)

  lang <- getLanguage
  fun  <- emptyFunctionData
  noMutualBlock $ addConstant theName $
    (defaultDefn defaultArgInfo theName theType lang
       (FunctionDefn fun{ _funTerminates = Just True
                        , _funIsKanOp    = Just name
                        }))
      { defNoCompilation = True }
  --   ⊢ Γ = gamma = (δ : Δ) (φ : I) (_ : (i : I) -> Partial φ (R δ)) (_ : R δ)
  -- Γ ⊢     rtype = R δ
  TelV gamma rtype <- telView theType

  let -- Γ ⊢ R δ
      drect_gamma = Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
delta) Substitution' (SubstArg LType) -> LType -> LType
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` LType
rect

  reportSDoc "hcomp.rec" 60 $ text $ "sort = " ++! show (lTypeLevel drect_gamma)

  let

      -- (γ : Γ) ⊢ hcompR γ : rtype
      compTerm = QName -> [Elim' Term] -> Term
Def QName
theName [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` Tele (Dom (Type'' Term Term)) -> [Arg Term]
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom (Type'' Term Term))
gamma

      -- (δ, φ, u, u0) : Γ ⊢ φ : I
      the_phi = Int -> Term
var Int
2
      -- (δ, φ, u, u0) : Γ ⊢ u : (i : I) → [φ] → R (δ i)
      the_u   = Int -> Term
var Int
1
      -- (δ, φ, u, u0) : Γ ⊢ u0 : R (δ i0)
      the_u0  = Int -> Term
var Int
0

      -- ' (δ, φ, u, u0) : Γ ⊢ fillR Γ : (i : I) → rtype[ δ ↦ (\ j → δ (i ∧ j))]
      fillTerm = Names -> NamesT Identity Term -> Term
forall a. Names -> NamesT Identity a -> a
runNames [] (NamesT Identity Term -> Term) -> NamesT Identity Term -> Term
forall a b. (a -> b) -> a -> b
$ do
        rect   <- Term -> NamesT Identity (NamesT Identity Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT Identity (NamesT Identity Term))
-> (LType -> Term)
-> LType
-> NamesT Identity (NamesT Identity Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl  (Type'' Term Term -> Term)
-> (LType -> Type'' Term Term) -> LType -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LType -> Type'' Term Term
fromLType  (LType -> NamesT Identity (NamesT Identity Term))
-> LType -> NamesT Identity (NamesT Identity Term)
forall a b. (a -> b) -> a -> b
$ LType
drect_gamma
        lvl    <- open . Level . lTypeLevel $ drect_gamma
        params <- mapM open $ take' (size delta) $ teleArgs gamma
        phi    <- open the_phi
        w      <- open the_u
        w0     <- open the_u0
        -- (δ : Δ, φ : I, w : .., w0 : R δ) ⊢
        -- ' fillR Γ = λ i → hcompR δ (φ ∨ ~ i) (\ j → [ φ ↦ w (i ∧ j) , ~ i ↦ w0 ]) w0
        --           = hfillR δ φ w w0
        lam "i" $ \ NamesT Identity Term
i -> do
          args <- [NamesT Identity (Arg Term)] -> NamesT Identity [Arg 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 Identity (Arg Term)]
params
          psi  <- pure imax <@> phi <@> (pure ineg <@> i)
          u <- lam "j" (\ NamesT Identity Term
j -> Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
por NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Identity Term
lvl
                                        NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
phi
                                        NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
i)
                                        NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char]
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" (\ NamesT Identity Term
o -> NamesT Identity Term
rect)
                                        NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Identity Term
w NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imin NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
i NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
j))
                                        NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" (\ NamesT Identity Term
o -> NamesT Identity Term
w0) -- TODO wait for i = 0
                       )
          u0 <- w0
          pure $ Def theName [] `apply` (args ++! [argN psi, argN u, argN u0])

      -- (γ : Γ) ⊢ (flatten Φ)[n ↦ f_n (compR γ)]
      clause_types = [Term] -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a
parallelS [Term
compTerm Term -> QName -> Term
`applyProj` (Arg QName -> QName
forall e. Arg e -> e
unArg Arg QName
fn)
                               | Arg QName
fn <- [Arg QName] -> [Arg QName]
forall a. [a] -> [a]
reverse [Arg QName]
fns] Substitution' (SubstArg [Dom LType]) -> [Dom LType] -> [Dom LType]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst`
                       Tele (Dom LType) -> [Dom LType]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel (Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
delta) Substitution' (SubstArg (Tele (Dom LType)))
-> Tele (Dom LType) -> Tele (Dom LType)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Tele (Dom LType)
fsT) -- Γ, Φ ⊢ flatten Φ
      -- Δ ⊢ Φ = fsT
      -- Γ, i : I ⊢ Φ'
      fsT' = Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS ((Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
- Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
delta) Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Substitution' (SubstArg (Tele (Dom LType)))
-> Tele (Dom LType) -> Tele (Dom LType)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Tele (Dom LType)
fsT

      -- Γ, i : I ⊢ (flatten Φ')[n ↦ f_n (fillR Γ i)]
      filled_types = [Term] -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a
parallelS [Int -> Term -> Term
forall a. Subst a => Int -> a -> a
raise Int
1 Term
fillTerm Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Int -> Term
var Int
0] Term -> QName -> Term
`applyProj` (Arg QName -> QName
forall e. Arg e -> e
unArg Arg QName
fn)
                               | Arg QName
fn <- [Arg QName] -> [Arg QName]
forall a. [a] -> [a]
reverse [Arg QName]
fns] Substitution' (SubstArg [Dom LType]) -> [Dom LType] -> [Dom LType]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst`
                       Tele (Dom LType) -> [Dom LType]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel Tele (Dom LType)
fsT' -- Γ, i : I, Φ' ⊢ flatten Φ'


  comp <- do
        let
          imax NamesT Identity Term
i NamesT Identity Term
j = Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
i NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
j
        let forward NamesT Identity Term
la NamesT Identity Term
bA NamesT Identity Term
r NamesT Identity Term
u = Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
transp NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char]
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Identity Term
i -> NamesT Identity Term
la NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Identity Term
i NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
`imax` NamesT Identity Term
r))
                                            NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Identity Term
i -> NamesT Identity Term
bA NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Identity Term
i NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
`imax` NamesT Identity Term
r))
                                            NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
r
                                            NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
u
        return $ \ NamesT Identity Term
la NamesT Identity Term
bA NamesT Identity Term
phi NamesT Identity Term
u NamesT Identity Term
u0 ->
          Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
hcomp NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Identity Term
la NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Identity Term
bA NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Identity Term
phi
                      NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Identity Term
i -> [Char]
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" ((NamesT Identity Term -> NamesT Identity Term)
 -> NamesT Identity Term)
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall a b. (a -> b) -> a -> b
$ \ NamesT Identity Term
o ->
                              NamesT Identity Term
-> NamesT Identity Term
-> NamesT Identity Term
-> NamesT Identity Term
-> NamesT Identity Term
forward NamesT Identity Term
la NamesT Identity Term
bA NamesT Identity Term
i (NamesT Identity Term
u NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
i NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT Identity Term
o))
                      NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
-> NamesT Identity Term
-> NamesT Identity Term
-> NamesT Identity Term
-> NamesT Identity Term
forward NamesT Identity Term
la NamesT Identity Term
bA (Term -> NamesT Identity Term
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT Identity Term
u0
  let
      mkBody (Arg QName
fname, Dom LType
filled_ty') = do
        let
          proj :: NamesT Identity Term -> NamesT Identity Term
proj NamesT Identity Term
t = (Term -> QName -> Term
`applyProj` Arg QName -> QName
forall e. Arg e -> e
unArg Arg QName
fname) (Term -> Term) -> NamesT Identity Term -> NamesT Identity Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT Identity Term
t
          filled_ty :: Term
filled_ty = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo ([Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"i" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl (Type'' Term Term -> Term)
-> (Dom LType -> Type'' Term Term) -> Dom LType -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LType -> Type'' Term Term
fromLType (LType -> Type'' Term Term)
-> (Dom LType -> LType) -> Dom LType -> Type'' Term Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom LType -> LType
forall t e. Dom' t e -> e
unDom) Dom LType
filled_ty')
          -- Γ ⊢ l : I -> Level of filled_ty
        l <- Level' Term -> TCMT IO (Level' Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Level' Term -> TCMT IO (Level' Term))
-> Level' Term -> TCMT IO (Level' Term)
forall a b. (a -> b) -> a -> b
$ LType -> Level' Term
lTypeLevel (LType -> Level' Term) -> LType -> Level' Term
forall a b. (a -> b) -> a -> b
$ Dom LType -> LType
forall t e. Dom' t e -> e
unDom Dom LType
filled_ty'
        let lvl = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo ([Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"i" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ Level' Term -> Term
Level Level' Term
l)
        return $ runNames [] $ do
             lvl       <- open lvl
             phi       <- open the_phi
             w         <- open the_u
             w0        <- open the_u0
             filled_ty <- open filled_ty

             comp lvl
                  filled_ty
                  phi
                  (lam "i" $ \ NamesT Identity Term
i -> [Char]
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" ((NamesT Identity Term -> NamesT Identity Term)
 -> NamesT Identity Term)
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall a b. (a -> b) -> a -> b
$ \ NamesT Identity Term
o -> NamesT Identity Term -> NamesT Identity Term
proj (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term -> NamesT Identity Term
forall a b. (a -> b) -> a -> b
$ NamesT Identity Term
w NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Identity Term
i NamesT Identity Term
-> NamesT Identity Term -> NamesT Identity Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT Identity Term
o) -- TODO wait for phi = 1
                  (proj w0)

  reportSDoc "hcomp.rec" 60 $ text $ "filled_types sorts:" ++! show (map' (getSort . fromLType . unDom) filled_types)

  bodys <- mapM mkBody (zip' fns filled_types)
  return $ ((theName, gamma, rtype, map' (fmap fromLType) clause_types, bodys),IdS)


getGeneralizedParameters :: Set Name -> QName -> TCM [Maybe Name]
getGeneralizedParameters :: Set Name -> QName -> TCM [Maybe Name]
getGeneralizedParameters Set Name
gpars QName
name | Set Name -> Bool
forall a. Set a -> Bool
Set.null Set Name
gpars = [Maybe Name] -> TCM [Maybe Name]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
getGeneralizedParameters Set Name
gpars QName
name = do
  -- Drop the named parameters that shouldn't be in scope (if the user
  -- wrote a split data type)
  let inscope :: Name -> Maybe Name
inscope Name
x = Name
x Name -> Maybe () -> Maybe Name
forall a b. a -> Maybe b -> Maybe a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Bool -> Maybe ()
forall b (m :: * -> *). (IsBool b, MonadPlus m) => b -> m ()
guard (Name -> Set Name -> Bool
forall a. Ord a => a -> Set a -> Bool
Set.member Name
x Set Name
gpars)
  (Maybe Name -> Maybe Name) -> [Maybe Name] -> [Maybe Name]
forall a b. (a -> b) -> [a] -> [b]
map' (Maybe Name -> (Name -> Maybe Name) -> Maybe Name
forall a b. Maybe a -> (a -> Maybe b) -> Maybe b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Name -> Maybe Name
inscope) ([Maybe Name] -> [Maybe Name])
-> (Definition -> [Maybe Name]) -> Definition -> [Maybe Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> [Maybe Name]
defGeneralizedParams (Definition -> [Maybe Name])
-> TCMT IO Definition -> TCM [Maybe Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Definition -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, ReadTCState m) =>
Definition -> m Definition
instantiateDef (Definition -> TCMT IO Definition)
-> TCMT IO Definition -> TCMT IO Definition
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
name)

-- | Bind the named generalized parameters.
bindGeneralizedParameters :: [Maybe Name] -> Type -> (Telescope -> Type -> TCM a) -> TCM a
bindGeneralizedParameters :: forall a.
[Maybe Name]
-> Type'' Term Term
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
bindGeneralizedParameters [] Type'' Term Term
t Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret = Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret Tele (Dom (Type'' Term Term))
forall a. Tele a
EmptyTel Type'' Term Term
t
bindGeneralizedParameters (Maybe Name
name : [Maybe Name]
names) Type'' Term Term
t Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret =
  case Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
t of
    Pi Dom (Type'' Term Term)
a Abs (Type'' Term Term)
b -> TCM a -> TCM a
ext (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$ [Maybe Name]
-> Type'' Term Term
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
forall a.
[Maybe Name]
-> Type'' Term Term
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
bindGeneralizedParameters [Maybe Name]
names (Abs (Type'' Term Term) -> Type'' Term Term
forall a. Abs a -> a
unAbs Abs (Type'' Term Term)
b) ((Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
 -> TCM a)
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
forall a b. (a -> b) -> a -> b
$ \ Tele (Dom (Type'' Term Term))
tel Type'' Term Term
t -> Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret (Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel Dom (Type'' Term Term)
a (Tele (Dom (Type'' Term Term))
tel Tele (Dom (Type'' Term Term))
-> Abs (Type'' Term Term) -> Abs (Tele (Dom (Type'' Term Term)))
forall a b. a -> Abs b -> Abs a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Abs (Type'' Term Term)
b)) Type'' Term Term
t
      where
        ext :: TCM a -> TCM a
ext | Just Name
x <- Maybe Name
name = (Name, Dom (Type'' Term Term)) -> TCM a -> TCM a
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
(Name, Dom (Type'' Term Term)) -> m a -> m a
addContext (Name
x, Dom (Type'' Term Term)
a)
            | Bool
otherwise      = ([Char], Dom (Type'' Term Term)) -> TCM a -> TCM a
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
([Char], Dom (Type'' Term Term)) -> m a -> m a
addContext (Abs (Type'' Term Term) -> [Char]
forall a. Abs a -> [Char]
absName Abs (Type'' Term Term)
b, Dom (Type'' Term Term)
a)
    Term
_      -> TCM a
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Bind the parameters of a datatype.
--
--   We allow omission of hidden parameters at the definition site.
--   Example:
--   @
--     data D {a} (A : Set a) : Set a
--     data D A where
--       c : A -> D A
--   @

bindParameters
  :: Int            -- ^ Number of parameters
  -> [A.LamBinding] -- ^ Bindings from definition site.
  -> Type           -- ^ Pi-type of bindings coming from signature site.
  -> (Telescope -> Type -> TCM a)
     -- ^ Continuation, accepting parameter telescope and rest of type.
     --   The parameters are part of the context when the continutation is invoked.
  -> TCM a

bindParameters :: forall a.
Int
-> [LamBinding]
-> Type'' Term Term
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
bindParameters Int
0 [] Type'' Term Term
a Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret = Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret Tele (Dom (Type'' Term Term))
forall a. Tele a
EmptyTel Type'' Term Term
a

bindParameters Int
0 (LamBinding
par : [LamBinding]
_) Type'' Term Term
_ Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
_ = LamBinding -> TCM a -> TCM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange LamBinding
par (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$
  TypeError -> TCM a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM a) -> TypeError -> TCM a
forall a b. (a -> b) -> a -> b
$ LamBinding -> TypeError
UnexpectedParameter LamBinding
par

bindParameters Int
npars [] Type'' Term Term
t Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret =
  case Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
t of
    Pi Dom (Type'' Term Term)
a Abs (Type'' Term Term)
b | Bool -> Bool
forall a. Boolean a => a -> a
not (Dom (Type'' Term Term) -> Bool
forall a. LensHiding a => a -> Bool
visible Dom (Type'' Term Term)
a) -> do
              x <- [Char] -> TCMT IO Name
forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
forall (m :: * -> *). MonadFresh NameId m => [Char] -> m Name
freshName_ (Abs (Type'' Term Term) -> [Char]
forall a. Abs a -> [Char]
absName Abs (Type'' Term Term)
b)
              bindParameter npars [] x a b ret
           | Bool
otherwise ->
              TypeError -> TCM a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM a) -> TypeError -> TCM a
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term) -> Abs (Type'' Term Term) -> TypeError
ExpectedBindingForParameter Dom (Type'' Term Term)
a Abs (Type'' Term Term)
b
    Term
_ -> TCM a
forall a. HasCallStack => a
__IMPOSSIBLE__

bindParameters Int
npars par :: [LamBinding]
par@(A.DomainFull (A.TBind Range
_ TypedBindingInfo
_ List1 (Arg (Named_ Binder))
xs Expr
e) : [LamBinding]
bs) Type'' Term Term
a Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret =
  [LamBinding] -> TCM a -> TCM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [LamBinding]
par (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$
  TypeError -> TCM a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM a) -> TypeError -> TCM a
forall a b. (a -> b) -> a -> b
$ List1 (Arg (Named_ Binder)) -> TypeError
UnexpectedTypeSignatureForParameter List1 (Arg (Named_ Binder))
xs

bindParameters Int
_ (A.DomainFull A.TLet{} : [LamBinding]
_) Type'' Term Term
_ Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
_ = TCM a
forall a. HasCallStack => a
__IMPOSSIBLE__

bindParameters Int
_ (par :: LamBinding
par@(A.DomainFree TacticAttribute
_ Arg (Named_ Binder)
arg) : [LamBinding]
ps) Type'' Term Term
_ Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
_
  | Arg (Named_ Binder) -> Modality
forall a. LensModality a => a -> Modality
getModality Arg (Named_ Binder)
arg Modality -> Modality -> Bool
forall a. Eq a => a -> a -> Bool
/= Modality
defaultModality = LamBinding -> TCM a -> TCM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange LamBinding
par (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$
      TypeError -> TCM a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM a) -> TypeError -> TCM a
forall a b. (a -> b) -> a -> b
$ LamBinding -> TypeError
UnexpectedModalityAnnotationInParameter LamBinding
par

bindParameters Int
npars ps0 :: [LamBinding]
ps0@(par :: LamBinding
par@(A.DomainFree TacticAttribute
_ Arg (Named_ Binder)
arg) : [LamBinding]
ps) Type'' Term Term
t Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret = do
  let x :: Binder
x          = Arg (Named_ Binder) -> Binder
forall a. NamedArg a -> a
namedArg Arg (Named_ Binder)
arg
      TelV Tele (Dom (Type'' Term Term))
tel Type'' Term Term
_ = Type'' Term Term -> TelV (Type'' Term Term)
telView' Type'' Term Term
t
  case Arg (Named_ Binder)
-> [Dom' Term ([Char], Type'' Term Term)] -> ImplicitInsertion
forall e a. NamedArg e -> [Dom a] -> ImplicitInsertion
insertImplicit Arg (Named_ Binder)
arg ([Dom' Term ([Char], Type'' Term Term)] -> ImplicitInsertion)
-> [Dom' Term ([Char], Type'' Term Term)] -> ImplicitInsertion
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term))
-> [Dom' Term ([Char], Type'' Term Term)]
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Tele (Dom (Type'' Term Term))
tel of
    ImplicitInsertion
NoInsertNeeded -> [LamBinding] -> Name -> TCM a
continue [LamBinding]
ps (Name -> TCM a) -> Name -> TCM a
forall a b. (a -> b) -> a -> b
$ BindName -> Name
A.unBind (BindName -> Name) -> BindName -> Name
forall a b. (a -> b) -> a -> b
$ Binder -> BindName
forall a. Binder' a -> a
A.binderName Binder
x
    ImpInsert [Dom ()]
_    -> [LamBinding] -> Name -> TCM a
continue [LamBinding]
ps0 (Name -> TCM a) -> TCMT IO Name -> TCM a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [Char] -> TCMT IO Name
forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
forall (m :: * -> *). MonadFresh NameId m => [Char] -> m Name
freshName_ (Abs (Type'' Term Term) -> [Char]
forall a. Abs a -> [Char]
absName Abs (Type'' Term Term)
b)
    ImplicitInsertion
BadImplicits   -> LamBinding -> TCM a -> TCM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange LamBinding
par (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$
      TypeError -> TCM a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM a) -> TypeError -> TCM a
forall a b. (a -> b) -> a -> b
$ LamBinding -> TypeError
UnexpectedParameter LamBinding
par
    NoSuchName [Char]
x   -> LamBinding -> TCM a -> TCM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange LamBinding
par (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$
      TypeError -> TCM a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM a) -> TypeError -> TCM a
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
NoParameterOfName [Char]
x
  where
    Pi dom :: Dom (Type'' Term Term)
dom@(Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> Type'' Term Term
a) Abs (Type'' Term Term)
b = Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
t -- TODO:: Defined but not used: info', a
    info :: ArgInfo
info = Dom (Type'' Term Term)
dom Dom (Type'' Term Term)
-> Getting ArgInfo (Dom (Type'' Term Term)) ArgInfo -> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo
    continue :: [LamBinding] -> Name -> TCM a
continue [LamBinding]
ps Name
x = Int
-> [LamBinding]
-> Name
-> Dom (Type'' Term Term)
-> Abs (Type'' Term Term)
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
forall a.
Int
-> [LamBinding]
-> Name
-> Dom (Type'' Term Term)
-> Abs (Type'' Term Term)
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
bindParameter Int
npars [LamBinding]
ps Name
x Dom (Type'' Term Term)
dom Abs (Type'' Term Term)
b Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret

bindParameter :: Int -> [A.LamBinding] -> Name -> Dom Type -> Abs Type -> (Telescope -> Type -> TCM a) -> TCM a
bindParameter :: forall a.
Int
-> [LamBinding]
-> Name
-> Dom (Type'' Term Term)
-> Abs (Type'' Term Term)
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
bindParameter Int
npars [LamBinding]
ps Name
x Dom (Type'' Term Term)
a Abs (Type'' Term Term)
b Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret =
  (Name, Dom (Type'' Term Term)) -> TCM a -> TCM a
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
(Name, Dom (Type'' Term Term)) -> m a -> m a
addContext (Name
x, Dom (Type'' Term Term)
a) (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$
    Int
-> [LamBinding]
-> Type'' Term Term
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
forall a.
Int
-> [LamBinding]
-> Type'' Term Term
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
bindParameters (Int
npars Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) [LamBinding]
ps (Abs (Type'' Term Term) -> Type'' Term Term
forall a. Subst a => Abs a -> a
absBody Abs (Type'' Term Term)
b) ((Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
 -> TCM a)
-> (Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a)
-> TCM a
forall a b. (a -> b) -> a -> b
$ \ Tele (Dom (Type'' Term Term))
tel Type'' Term Term
s ->
      Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> TCM a
ret (Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel Dom (Type'' Term Term)
a (Abs (Tele (Dom (Type'' Term Term)))
 -> Tele (Dom (Type'' Term Term)))
-> Abs (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ [Char]
-> Tele (Dom (Type'' Term Term))
-> Abs (Tele (Dom (Type'' Term Term)))
forall a. [Char] -> a -> Abs a
Abs (Name -> [Char]
nameToArgName Name
x) Tele (Dom (Type'' Term Term))
tel) Type'' Term Term
s

-- | Check that the arguments to a constructor fits inside the sort of the datatype.
--   The third argument is the type of the constructor.
--
--   When @--without-K@ is active and the type is fibrant the
--   procedure also checks that the type is usable at the current
--   modality. See #4784 and #5434.
--
--   As a side effect, return the arity of the constructor.

fitsIn :: DataOrRecord_ -> QName -> UniverseCheck -> [IsForced] -> Type -> Sort -> TCM Int
fitsIn :: DataOrRecord' ()
-> QName
-> UniverseCheck
-> [IsForced]
-> Type'' Term Term
-> Sort
-> TCMT IO Int
fitsIn DataOrRecord' ()
dataOrRecord QName
con UniverseCheck
uc [IsForced]
forceds Type'' Term Term
conT Sort
s = do
  [Char] -> Int -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.fits" Int
10 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"does" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
conT
        , TCMT IO Doc
"of 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'' Term Term -> Sort
forall a. LensSort a => a -> Sort
getSort Type'' Term Term
conT)
        , TCMT IO Doc
"fit in" 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 TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"?"
        ]
  -- The code below would be simpler, but doesn't allow datatypes
  -- to be indexed by the universe level.
  -- s' <- instantiateFull (getSort t)
  -- noConstraints $ s' `leqSort` s

  TCMT IO Bool -> TCM () -> TCM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM TCMT IO Bool
forall (m :: * -> *). HasOptions m => m Bool
withoutKOption (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
    q <- Lens' TCEnv Quantity -> TCMT IO Quantity
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (Quantity -> f Quantity) -> TCEnv -> f TCEnv
Lens' TCEnv Quantity
eQuantityZeroHardCompile
    -- Don't want to check polarities for the constructor's type,
    -- only for its argument telescope!
    applyPolarityToContext (withStandardLock UnusedPolarity) $
      usableAtModality' (Just s) ConstructorType (setQuantity q unitModality) (unEl conT)

  li <- PragmaOptions -> Bool
optLargeIndices (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
  -- To allow propositional squash in data constructors, we turn @Prop ℓ@ into @Set ℓ@
  -- for the purpose of checking the sort of the constructor.
  -- This would be invalid for record constructors as we could unsquash
  -- by projecting out the squashed data.
  fitsIn' li forceds conT s $ applyWhen (dataOrRecord == IsData) propToType s
  where
  fitsIn' ::
       Bool        -- Are large indices allowed?
    -> [IsForced]  -- Which constructor arguments are forced?
    -> Type        -- Type of the constructor.
    -> Sort        -- Original sort of the data or record type.
    -> Sort        -- For @data@, prop-to-type converted sort.
    -> TCM Int     -- Constructor arity computed from the type.
  fitsIn' :: Bool
-> [IsForced] -> Type'' Term Term -> Sort -> Sort -> TCMT IO Int
fitsIn' Bool
li [IsForced]
forceds Type'' Term Term
t Sort
s0 Sort
s = do
    vt <- do
      t <- Type'' Term Term
-> TCMT
     IO
     (Either
        (Dom (Type'' Term Term), Abs (Type'' Term Term))
        (Type'' Term Term))
forall (m :: * -> *).
PureTCM m =>
Type'' Term Term
-> m (Either
        (Dom (Type'' Term Term), Abs (Type'' Term Term))
        (Type'' Term Term))
pathViewAsPi Type'' Term Term
t
      return $ case t of
                    Left (Dom (Type'' Term Term)
a,Abs (Type'' Term Term)
b)     -> (Bool, Dom (Type'' Term Term), Abs (Type'' Term Term))
-> Maybe (Bool, Dom (Type'' Term Term), Abs (Type'' Term Term))
forall a. a -> Maybe a
Just (Bool
True ,Dom (Type'' Term Term)
a,Abs (Type'' Term Term)
b)
                    Right (El Sort
_ Term
t) | Pi Dom (Type'' Term Term)
a Abs (Type'' Term Term)
b <- Term
t
                                   -> (Bool, Dom (Type'' Term Term), Abs (Type'' Term Term))
-> Maybe (Bool, Dom (Type'' Term Term), Abs (Type'' Term Term))
forall a. a -> Maybe a
Just (Bool
False,Dom (Type'' Term Term)
a,Abs (Type'' Term Term)
b)
                    Either
  (Dom (Type'' Term Term), Abs (Type'' Term Term)) (Type'' Term Term)
_              -> Maybe (Bool, Dom (Type'' Term Term), Abs (Type'' Term Term))
forall a. Maybe a
Nothing
    case vt of
      Just (Bool
isPath, Dom (Type'' Term Term)
dom, Abs (Type'' Term Term)
b) -> do
        polarity <- PragmaOptions -> Bool
optPolarity (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
        -- When the --polarity option is enabled, the type of
        -- every constructor argument is re-checked using the internal
        -- type checker, to ensure that their usage of datatype parameters is
        -- consistent with polarity annotations (of the parameters).
        -- This may impact type checking performance, as the internal checker
        -- does more work than just checking polarity.
        -- A simpler check dedicated to polarity could be implemented,
        -- but would likely lead to duplicated logic.
        -- For further discussion on why this check is necessary, see:
        -- https://github.com/agda/agda/pull/6385#issuecomment-1349672456
        when polarity $ do
          arg <- instantiateFull (unEl (unDom dom))
          reportSDoc "tc.polarity" 40 $
            sep [ "checking constructor domain"
                , prettyTCM (unEl $ unDom dom)
                , "against sort"
                , prettyTCM (getSort dom)
                ]
          applyCohesionToContext dom $
            checkInternal arg CmpLeq (sort (getSort dom))
        let
          (forced, forceds') = nextIsForced forceds
          isf = IsForced -> Bool
isForced IsForced
forced

        unless (isf && li) $ do
          sa <- reduce $ getSort dom
          unless (isPath || uc == NoUniverseCheck || sa == SizeUniv) $
            traceCall (CheckConArgFitsIn con isf (unDom dom) s) $
            fitSort sa s0 s

        addContext (absName b, dom) $ do
          succ <$> fitsIn' li forceds' (absBody b) (raise 1 s0) (raise 1 s)
      Maybe (Bool, Dom (Type'' Term Term), Abs (Type'' Term Term))
_ -> do
        Sort -> Sort -> Sort -> TCM ()
fitSort (Type'' Term Term -> Sort
forall a. LensSort a => a -> Sort
getSort Type'' Term Term
t) Sort
s0 Sort
s
        Int -> TCMT IO Int
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
0
  -- catch hard error from sort comparison to turn it into a soft error
  fitSort :: Sort -> Sort -> Sort -> TCM ()
fitSort Sort
sa Sort
s0 Sort
s = Sort -> Sort -> TCM ()
leqSort Sort
sa Sort
s TCM () -> (TCErr -> TCM ()) -> TCM ()
forall a. TCM a -> (TCErr -> TCM a) -> TCM a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ TCErr
err ->
    Warning -> TCM ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCM ()) -> Warning -> TCM ()
forall a b. (a -> b) -> a -> b
$ DataOrRecord' () -> QName -> Sort -> Sort -> TCErr -> Warning
ConstructorDoesNotFitInData DataOrRecord' ()
dataOrRecord QName
con Sort
sa Sort
s0 TCErr
err

-- | When --without-K is enabled, we should check that the sorts of
--   the index types fit into the sort of the datatype.
checkIndexSorts :: Sort -> Telescope -> TCM ()
checkIndexSorts :: Sort -> Tele (Dom (Type'' Term Term)) -> TCM ()
checkIndexSorts Sort
s = \case
  Tele (Dom (Type'' Term Term))
EmptyTel -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ExtendTel Dom (Type'' Term Term)
a Abs (Tele (Dom (Type'' Term Term)))
tel' -> do
    let sa :: Sort
sa = Dom (Type'' Term Term) -> Sort
forall a. LensSort a => a -> Sort
getSort Dom (Type'' Term Term)
a
    -- Andreas, 2020-10-19, allow Size indices
    Bool -> TCM () -> TCM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (Sort
sa Sort -> Sort -> Bool
forall a. Eq a => a -> a -> Bool
== Sort
forall t. Sort' t
SizeUniv) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ Sort
sa Sort -> Sort -> TCM ()
`leqSort` Sort
s
    Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> (Tele (Dom (Type'' Term Term)) -> TCM ())
-> TCM ()
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Dom (Type'' Term Term) -> Abs a -> (a -> m b) -> m b
underAbstraction Dom (Type'' Term Term)
a Abs (Tele (Dom (Type'' Term Term)))
tel' ((Tele (Dom (Type'' Term Term)) -> TCM ()) -> TCM ())
-> (Tele (Dom (Type'' Term Term)) -> TCM ()) -> TCM ()
forall a b. (a -> b) -> a -> b
$ Sort -> Tele (Dom (Type'' Term Term)) -> TCM ()
checkIndexSorts (Int -> Sort -> Sort
forall a. Subst a => Int -> a -> a
raise Int
1 Sort
s)

-- | Return the parameters that share variables with the indices
-- nonLinearParameters :: Int -> Type -> TCM [Int]
-- nonLinearParameters nPars t =

data IsPathCons = PathCons | PointCons
  deriving (IsPathCons -> IsPathCons -> Bool
(IsPathCons -> IsPathCons -> Bool)
-> (IsPathCons -> IsPathCons -> Bool) -> Eq IsPathCons
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: IsPathCons -> IsPathCons -> Bool
== :: IsPathCons -> IsPathCons -> Bool
$c/= :: IsPathCons -> IsPathCons -> Bool
/= :: IsPathCons -> IsPathCons -> Bool
Eq,Int -> IsPathCons -> [Char] -> [Char]
[IsPathCons] -> [Char] -> [Char]
IsPathCons -> [Char]
(Int -> IsPathCons -> [Char] -> [Char])
-> (IsPathCons -> [Char])
-> ([IsPathCons] -> [Char] -> [Char])
-> Show IsPathCons
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> IsPathCons -> [Char] -> [Char]
showsPrec :: Int -> IsPathCons -> [Char] -> [Char]
$cshow :: IsPathCons -> [Char]
show :: IsPathCons -> [Char]
$cshowList :: [IsPathCons] -> [Char] -> [Char]
showList :: [IsPathCons] -> [Char] -> [Char]
Show)

-- | Check that a type constructs something of the given datatype. The first
--   argument is the number of parameters to the datatype and the second the
--   number of additional non-parameters in the context (1 when generalizing, 0
--   otherwise).
--
constructs :: Int -> Int -> Type -> QName -> TCM IsPathCons
constructs :: Int -> Int -> Type'' Term Term -> QName -> TCM IsPathCons
constructs Int
nofPars Int
nofExtraVars Type'' Term Term
t QName
q = Int -> Type'' Term Term -> TCM IsPathCons
constrT Int
nofExtraVars Type'' Term Term
t
    where
        -- The number n counts the proper (non-parameter) constructor arguments.
        constrT :: Nat -> Type -> TCM IsPathCons
        constrT :: Int -> Type'' Term Term -> TCM IsPathCons
constrT Int
n Type'' Term Term
t = do
            t <- Type'' Term Term -> TCMT IO (Type'' Term Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Type'' Term Term
t
            pathV <- pathViewAsPi'whnf
            case unEl t of
                Pi Dom (Type'' Term Term)
_ (NoAbs [Char]
_ Type'' Term Term
b)  -> Int -> Type'' Term Term -> TCM IsPathCons
constrT Int
n Type'' Term Term
b
                Pi Dom (Type'' Term Term)
a Abs (Type'' Term Term)
b            -> Dom (Type'' Term Term)
-> Abs (Type'' Term Term)
-> (Type'' Term Term -> TCM IsPathCons)
-> TCM IsPathCons
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Dom (Type'' Term Term) -> Abs a -> (a -> m b) -> m b
underAbstraction Dom (Type'' Term Term)
a Abs (Type'' Term Term)
b ((Type'' Term Term -> TCM IsPathCons) -> TCM IsPathCons)
-> (Type'' Term Term -> TCM IsPathCons) -> TCM IsPathCons
forall a b. (a -> b) -> a -> b
$ Int -> Type'' Term Term -> TCM IsPathCons
constrT (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                  -- OR: addCxtString (absName b) a $ constrT (n + 1) (absBody b)
                Term
_ | Left ((Dom (Type'' Term Term)
a,Abs (Type'' Term Term)
b),(Term, Term)
_) <- Type'' Term Term
-> Either
     ((Dom (Type'' Term Term), Abs (Type'' Term Term)), (Term, Term))
     (Type'' Term Term)
pathV Type'' Term Term
t -> do
                      _ <- case Abs (Type'' Term Term)
b of
                             NoAbs [Char]
_ Type'' Term Term
b -> Int -> Type'' Term Term -> TCM IsPathCons
constrT Int
n Type'' Term Term
b
                             Abs (Type'' Term Term)
b         -> Dom (Type'' Term Term)
-> Abs (Type'' Term Term)
-> (Type'' Term Term -> TCM IsPathCons)
-> TCM IsPathCons
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Dom (Type'' Term Term) -> Abs a -> (a -> m b) -> m b
underAbstraction Dom (Type'' Term Term)
a Abs (Type'' Term Term)
b ((Type'' Term Term -> TCM IsPathCons) -> TCM IsPathCons)
-> (Type'' Term Term -> TCM IsPathCons) -> TCM IsPathCons
forall a b. (a -> b) -> a -> b
$ Int -> Type'' Term Term -> TCM IsPathCons
constrT (Int
n Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                      return PathCons
                Def QName
d [Elim' Term]
es | QName
d QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
q -> do
                  let vs :: [Arg Term]
vs = [Elim' Term] -> [Arg Term]
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims [Elim' Term]
es
                  let ([Arg Term]
pars, [Arg Term]
ixs) = Int -> [Arg Term] -> ([Arg Term], [Arg Term])
forall a. Int -> [a] -> ([a], [a])
splitAt' Int
nofPars [Arg Term]
vs
                  -- check that the constructor parameters are the data parameters
                  Int -> [Arg Term] -> TCM ()
checkParams Int
n [Arg Term]
pars
                  IsPathCons -> TCM IsPathCons
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return IsPathCons
PointCons
                MetaV{} -> do
                  def <- QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
q
                  -- Analyse the type of q (name of the data type)
                  let td = Definition -> Type'' Term Term
defType Definition
def
                  TelV tel core <- telView td
                  -- Construct the parameter arguments
                  -- The parameters are @n + nofPars - 1 .. n@
                  let us = (Arg [Char] -> Int -> Arg Term)
-> [Arg [Char]] -> [Int] -> [Arg Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' (\ Arg [Char]
arg Int
x -> Int -> Term
var Int
x Term -> Arg [Char] -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg [Char]
arg ) (Tele (Dom (Type'' Term Term)) -> [Arg [Char]]
forall a. TelToArgs a => a -> [Arg [Char]]
telToArgs Tele (Dom (Type'' Term Term))
tel) ([Int] -> [Arg Term]) -> [Int] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$
                             Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take' Int
nofPars ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
forall a. Integral a => a -> [a]
downFrom (Int
nofPars Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
n)
                  -- The indices are fresh metas
                  xs <- newArgsMeta =<< piApplyM td us
                  let t' = Sort -> Term -> Type'' Term Term
forall t a. Sort' t -> a -> Type'' t a
El (Int -> Sort -> Sort
forall a. Subst a => Int -> a -> a
raise Int
n (Sort -> Sort) -> Sort -> Sort
forall a b. (a -> b) -> a -> b
$ Defn -> Sort
dataSort (Defn -> Sort) -> Defn -> Sort
forall a b. (a -> b) -> a -> b
$ Definition -> Defn
theDef Definition
def) (Term -> Type'' Term Term) -> Term -> Type'' Term Term
forall a b. (a -> b) -> a -> b
$ QName -> [Elim' Term] -> Term
Def QName
q ([Elim' Term] -> Term) -> [Elim' Term] -> Term
forall a b. (a -> b) -> a -> b
$ (Arg Term -> Elim' Term) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply ([Arg Term] -> [Elim' Term]) -> [Arg Term] -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ [Arg Term]
us [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++! [Arg Term]
xs
                  -- Andreas, 2017-11-07, issue #2840
                  -- We should not postpone here, otherwise we might upset the positivity checker.
                  ifM (tryConversion $ equalType t t')
                      (constrT n t')
                      (typeError $ ShouldEndInApplicationOfTheDatatype t)
                Term
_ -> TypeError -> TCM IsPathCons
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM IsPathCons) -> TypeError -> TCM IsPathCons
forall a b. (a -> b) -> a -> b
$ Type'' Term Term -> TypeError
ShouldEndInApplicationOfTheDatatype Type'' Term Term
t

        checkParams :: Int -> [Arg Term] -> TCM ()
checkParams Int
n [Arg Term]
vs = (Arg Term -> Int -> TCM ()) -> [Arg Term] -> [Int] -> TCM ()
forall (m :: * -> *) a b c.
Applicative m =>
(a -> b -> m c) -> [a] -> [b] -> m ()
zipWithM_ Arg Term -> Int -> TCM ()
sameVar [Arg Term]
vs [Int]
ps
            where
                nvs :: Int
nvs = [Arg Term] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg Term]
vs
                ps :: [Int]
ps  = [Int] -> [Int]
forall a. [a] -> [a]
reverse ([Int] -> [Int]) -> [Int] -> [Int]
forall a b. (a -> b) -> a -> b
$ Int -> [Int] -> [Int]
forall a. Int -> [a] -> [a]
take' Int
nvs [Int
n..]

                sameVar :: Arg Term -> Int -> TCM ()
sameVar Arg Term
arg Int
i
                  -- skip irrelevant parameters
                  | Arg Term -> Bool
forall a. LensRelevance a => a -> Bool
isIrrelevant Arg Term
arg = () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  | Bool
otherwise = do
                    t <- Int -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(MonadDebug m, MonadTCEnv m) =>
Int -> m (Type'' Term Term)
typeOfBV Int
i
                    equalTerm t (unArg arg) (var i)


-- | Is the type coinductive? Returns 'Nothing' if the answer cannot
-- be determined.

isCoinductive :: Type -> TCM (Maybe Bool)
isCoinductive :: Type'' Term Term -> TCM (Maybe Bool)
isCoinductive Type'' Term Term
t = do
  El s t <- Type'' Term Term -> TCMT IO (Type'' Term Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Type'' Term Term
t
  case t of
    Def QName
q [Elim' Term]
_ -> do
      def <- QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
q
      case theDef def of
        Axiom       {} -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
        DataOrRecSig{} -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
        Function    {} -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
        Datatype    {} -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
        Record      {  recInduction :: Defn -> Maybe Induction
recInduction = Just Induction
CoInductive } -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True)
        Record      {  recInduction :: Defn -> Maybe Induction
recInduction = Maybe Induction
_                } -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
        GeneralizableVar{} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
        Constructor {} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
        Primitive   {} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
        PrimitiveSort{} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
        AbstractDefn{} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
    Var   {} -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
    Lam   {} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
    Lit   {} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
    Level {} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
    Con   {} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
    Pi    {} -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
    Sort  {} -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False)
    MetaV {} -> Maybe Bool -> TCM (Maybe Bool)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
forall a. Maybe a
Nothing
    DontCare{} -> TCM (Maybe Bool)
forall a. HasCallStack => a
__IMPOSSIBLE__
    Dummy DummyTermKind
s [Elim' Term]
_  -> [Char] -> TCM (Maybe Bool)
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
[Char] -> m a
__IMPOSSIBLE_VERBOSE__ (DummyTermKind -> [Char]
forall a. Show a => a -> [Char]
show DummyTermKind
s)