{-# LANGUAGE NondecreasingIndentation #-}

module Mikan.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 Control.DeepSeq

import Data.Set (Set)
import Data.Set qualified as Set
import Data.Text (Text)
import Data.Text qualified as T
import Data.Text.Short (ShortText)
import Data.Text.Short qualified as TS

import GHC.Generics (Generic)

import Mikan.Interaction.Options.Base

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

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

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

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

import Mikan.Utils.Permutation
import Mikan.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 Nat
n -> Nat
n
                Defn
_              -> Nat
forall a. HasCallStack => a
__IMPOSSIBLE__

        -- Make sure the shape of the type is visible
        let unTelV (TelV Tele (Dom Type)
tel Type
a) = Tele (Dom Type) -> Type -> Type
telePi Tele (Dom Type)
tel Type
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)
gtel Type
t0 ->
                   DataOrRecord
-> Nat
-> [LamBinding]
-> Type
-> (Tele (Dom Type) -> Type -> TCM DatatypeData)
-> TCM DatatypeData
forall a.
DataOrRecord
-> Nat
-> [LamBinding]
-> Type
-> (Tele (Dom Type) -> Type -> TCM a)
-> TCM a
bindParameters DataOrRecord
forall p. DataOrRecord' p
IsData (Nat
npars Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- [Maybe Name] -> Nat
forall a. [a] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [Maybe Name]
parNames) [LamBinding]
ps Type
t0 ((Tele (Dom Type) -> Type -> TCM DatatypeData) -> TCM DatatypeData)
-> (Tele (Dom Type) -> Type -> TCM DatatypeData)
-> TCM DatatypeData
forall a b. (a -> b) -> a -> b
$ \Tele (Dom Type)
ptel Type
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)
ixTel Type
s0 = Type -> TelV Type
telView' Type
t0
                nofIxs :: Nat
nofIxs = Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
ixTel

            s <- TCMT IO Sort -> TCMT IO Sort
forall (m :: * -> *) a. (MonadTCEnv 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
newSortMeta
              catchError_ (addContext ixTel $ equalType s0 $ raise nofIxs $ sort s) $ \ TCErr
err ->
                  if (Nat -> Bool) -> [Nat] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Nat -> Type -> Bool
forall t. Free t => Nat -> t -> Bool
`freeIn` Type
s0) [Nat
0..Nat
nofIxs Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1] then TypeError -> TCM ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM ()) -> TypeError -> TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> Type -> TypeError
SortCannotDependOnItsIndex QName
name Type
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

            -- Parameters are always hidden in constructors.
            let tel  = Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
gtel Tele (Dom Type)
ptel
                tel' = Dom Type -> Dom Type
forall a. LensHiding a => a -> a
hideExplicit (Dom Type -> Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tele (Dom Type)
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) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
tel

            -- Change the datatype from an axiom to a datatype with no constructors.
            let dataDef = DatatypeData
                  { _dataPars :: Nat
_dataPars       = Nat
npars
                  , _dataIxs :: Nat
_dataIxs        = Nat
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)
-> Nat
-> Sort
-> Constructor
-> TCM IsPathCons
checkConstructor QName
name UniverseCheck
uc Tele (Dom Type)
tel' Nat
nofIxs Sort
s Constructor
c
              return $ if isPathCons == PathCons then Just (A.axiomName c) else Nothing


            -- cubical: the interval universe does not contain datatypes
            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) do
              let s' = case Sort
s of
                    Prop Level
l      -> Level -> Sort
forall t. Level' t -> Sort' t
Type Level
l
                    Inf Univ
UProp Integer
l -> Univ -> Integer -> Sort
forall t. Univ -> Integer -> Sort' t
Inf Univ
UType Integer
l
                    Sort
_           -> Sort
s
              checkIndexSorts name 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) <- inTopContext $ do
          mtranspix <- defineTranspIx name
          transpFun <- defineTranspFun name mtranspix cons $
                        _dataPathCons dataDef
          return (mtranspix, transpFun)

        -- 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@ does 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 :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> 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
_     -> TCM ()
yes
      Inf Univ
_ Integer
_      -> TCM ()
yes
      DefS QName
_ [Elim' Term]
_     -> TCM ()
yes
      -- Sorts that do not admit data definitions.
      Sort
LevelUniv    -> TCM ()
no
      Sort
IntervalUniv -> TCM ()
no
      Sort
CofUniv      -> 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 -> TCMT IO Sort
forceSort Type
t = Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Type -> Term
forall t a. Type'' t a -> a
unEl Type
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
newSortMeta
    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)
-> Nat
-> Sort
-> Constructor
-> TCM IsPathCons
checkConstructor QName
d UniverseCheck
uc Tele (Dom Type)
tel Nat
nofIxs Sort
s (A.ScopedDecl ScopeInfo
scope (Constructor
con :| [])) = do
  ScopeInfo -> TCM ()
setScope ScopeInfo
scope
  QName
-> UniverseCheck
-> Tele (Dom Type)
-> Nat
-> Sort
-> Constructor
-> TCM IsPathCons
checkConstructor QName
d UniverseCheck
uc Tele (Dom Type)
tel Nat
nofIxs Sort
s Constructor
con
checkConstructor QName
d UniverseCheck
uc Tele (Dom Type)
tel Nat
nofIxs Sort
s con :: Constructor
con@(A.Axiom KindOfName
_ DefInfo
i Origin
orig Maybe PragmaPolarities
Nothing QName
c Type
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) -> Sort -> Constructor -> Call
CheckConstructor QName
d Tele (Dom Type)
tel Sort
s Constructor
con) (TCM IsPathCons -> TCM IsPathCons)
-> TCM IsPathCons -> TCM IsPathCons
forall a b. (a -> b) -> a -> b
$ do
        QName -> Type -> TCM ()
forall {m :: * -> *} {a} {a}.
(MonadDebug m, PrettyTCM a, PrettyTCM a) =>
a -> a -> m ()
debugEnter QName
c Type
e

        -- check that the type of the constructor is well-formed
        (t, isPathCons) <- Type -> QName -> TCMT IO (Type, IsPathCons)
checkConstructorType Type
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 <- 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] $ \ Nat
i ->
              ArgName -> TCMT IO QName
freshAbstractQName'_ (ArgName -> TCMT IO QName) -> ArgName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char] -> ArgName
TS.pack (Name -> [Char]
forall a. Pretty a => a -> [Char]
P.prettyShow (QName -> Name
A.qnameName QName
c)) ArgName -> ArgName -> ArgName
forall a. Semigroup a => a -> a -> a
<> ArgName
"-" ArgName -> ArgName -> ArgName
forall a. Semigroup a => a -> a -> a
<> ([Char] -> ArgName
TS.pack (Nat -> [Char]
forall a. Show a => a -> [Char]
show Nat
i))

            -- nofIxs == 0 means the data type can be reconstructed
            -- by appling the QName d to the parameters.
            let dataT = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El Sort
s (Term -> Type) -> Term -> Type
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) -> Args -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply (Args -> [Elim' Term]) -> Args -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> Args
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom Type)
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 -> [QName] -> ConHead
ConHead QName
c DataOrRecord
forall p. DataOrRecord' p
IsData Induction
Inductive [QName]
names

            defineProjections d con params names fields dataT
            -- Andreas, 2024-01-05 issue #7048:
            -- Only define hcomp when --cubical=compatible.
            -- Cannot compose indexed inductive types yet.
            comp <- if 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
          addConstant' c defaultArgInfo{ argInfoOrigin = orig } (telePi tel t) $ Constructor
              { conPars   = size tel
              , conArity  = arity
              , conSrcCon = con
              , conData   = d
              , conAbstr  = Info.defAbstract i
              , conComp   = comp
              , conProj   = projNames
              , conForced = forcedArgs
              , 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 -> TCM ()
addTypedInstance KwRange
kwr QName
c Type
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 :: Type -> QName -> TCMT IO (Type, IsPathCons)
checkConstructorType (A.ScopedExpr ScopeInfo
s Type
e) QName
d = ScopeInfo
-> TCMT IO (Type, IsPathCons) -> TCMT IO (Type, IsPathCons)
forall (m :: * -> *) a. ReadTCState m => ScopeInfo -> m a -> m a
evalWithScope ScopeInfo
s (TCMT IO (Type, IsPathCons) -> TCMT IO (Type, IsPathCons))
-> TCMT IO (Type, IsPathCons) -> TCMT IO (Type, IsPathCons)
forall a b. (a -> b) -> a -> b
$ Type -> QName -> TCMT IO (Type, IsPathCons)
checkConstructorType Type
e QName
d
    checkConstructorType Type
e QName
d = do
      let check :: Nat -> Type -> TCMT IO (Type, IsPathCons)
check Nat
k Type
e = do
            t <- TCMT IO Type -> TCMT IO Type
forall (m :: * -> *) a. (MonadTCEnv m, MonadDebug m) => m a -> m a
workOnTypes (TCMT IO Type -> TCMT IO Type) -> TCMT IO Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO Type
isType_ Type
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 Type
e of
        A.Generalized Set1 QName
s Type
e -> do
          (_, t, isPathCons) <- Set QName
-> TCMT IO (Type, IsPathCons)
-> TCM ([Maybe QName], Type, IsPathCons)
forall a.
Set QName -> TCM (Type, a) -> TCM ([Maybe QName], Type, a)
generalizeType' (Set1 QName -> Set QName
forall a. NESet a -> Set a
Set1.toSet Set1 QName
s) (Nat -> Type -> TCMT IO (Type, IsPathCons)
check Nat
1 Type
e)
          return (t, isPathCons)
        Type
_ -> Nat -> Type -> TCMT IO (Type, IsPathCons)
check Nat
0 Type
e

    debugEnter :: a -> a -> m ()
debugEnter a
c a
e =
      [Char] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.con" Nat
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] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.con" Nat
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"
              , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ 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
              ]
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"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] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.con" Nat
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"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ 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] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.con" Nat
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)
_ Nat
_ 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)
-> [QName]
-> Tele (Dom Type)
-> Type
-> Boundary
-> TCMT IO CompKit
defineCompData QName
d ConHead
con Tele (Dom Type)
params [QName]
names Tele (Dom Type)
fsT Type
t Boundary
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
    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
sub a
tel = [ Nat -> Term
var Nat
n Term -> Args -> Term
forall t. Apply t => t -> Args -> 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
$ Nat -> Term
var Nat
0] | Nat
n <- [Nat
1..a -> Nat
forall a. Sized a => a -> Nat
size a
tel] ] [Term] -> Substitution -> Substitution
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Impossible -> Substitution
forall a. Impossible -> Substitution' a
EmptyS Impossible
forall a. HasCallStack => a
__IMPOSSIBLE__
    withArgInfo :: Tele (Dom t) -> [b] -> [Arg b]
withArgInfo Tele (Dom t)
tel = (ArgInfo -> b -> Arg b) -> [ArgInfo] -> [b] -> [Arg b]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' ArgInfo -> b -> Arg b
forall e. ArgInfo -> e -> Arg e
Arg ((Dom' Term (ArgName, t) -> ArgInfo)
-> [Dom' Term (ArgName, t)] -> [ArgInfo]
forall a b. (a -> b) -> [a] -> [b]
map' Dom' Term (ArgName, t) -> ArgInfo
forall t e. Dom' t e -> ArgInfo
domInfo ([Dom' Term (ArgName, t)] -> [ArgInfo])
-> (Tele (Dom t) -> [Dom' Term (ArgName, t)])
-> Tele (Dom t)
-> [ArgInfo]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tele (Dom t) -> [Dom' Term (ArgName, t)]
forall t. Tele (Dom t) -> [Dom (ArgName, 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)
-> [QName]
-> Tele (Dom Type)
-> Type
-> Boundary
-> TCMT IO (Maybe QName)
defineKanOperationD Command
cmd QName
d ConHead
con Tele (Dom Type)
params [QName]
names Tele (Dom Type)
fsT Type
t Boundary
boundary = do
      let project :: Term -> QName -> Term
project = (\ Term
t QName
p -> Term -> Args -> Term
forall t. Apply t => t -> Args -> 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)
-> Tele (Dom Type)
-> [Arg QName]
-> Type
-> TCM
     (Maybe
        ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution))
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 -> Bool
forall a. Null a => a -> Bool
null Boundary
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) -> Boundary -> [Elim' Term]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary' Nat a -> [Elim' a]
teleElims Tele (Dom Type)
fsT Boundary
boundary))
                 Term -> QName -> Term
project QName
d Tele (Dom Type)
params Tele (Dom Type)
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
t
      caseMaybe stuff (return Nothing) $ \ ((QName
theName, Tele (Dom Type)
gamma , Type
ty, [Dom Type]
_cl_types , [Term]
bodies), Substitution
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) -> Args -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply (Args -> [Elim' Term]) -> Args -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> [Term] -> Args
forall {t} {b}. Tele (Dom t) -> [b] -> [Arg b]
withArgInfo Tele (Dom Type)
fsT [Term]
bodies)
          Command
DoTransp | Boundary -> Bool
forall a. Null a => a -> Bool
null Boundary
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) -> Args -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply (Args -> [Elim' Term]) -> Args -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> [Term] -> Args
forall {t} {b}. Tele (Dom t) -> [b] -> [Arg b]
withArgInfo Tele (Dom Type)
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) -> Boundary -> [Elim' Term]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary' Nat a -> [Elim' a]
teleElims Tele (Dom Type)
fsT Boundary
boundary
              -- Γ ⊢ u
              the_u = Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
liftS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
fsT) Substitution
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
d0 = Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
wkS Nat
1 -- Δ^I, φ : F ⊢ Δ
                             (Term -> Substitution -> Substitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
iz Substitution
forall a. Substitution' a
IdS Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
params) -- Δ^I ⊢ Δ
                                       -- Δ^I , i:I ⊢ sub params : Δ
              the_phi = Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
fsT) (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Nat -> Term
var Nat
0
              -- Γ ⊢ sigma : Δ.Φ
              -- sigma = [δ i1,bodies]
              -- sigma = theSub[i1]
              sigma = [Term] -> [Term]
forall a. [a] -> [a]
reverse [Term]
bodies [Term] -> Substitution -> Substitution
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Substitution
d1
               where
                -- δ i1
                d1 :: Substitution
                d1 :: Substitution
d1 = Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
wkS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
gamma Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
params) -- Γ ⊢ Δ
                       (Term -> Substitution -> Substitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
io Substitution
forall a. Substitution' a
IdS Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
params) -- Δ^I ⊢ Δ
                                 -- Δ^I , i:I ⊢ sub params : Δ

              -- Δ.Φ ⊢ [ (i=0) -> t_i; (i=1) -> u_i ] : R δ
              bs = Tele (Dom Type) -> Boundary -> Boundary
fullBoundary Tele (Dom Type)
fsT Boundary
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
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) -> Boundary -> [Elim' Term]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary' Nat a -> [Elim' a]
teleElims Tele (Dom Type)
fsT Boundary
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
l) -> Level -> Term
Level Level
l) (Sort -> Term) -> (Type -> Sort) -> Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Sort
forall a. LensSort a => a -> Sort
getSort
              pOr NamesT (TCMT IO) Type
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
lvlOfType (Type -> Term) -> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Type
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
<#> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"o" (\ NamesT (TCMT IO) Term
_ -> Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Type
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
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
<#> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"j" (\ NamesT (TCMT IO) Term
j -> Type -> Term
lvlOfType (Type -> Term) -> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Type)
ty NamesT (TCMT IO) (Abs Type)
-> NamesT (TCMT IO) (SubstArg Type) -> NamesT (TCMT IO) Type
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
<@> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"j" (\ NamesT (TCMT IO) Term
j -> Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Type)
ty NamesT (TCMT IO) (Abs Type)
-> NamesT (TCMT IO) (SubstArg Type) -> NamesT (TCMT IO) Type
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
                           (lam "o" $ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
squeeze NamesT (TCMT IO) Term
u1) (lam "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
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
lvlOfType (Type -> Term) -> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Type
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
forall t a. Type'' t a -> a
unEl (Type -> Term) -> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Type
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 = ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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
-> 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
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
-> 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
ty
                                                   NamesT (TCMT IO) Term
thePsi    NamesT (TCMT IO) Term
phi
                                                   NamesT (TCMT IO) Term
sys_alpha (ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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 = Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
wkS Nat
1 -- Δ^I, φ : F ⊢ Δ
                       (Term -> Substitution -> Substitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
iz Substitution
forall a. Substitution' a
IdS Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
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) -> Bool -> ConPatternInfo
ConPatternInfo PatternInfo
defaultPatternInfo Bool
False Bool
False Maybe (Arg Type)
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) -> Boundary -> [Arg (Named_ (Pattern' DBPatVar))]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary -> [NamedArg (Pattern' a)]
telePatterns (Substitution
Substitution' (SubstArg (Tele (Dom Type)))
d0 Substitution' (SubstArg (Tele (Dom Type)))
-> Tele (Dom Type) -> Tele (Dom Type)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Tele (Dom Type)
fsT) (Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
liftS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
fsT) Substitution
d0 Substitution' (SubstArg Boundary) -> Boundary -> Boundary
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Boundary
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 -> Bool
forall a. Null a => a -> Bool
null Boundary
boundary = Tele (Dom Type) -> [Arg (Named_ (Pattern' DBPatVar))]
forall a t. DeBruijn a => Tele (Dom t) -> [NamedArg a]
teleNamedArgs Tele (Dom Type)
gamma
             | Bool
otherwise     = Nat
-> [Arg (Named_ (Pattern' DBPatVar))]
-> [Arg (Named_ (Pattern' DBPatVar))]
forall a. Nat -> [a] -> [a]
take' (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
gamma Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
fsT) (Tele (Dom Type) -> [Arg (Named_ (Pattern' DBPatVar))]
forall a t. DeBruijn a => Tele (Dom t) -> [NamedArg a]
teleNamedArgs Tele (Dom Type)
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)
clauseTel         = Tele (Dom Type)
gamma
          , clauseType :: Maybe (Arg Type)
clauseType        = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Arg Type -> Maybe (Arg Type))
-> (Type -> Arg Type) -> Type -> Maybe (Arg Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Arg Type
forall e. e -> Arg e
argN (Type -> Maybe (Arg Type)) -> Type -> Maybe (Arg Type)
forall a b. (a -> b) -> a -> b
$ Type
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

-- | 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)
-> [QName]
-> Tele (Dom Type)
-> Type
-> TCM ()
defineProjections QName
dataName ConHead
con Tele (Dom Type)
params [QName]
names Tele (Dom Type)
fsT Type
t = do
  let
    -- Γ , (d : T) ⊢ Φ[n ↦ proj n d]
    fieldTypes :: [Dom Type]
fieldTypes = ([ QName -> [Elim' Term] -> Term
Def QName
f [] Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Nat -> Term
var Nat
0] | QName
f <- [QName] -> [QName]
forall a. [a] -> [a]
reverse [QName]
names ] [Term] -> Substitution -> Substitution
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS Nat
1) Substitution' (SubstArg [Dom Type]) -> [Dom Type] -> [Dom Type]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst`
                    Tele (Dom Type) -> [Dom Type]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel Tele (Dom Type)
fsT  -- Γ , Φ ⊢ Φ
    -- ⊢ Γ , (d : T)
    projTel :: Tele (Dom Type)
projTel    = Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
params (Dom Type -> Abs (Tele (Dom Type)) -> Tele (Dom Type)
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type -> Dom Type
forall a t. a -> Dom' t a
defaultDom Type
t) (ArgName -> Tele (Dom Type) -> Abs (Tele (Dom Type))
forall a. ArgName -> a -> Abs a
Abs ArgName
"d" Tele (Dom Type)
forall a. Tele a
EmptyTel))
    np :: Nat
np         = Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
params

  [(Nat, QName, Dom Type)]
-> ((Nat, QName, Dom Type) -> TCM ()) -> TCM ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([Nat] -> [QName] -> [Dom Type] -> [(Nat, QName, Dom Type)]
forall a b c. [a] -> [b] -> [c] -> [(a, b, c)]
zip3 (Nat -> [Nat]
forall a. Integral a => a -> [a]
downFrom ([Dom Type] -> Nat
forall a. Sized a => a -> Nat
size [Dom Type]
fieldTypes)) [QName]
names [Dom Type]
fieldTypes) (((Nat, QName, Dom Type) -> TCM ()) -> TCM ())
-> ((Nat, QName, Dom Type) -> TCM ()) -> TCM ()
forall a b. (a -> b) -> a -> b
$ \ (Nat
i,QName
projName,Dom Type
ty) -> do
    let
      projType :: Dom Type
projType = Tele (Dom Type) -> Type -> Type
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
projTel (Type -> Type) -> Dom Type -> Dom Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom Type
ty
      cpi :: ConPatternInfo
cpi    = PatternInfo
-> Bool -> Bool -> Maybe (Arg Type) -> Bool -> ConPatternInfo
ConPatternInfo PatternInfo
defaultPatternInfo Bool
False Bool
False (Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Arg Type -> Maybe (Arg Type)) -> Arg Type -> Maybe (Arg Type)
forall a b. (a -> b) -> a -> b
$ Type -> Arg Type
forall e. e -> Arg e
argN (Type -> Arg Type) -> Type -> Arg Type
forall a b. (a -> b) -> a -> b
$ Nat -> Type -> Type
forall a. Subst a => Nat -> a -> a
raise (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
fsT) Type
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) -> [Arg (Named_ (Pattern' DBPatVar))]
forall a t. DeBruijn a => Tele (Dom t) -> [NamedArg a]
teleNamedArgs Tele (Dom Type)
fsT
      sigma :: Substitution
sigma  = ConHead -> ConInfo -> [Elim' Term] -> Term
Con ConHead
con ConInfo
ConOSystem ((Arg Term -> Elim' Term) -> Args -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply (Args -> [Elim' Term]) -> Args -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> Args
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom Type)
fsT) Term -> Substitution -> Substitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
`consS` Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
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] -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.proj" Nat
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
<+> (Nat, Dom Type) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => (Nat, Dom Type) -> m Doc
prettyTCM (Nat
i,Dom Type
ty)
      , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ 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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Dom Type -> m Doc
prettyTCM Dom Type
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 (Tele (Dom Type), QName, Type)
-> [Clause] -> TCMT IO (Maybe SplitTree, Bool, CompiledClauses)
compileClauses Maybe (Tele (Dom Type), QName, Type)
forall a. Maybe a
Nothing [Clause]
cs
      let fun = FunctionData
emptyFunctionData
                { _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
                }
      inTopContext $ addConstant projName $
        (defaultDefn defaultArgInfo projName (unDom projType) $ FunctionDefn fun)
          { defNoCompilation  = True
          , defArgOccurrences = [StrictPos]
          }

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


freshAbstractQName'_ :: ShortText -> TCM QName
freshAbstractQName'_ :: ArgName -> TCMT IO QName
freshAbstractQName'_ = Fixity' -> Name -> TCMT IO QName
freshAbstractQName Fixity'
noFixity' (Name -> TCMT IO QName)
-> (ArgName -> Name) -> ArgName -> TCMT IO QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgName -> Name
C.simpleName

-- | 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 -> Nat
dataPars = Nat
npars
             , dataIxs :: Defn -> Nat
dataIxs = Nat
nixs
             , dataSort :: Defn -> Sort
dataSort = Sort
s}
     -> do
      let t :: Type
t = Definition -> Type
defType Definition
def
      [Char] -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.ixs" Nat
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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t
        , TCMT IO Doc
"npars:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Nat -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Nat
npars
        , TCMT IO Doc
"nixs :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Nat -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Nat
nixs
        ]
      if Nat
nixs Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
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 <- ArgName -> TCMT IO QName
freshAbstractQName'_ (ArgName -> TCMT IO QName) -> ArgName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char] -> ArgName
TS.pack ([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 -> Tele (Dom Type) -> Tele (Dom Type)
expTelescope Type
interval Tele (Dom Type)
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) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
ixs Substitution' (SubstArg Type) -> Type -> Type
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El (Nat -> Sort -> Sort
forall a. Subst a => Nat -> a -> a
raise (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
ixs) Sort
s) (QName -> [Elim' Term] -> Term
Def QName
d (Tele (Dom Type) -> Boundary -> [Elim' Term]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary' Nat a -> [Elim' a]
teleElims (Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
params Tele (Dom Type)
ixs) Boundary
forall a. Null a => a
empty))
      addContext params $ reportSDoc "tc.data.ixs" 20 $ "deltaI:" <+> prettyTCM deltaI
      addContext params $ addContext deltaI $ addContext ("i" :: ShortText, 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 -> NamesT Identity Type
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
rect')
                  nPi' "phi" (primIntervalType) $ \ NamesT (TCMT IO) Term
phi ->
                   (Abs Type -> Term -> Type
Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Type -> Term -> Type)
-> NamesT (TCMT IO) (Abs Type) -> NamesT (TCMT IO) (Term -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Type)
rect' NamesT (TCMT IO) (Term -> Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). HasOptions m => m Type -> m Type -> m Type
--> (Abs Type -> Term -> Type
Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Type -> Term -> Type)
-> NamesT (TCMT IO) (Abs Type) -> NamesT (TCMT IO) (Term -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Type)
rect' NamesT (TCMT IO) (Term -> Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
params (Tele (Dom Type) -> Tele (Dom Type))
-> Tele (Dom Type) -> Tele (Dom Type)
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
deltaI (Tele (Dom Type) -> Tele (Dom Type))
-> Tele (Dom Type) -> Tele (Dom Type)
forall a b. (a -> b) -> a -> b
$ Dom Type -> Abs (Tele (Dom Type)) -> Tele (Dom Type)
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type -> Dom Type
forall a t. a -> Dom' t a
defaultDom (Type -> Dom Type) -> Type -> Dom Type
forall a b. (a -> b) -> a -> b
$ Nat -> SubstArg Type -> Type -> Type
forall a. Subst a => Nat -> SubstArg a -> a -> a
subst Nat
0 Term
SubstArg Type
iz Type
rect') (ArgName -> Tele (Dom Type) -> Abs (Tele (Dom Type))
forall a. ArgName -> a -> Abs a
Abs ArgName
"t" Tele (Dom Type)
forall a. Tele a
EmptyTel)
        ps = Tele (Dom Type) -> Boundary -> [Arg (Named_ (Pattern' DBPatVar))]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary -> [NamedArg (Pattern' a)]
telePatterns Tele (Dom Type)
ctel Boundary
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
        let fun = FunctionData
emptyFunctionData
                  { _funClauses    = cs
                  , _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 $ 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
sub a
tel = Nat -> Substitution
expS (Nat -> Substitution) -> Nat -> Substitution
forall a b. (a -> b) -> a -> b
$ a -> Nat
forall a. Sized a => a -> Nat
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 -> Nat
dataPars = Nat
npars
             , dataIxs :: Defn -> Nat
dataIxs = Nat
nixs
             , dataSort :: Defn -> Sort
dataSort = s :: Sort
s@(Type Level
_)
--             , dataCons = cons -- not there yet
             }
     -> do
      let t :: Type
t = Definition -> Type
defType Definition
def
      [Char] -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp" Nat
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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t
        , TCMT IO Doc
"npars:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Nat -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Nat
npars
        , TCMT IO Doc
"nixs :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Nat -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Nat
nixs
        ]
      trD <- ArgName -> TCMT IO QName
freshAbstractQName'_ (ArgName -> TCMT IO QName) -> ArgName -> TCMT IO QName
forall a b. (a -> b) -> a -> b
$ [Char] -> ArgName
TS.pack ([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) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
params Tele (Dom Type)
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 -> Tele (Dom Type) -> Tele (Dom Type)
expTelescope Type
interval Tele (Dom Type)
tel
          sigma = Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
tel
          dTs = (Substitution
Substitution' (SubstArg Type)
sigma Substitution' (SubstArg Type) -> Type -> Type
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Sort -> Term -> Type
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) -> Args -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply (Args -> [Elim' Term]) -> Args -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> Args
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom Type)
tel))

      theType <- (abstract telI <$>) $ runNamesT [] $ do
                  dT <- open $ Abs "i" $ dTs
                  nPi' "phi" primIntervalType $ \ NamesT (TCMT IO) Term
phi ->
                   (Abs Type -> Term -> Type
Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Type -> Term -> Type)
-> NamesT (TCMT IO) (Abs Type) -> NamesT (TCMT IO) (Term -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Type)
dT NamesT (TCMT IO) (Term -> Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). HasOptions m => m Type -> m Type -> m Type
--> (Abs Type -> Term -> Type
Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Type -> Term -> Type)
-> NamesT (TCMT IO) (Abs Type) -> NamesT (TCMT IO) (Term -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Type)
dT NamesT (TCMT IO) (Term -> Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
        let fun = Defn
emptyFunction
        inTopContext $ addConstant trD $
          (defaultDefn defaultArgInfo trD theType fun)
        let
          ctel = Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
telI (Tele (Dom Type) -> Tele (Dom Type))
-> Tele (Dom Type) -> Tele (Dom Type)
forall a b. (a -> b) -> a -> b
$ Dom Type -> Abs (Tele (Dom Type)) -> Tele (Dom Type)
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type -> Dom Type
forall a t. a -> Dom' t a
defaultDom (Type -> Dom Type) -> Type -> Dom Type
forall a b. (a -> b) -> a -> b
$ Nat -> SubstArg Type -> Type -> Type
forall a. Subst a => Nat -> SubstArg a -> a -> a
subst Nat
0 Term
SubstArg Type
iz Type
dTs) (ArgName -> Tele (Dom Type) -> Abs (Tele (Dom Type))
forall a. ArgName -> a -> Abs a
Abs ArgName
"t" Tele (Dom Type)
forall a. Tele a
EmptyTel)
          ps = Tele (Dom Type) -> Boundary -> [Arg (Named_ (Pattern' DBPatVar))]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary -> [NamedArg (Pattern' a)]
telePatterns Tele (Dom Type)
ctel Boundary
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] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp" Nat
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ (ArgName, Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
(ArgName, Dom Type) -> m a -> m a
addContext (ArgName
"i" :: ShortText, Dom Type
HasCallStack => Dom Type
__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)
cl -> Closure (Abs Type) -> 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)
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 (Tele (Dom Type), QName, Type)
-> [Clause] -> TCMT IO (Maybe SplitTree, Bool, CompiledClauses)
compileClauses Maybe (Tele (Dom Type), QName, Type)
forall a. Maybe a
Nothing [Clause]
cs
        let fun = FunctionData
emptyFunctionData
                  { _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 $ 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
sub a
tel = Nat -> Substitution
expS (a -> Nat
forall a. Sized a => a -> Nat
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
-> Nat
-> Nat
-> Tele (Dom Type)
-> Tele (Dom Type)
-> Substitution
-> Type
-> [QName]
-> TCM [Clause]
defineConClause QName
trD' Bool
isHIT Maybe QName
mtrX Nat
npars Nat
nixs Tele (Dom Type)
xTel' Tele (Dom Type)
telI Substitution
sigma Type
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
== (Nat
nixs Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
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
ty [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
sys NamesT (TCMT IO) Term
u0 = do
          ty <- NamesT (TCMT IO) Type
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 ArgName
nm = Dom Type -> Abs (Tele (Dom Type)) -> Tele (Dom Type)
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type -> Dom Type
forall a t. a -> Dom' t a
defaultDom Type
interval) (ArgName -> Tele (Dom Type) -> Abs (Tele (Dom Type))
forall a. ArgName -> a -> Abs a
Abs ArgName
nm Tele (Dom Type)
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))
k = do
               ixsI <- AbsN (Tele (Dom Type))
-> NamesT m (NamesT m (AbsN (Tele (Dom Type))))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (AbsN (Tele (Dom Type))
 -> NamesT m (NamesT m (AbsN (Tele (Dom Type)))))
-> AbsN (Tele (Dom Type))
-> NamesT m (NamesT m (AbsN (Tele (Dom Type))))
forall a b. (a -> b) -> a -> b
$ Names -> Tele (Dom Type) -> AbsN (Tele (Dom Type))
forall a. Names -> a -> AbsN a
AbsN (Tele (Dom Type) -> Names
teleNames Tele (Dom Type)
parI) Tele (Dom Type)
ixsI
               parI <- open parI
               abstractN parI $ \ Vars m
delta -> do
               NamesT m (Tele (Dom Type))
-> (Vars m -> NamesT m (Tele (Dom Type)))
-> NamesT m (Tele (Dom Type))
forall (m :: * -> *) a.
(Monad m, Abstract a) =>
NamesT m (Tele (Dom Type)) -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (NamesT m (AbsN (Tele (Dom Type)))
ixsI NamesT m (AbsN (Tele (Dom Type)))
-> [NamesT m (SubstArg (Tele (Dom Type)))]
-> NamesT m (Tele (Dom Type))
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)))]
Vars m
delta) ((Vars m -> NamesT m (Tele (Dom Type)))
 -> NamesT m (Tele (Dom Type)))
-> (Vars m -> NamesT m (Tele (Dom Type)))
-> NamesT m (Tele (Dom Type))
forall a b. (a -> b) -> a -> b
$ \ Vars m
x -> do
               NamesT m (Tele (Dom Type))
-> (Vars m -> NamesT m (Tele (Dom Type)))
-> NamesT m (Tele (Dom Type))
forall (m :: * -> *) a.
(Monad m, Abstract a) =>
NamesT m (Tele (Dom Type)) -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (Tele (Dom Type) -> NamesT m (Tele (Dom Type))
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tele (Dom Type) -> NamesT m (Tele (Dom Type)))
-> Tele (Dom Type) -> NamesT m (Tele (Dom Type))
forall a b. (a -> b) -> a -> b
$ ArgName -> Tele (Dom Type)
intervalTel ArgName
"phi") ((Vars m -> NamesT m (Tele (Dom Type)))
 -> NamesT m (Tele (Dom Type)))
-> (Vars m -> NamesT m (Tele (Dom Type)))
-> NamesT m (Tele (Dom Type))
forall a b. (a -> b) -> a -> b
$ \ Vars m
phi -> do
               Vars m -> Vars m -> Vars m -> NamesT m (Tele (Dom Type))
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 ArgName]
-> (ArgVars m -> NamesT m (AbsN (AbsN b)))
-> NamesT m (AbsN (AbsN (AbsN b)))
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom Type) -> [Arg ArgName]
teleArgNames Tele (Dom Type)
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 ArgName]
-> (ArgVars m -> NamesT m (AbsN b)) -> NamesT m (AbsN (AbsN b))
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom Type) -> [Arg ArgName]
teleArgNames Tele (Dom Type)
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 ArgName] -> (ArgVars m -> NamesT m b) -> NamesT m (AbsN b)
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom Type) -> [Arg ArgName]
teleArgNames (Tele (Dom Type) -> [Arg ArgName])
-> Tele (Dom Type) -> [Arg ArgName]
forall a b. (a -> b) -> a -> b
$ ArgName -> Tele (Dom Type)
intervalTel ArgName
"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 ArgName]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN (AbsN Term)))
-> NamesT (TCMT IO) (AbsN (AbsN (AbsN Term)))
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom Type) -> [Arg ArgName]
teleArgNames Tele (Dom Type)
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 ArgName]
-> (ArgVars (TCMT IO) -> NamesT (TCMT IO) (AbsN Term))
-> NamesT (TCMT IO) (AbsN (AbsN Term))
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg (Tele (Dom Type) -> [Arg ArgName]
teleArgNames Tele (Dom Type)
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 [ArgName
"phi",ArgName
"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 -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply`) (Args -> Term) -> NamesT (TCMT IO) Args -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamesT (TCMT IO) (Arg Term)] -> NamesT (TCMT IO) Args
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)) -> NamesT (TCMT IO) (AbsN (Tele (Dom Type)))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN (Tele (Dom Type))
 -> NamesT (TCMT IO) (AbsN (Tele (Dom Type))))
-> AbsN (Tele (Dom Type))
-> NamesT (TCMT IO) (AbsN (Tele (Dom Type)))
forall a b. (a -> b) -> a -> b
$ Names -> Tele (Dom Type) -> AbsN (Tele (Dom Type))
forall a. Names -> a -> AbsN a
AbsN (Tele (Dom Type) -> Names
teleNames Tele (Dom Type)
parI) Tele (Dom Type)
xTel'
  -- [δ : Δ^I, x : X^I, i : I] ⊢ D (δ i) (x i)
  let dT = AbsN Type -> NamesT (TCMT IO) (AbsN Type)
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (AbsN Type -> NamesT (TCMT IO) (AbsN Type))
-> AbsN Type -> NamesT (TCMT IO) (AbsN Type)
forall a b. (a -> b) -> a -> b
$ Names -> Type -> AbsN Type
forall a. Names -> a -> AbsN a
AbsN (Tele (Dom Type) -> Names
teleNames Tele (Dom Type)
parI Names -> Names -> Names
forall a. [a] -> [a] -> [a]
++! Tele (Dom Type) -> Names
teleNames Tele (Dom Type)
ixsI Names -> Names -> Names
forall a. [a] -> [a] -> [a]
++! [ArgName
"i"]) Type
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
|| Nat
nixs Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
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 -> NamesT (TCMT IO) (Maybe LType))
-> Type
-> NamesT (TCMT IO) LType
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Type -> NamesT (TCMT IO) (Maybe LType)
forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType (Type -> NamesT (TCMT IO) LType)
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) LType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (NamesT (TCMT IO) (AbsN Type)
dT NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
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 = (ArgName -> Arg ArgName) -> Names -> [Arg ArgName]
forall a b. (a -> b) -> [a] -> [b]
map' ArgName -> Arg ArgName
forall e. e -> Arg e
argN [ArgName
"phi",ArgName
"u",ArgName
"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 ArgName]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT
     (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg ArgName]
hcompArgs ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
 -> NamesT
      (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term)))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT
     (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, 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 -> NamesT (TCMT IO) (Maybe LType))
-> Type
-> NamesT (TCMT IO) LType
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Type -> NamesT (TCMT IO) (Maybe LType)
forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType (Type -> NamesT (TCMT IO) LType)
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) LType
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (NamesT (TCMT IO) (AbsN Type)
dT NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
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
Level Level
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
rhsTy = NamesT (TCMT IO) (AbsN Type)
dT NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
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 = ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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 -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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
-> [(NamesT (TCMT IO) Term, NamesT (TCMT IO) Term)]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term
hcomp NamesT (TCMT IO) Type
rhsTy [(NamesT (TCMT IO) Term
hphi, NamesT (TCMT IO) Term
sideHComp)] NamesT (TCMT IO) Term
baseHComp
        (,,) ([Arg (Named_ (Pattern' DBPatVar))]
 -> Type
 -> Term
 -> ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
-> NamesT
     (TCMT IO)
     (Type -> Term -> ([Arg (Named_ (Pattern' DBPatVar))], Type, 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 -> ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT (TCMT IO) Type
-> NamesT
     (TCMT IO)
     (Term -> ([Arg (Named_ (Pattern' DBPatVar))], Type, 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
rhsTy NamesT
  (TCMT IO)
  (Term -> ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT (TCMT IO) Term
-> NamesT
     (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, 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] -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Nat
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"======================="
        [Char] -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Nat
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)) -> TCMT IO (Tele (Dom Type))
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) (Tele (Dom Type)) -> TCMT IO (Tele (Dom Type)))
-> NamesT (TCMT IO) (Tele (Dom Type)) -> TCMT IO (Tele (Dom Type))
forall a b. (a -> b) -> a -> b
$ do
                     ixsI <- AbsN (Tele (Dom Type))
-> NamesT (TCMT IO) (NamesT (TCMT IO) (AbsN (Tele (Dom Type))))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (AbsN (Tele (Dom Type))
 -> NamesT (TCMT IO) (NamesT (TCMT IO) (AbsN (Tele (Dom Type)))))
-> AbsN (Tele (Dom Type))
-> NamesT (TCMT IO) (NamesT (TCMT IO) (AbsN (Tele (Dom Type))))
forall a b. (a -> b) -> a -> b
$ Names -> Tele (Dom Type) -> AbsN (Tele (Dom Type))
forall a. Names -> a -> AbsN a
AbsN (Tele (Dom Type) -> Names
teleNames Tele (Dom Type)
parI) Tele (Dom Type)
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]
Vars (TCMT IO)
delta [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
<&> \ NamesT (TCMT IO) Term
p -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Tele (Dom Type))
forall (m :: * -> *) a.
(Monad m, Abstract a) =>
NamesT m (Tele (Dom Type)) -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (NamesT (TCMT IO) (AbsN (Tele (Dom Type)))
ixsI NamesT (TCMT IO) (AbsN (Tele (Dom Type)))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom Type)))]
-> NamesT (TCMT IO) (Tele (Dom Type))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` [NamesT (TCMT IO) Term]
[NamesT (TCMT IO) (SubstArg (Tele (Dom Type)))]
delta0_refl) ((Vars (TCMT IO) -> NamesT (TCMT IO) (Tele (Dom Type)))
 -> NamesT (TCMT IO) (Tele (Dom Type)))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Tele (Dom Type))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
x' -> do
                     NamesT (TCMT IO) (Tele (Dom Type))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Tele (Dom Type))
forall (m :: * -> *) a.
(Monad m, Abstract a) =>
NamesT m (Tele (Dom Type)) -> (Vars m -> NamesT m a) -> NamesT m a
abstractN (Tele (Dom Type) -> NamesT (TCMT IO) (Tele (Dom Type))
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Tele (Dom Type) -> NamesT (TCMT IO) (Tele (Dom Type)))
-> Tele (Dom Type) -> NamesT (TCMT IO) (Tele (Dom Type))
forall a b. (a -> b) -> a -> b
$ ArgName -> Tele (Dom Type)
intervalTel ArgName
"phi'") ((Vars (TCMT IO) -> NamesT (TCMT IO) (Tele (Dom Type)))
 -> NamesT (TCMT IO) (Tele (Dom Type)))
-> (Vars (TCMT IO) -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Tele (Dom Type))
forall a b. (a -> b) -> a -> b
$ \ Vars (TCMT IO)
_ -> do
                     ty <- NamesT (TCMT IO) (AbsN Type)
dT NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
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 ArgName]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         (AbsN (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))))
-> NamesT
     (TCMT IO)
     (AbsN
        (AbsN (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))))
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg ((Arg ArgName -> Arg ArgName) -> [Arg ArgName] -> [Arg ArgName]
forall a b. (a -> b) -> [a] -> [b]
map' ((ArgName -> ArgName) -> Arg ArgName -> Arg ArgName
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ArgName -> ArgName -> ArgName
forall a. Semigroup a => a -> a -> a
<> ArgName
"'")) (Tele (Dom Type) -> [Arg ArgName]
teleArgNames Tele (Dom Type)
ixsI)) ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO)
       (AbsN (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))))
 -> NamesT
      (TCMT IO)
      (AbsN
         (AbsN (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term)))))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO)
         (AbsN (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))))
-> NamesT
     (TCMT IO)
     (AbsN
        (AbsN (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, 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 ArgName]
phi'name = Tele (Dom Type) -> [Arg ArgName]
teleArgNames (Tele (Dom Type) -> [Arg ArgName])
-> Tele (Dom Type) -> [Arg ArgName]
forall a b. (a -> b) -> a -> b
$ ArgName -> Tele (Dom Type)
intervalTel ArgName
"phi'"
          [Arg ArgName]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term)))
-> NamesT
     (TCMT IO)
     (AbsN (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term)))
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg ArgName]
phi'name ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term)))
 -> NamesT
      (TCMT IO)
      (AbsN (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term)))
-> NamesT
     (TCMT IO)
     (AbsN (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, 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 ArgName]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT
     (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [ArgName -> Arg ArgName
forall e. e -> Arg e
argN ArgName
"t"] ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
 -> NamesT
      (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term)))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT
     (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
forall a b. (a -> b) -> a -> b
$ \ ArgVars (TCMT IO)
as0 -> do
          let deltaArg :: NamesT (TCMT IO) Term -> NamesT (TCMT IO) Args
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
rhsTy = NamesT (TCMT IO) (AbsN Type)
dT NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
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)))
telXdeltai = ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Tele (Dom Type)))
 -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
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)))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom Type)))]
-> NamesT (TCMT IO) (Tele (Dom Type))
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)))
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]
x [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
<&> \ NamesT (TCMT IO) Term
q -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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]
x' [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
<&> \ NamesT (TCMT IO) Term
q' -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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))
-> Args -> 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) (Args -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) Args
-> 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)))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Args
transpPathTel' NamesT (TCMT IO) (Abs (Tele (Dom Type)))
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 = ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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 -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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]
delta [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
<&> \ NamesT (TCMT IO) Term
p -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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]
x_tr [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
<&> \ NamesT (TCMT IO) Term
p -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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) Args
x_tr_f = (Abs Args -> Args)
-> NamesT (TCMT IO) (Abs Args) -> NamesT (TCMT IO) Args
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)] -> Args
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Abs ArgName
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 (ArgName -> Term -> Abs Term
forall a. ArgName -> a -> Abs a
Abs ArgName
n Term
t)) ([Abs (Arg Term)] -> Args)
-> (Abs Args -> [Abs (Arg Term)]) -> Abs Args -> Args
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Args -> [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 Args) -> NamesT (TCMT IO) Args)
-> NamesT (TCMT IO) (Abs Args) -> NamesT (TCMT IO) Args
forall a b. (a -> b) -> a -> b
$
                           ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) Args)
-> NamesT (TCMT IO) (Abs Args)
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) Args)
 -> NamesT (TCMT IO) (Abs Args))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) Args)
-> NamesT (TCMT IO) (Abs Args)
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) Args
args = (Args -> Args -> Args)
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) Args
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Args -> Args -> Args
forall a. [a] -> [a] -> [a]
(++) ((Arg Term -> Arg Term) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map' (Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) (Args -> Args) -> NamesT (TCMT IO) Args -> NamesT (TCMT IO) Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Args
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) Args
x_tr_f
                      (Term -> Args -> Term
forall t. Apply t => t -> Args -> t
apply (QName -> [Elim' Term] -> Term
Def QName
trX []) (Args -> Term) -> NamesT (TCMT IO) Args -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Args
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
_ -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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
 -> ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT (TCMT IO) [Arg (Named_ (Pattern' DBPatVar))]
-> NamesT
     (TCMT IO)
     (Type -> Term -> ([Arg (Named_ (Pattern' DBPatVar))], Type, 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 -> ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT (TCMT IO) Type
-> NamesT
     (TCMT IO)
     (Term -> ([Arg (Named_ (Pattern' DBPatVar))], Type, 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
rhsTy NamesT
  (TCMT IO)
  (Term -> ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT (TCMT IO) Term
-> NamesT
     (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, 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
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] -> Args
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims ([Elim' Term] -> Args) -> [Elim' Term] -> Args
forall a b. (a -> b) -> a -> b
$ Nat -> [Elim' Term] -> [Elim' Term]
forall a. Nat -> [a] -> [a]
drop Nat
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))
args = NamesT (TCMT IO) (AbsN (Tele (Dom Type)))
aTel NamesT (TCMT IO) (AbsN (Tele (Dom Type)))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom Type)))]
-> NamesT (TCMT IO) (Tele (Dom Type))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term -> 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))
args
        res <- runNamesT [] $ do
          let aTelNames = Tele (Dom Type) -> Names
teleNames Tele (Dom Type)
aTel
              aTelArgs = Tele (Dom Type) -> [Arg ArgName]
teleArgNames Tele (Dom Type)
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 -> NamesT (TCMT IO) (Maybe LType)
forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType Type
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
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ ArgName -> Term -> Abs Term
forall a. ArgName -> a -> Abs a
NoAbs ArgName
"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 ArgName]
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT
     (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
forall (m :: * -> *) a.
Monad m =>
[Arg ArgName] -> (ArgVars m -> NamesT m a) -> NamesT m (AbsN a)
bindNArg [Arg ArgName]
aTelArgs ((ArgVars (TCMT IO)
  -> NamesT
       (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
 -> NamesT
      (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, Term)))
-> (ArgVars (TCMT IO)
    -> NamesT
         (TCMT IO) ([Arg (Named_ (Pattern' DBPatVar))], Type, Term))
-> NamesT
     (TCMT IO) (AbsN ([Arg (Named_ (Pattern' DBPatVar))], Type, 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))
aTel0 = NamesT (TCMT IO) (AbsN (Tele (Dom Type)))
aTel NamesT (TCMT IO) (AbsN (Tele (Dom Type)))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom Type)))]
-> NamesT (TCMT IO) (Tele (Dom Type))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term -> 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) -> Boundary -> [Arg (Named_ (Pattern' DBPatVar))]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary -> [NamedArg (Pattern' a)]
telePatterns (Tele (Dom Type) -> Boundary -> [Arg (Named_ (Pattern' DBPatVar))])
-> NamesT (TCMT IO) (Tele (Dom Type))
-> NamesT
     (TCMT IO) (Boundary -> [Arg (Named_ (Pattern' DBPatVar))])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Tele (Dom Type))
aTel0 NamesT (TCMT IO) (Boundary -> [Arg (Named_ (Pattern' DBPatVar))])
-> NamesT (TCMT IO) Boundary
-> 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
forall a. Boundary' Term a -> Boundary' Nat a
varBoundary (Boundary' Term Term -> Boundary)
-> NamesT (TCMT IO) (Boundary' Term Term)
-> NamesT (TCMT IO) Boundary
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)
dT NamesT (TCMT IO) (AbsN Type)
-> [NamesT (TCMT IO) (SubstArg Type)] -> NamesT (TCMT IO) Type
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` ([NamesT (TCMT IO) Term]
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 = ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Tele (Dom Type)))
 -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
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)))
aTel NamesT (TCMT IO) (AbsN (Tele (Dom Type)))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom Type)))]
-> NamesT (TCMT IO) (Tele (Dom Type))
forall (m :: * -> *) a.
(Monad m, Subst a) =>
NamesT m (AbsN a) -> [NamesT m (SubstArg a)] -> NamesT m a
`applyN` (NamesT (TCMT IO) Term -> 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) $ \ Args
as1 -> do

          as1 <- (Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> Args -> 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) Args
as1

          as01 <- (open =<<) $ bind "i" $ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> do
            eas01 <- (ExceptT (Closure (Abs Type)) (TCMT IO) Args
 -> NamesT (TCMT IO) (Either (Closure (Abs Type)) Args))
-> NamesT (TCMT IO) (ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) Args)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
(=<<) (TCMT IO (Either (Closure (Abs Type)) Args)
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) Args)
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)) Args)
 -> NamesT (TCMT IO) (Either (Closure (Abs Type)) Args))
-> (ExceptT (Closure (Abs Type)) (TCMT IO) Args
    -> TCMT IO (Either (Closure (Abs Type)) Args))
-> ExceptT (Closure (Abs Type)) (TCMT IO) Args
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) Args)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (Closure (Abs Type)) (TCMT IO) Args
-> TCMT IO (Either (Closure (Abs Type)) Args)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT) (NamesT (TCMT IO) (ExceptT (Closure (Abs Type)) (TCMT IO) Args)
 -> NamesT (TCMT IO) (Either (Closure (Abs Type)) Args))
-> NamesT (TCMT IO) (ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) Args)
forall a b. (a -> b) -> a -> b
$ Abs (Tele (Dom Type))
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) Args
trFillTel (Abs (Tele (Dom Type))
 -> Term
 -> Args
 -> Term
 -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
-> NamesT
     (TCMT IO)
     (Term
      -> Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
aTelI NamesT
  (TCMT IO)
  (Term
   -> Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> NamesT (TCMT IO) Term
-> NamesT
     (TCMT IO)
     (Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
phi NamesT
  (TCMT IO)
  (Args -> Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
-> NamesT (TCMT IO) Args
-> NamesT
     (TCMT IO) (Term -> ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [NamesT (TCMT IO) (Arg Term)] -> NamesT (TCMT IO) Args
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)) (TCMT IO) Args)
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) (ExceptT (Closure (Abs Type)) (TCMT IO) Args)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
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 -> Args -> b
forall t. Apply t => t -> Args -> 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 ArgName
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
$ ArgName -> Term -> Abs Term
forall a. ArgName -> a -> Abs a
Abs ArgName
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
<$> ArgName
-> (Var m -> NamesT m (Arg Term)) -> NamesT m (Abs (Arg Term))
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"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))))
theTel = ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
-> NamesT (TCMT IO) (Abs (Abs (Tele (Dom Type))))
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"j" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
 -> NamesT (TCMT IO) (Abs (Abs (Tele (Dom Type)))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
-> NamesT (TCMT IO) (Abs (Abs (Tele (Dom Type))))
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Tele (Dom Type)))
 -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
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)))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom Type)))]
-> NamesT (TCMT IO) (Tele (Dom Type))
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)))
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
$ ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"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))
-> Args -> 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) (Args -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Abs Args -> Term -> Args
Abs Args -> SubstArg Args -> Args
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Args -> Term -> Args)
-> NamesT (TCMT IO) (Abs Args) -> NamesT (TCMT IO) (Term -> Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Args)
as01 NamesT (TCMT IO) (Term -> Args)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Args
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
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 = (Args -> Args -> Args)
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) Args
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Args -> Args -> Args
forall a. [a] -> [a] -> [a]
(++) ((Arg Term -> Arg Term) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map' (Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) (Args -> Args) -> NamesT (TCMT IO) Args -> NamesT (TCMT IO) Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Args
deltaArg (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)) (Args
-> (Arg Term -> NamesT (TCMT IO) (Arg Term))
-> NamesT (TCMT IO) Args
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Args
trx' ((Arg Term -> NamesT (TCMT IO) (Arg Term))
 -> NamesT (TCMT IO) Args)
-> (Arg Term -> NamesT (TCMT IO) (Arg Term))
-> NamesT (TCMT IO) Args
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))))
theTel = ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
-> NamesT (TCMT IO) (Abs (Abs (Tele (Dom Type))))
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"j" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
 -> NamesT (TCMT IO) (Abs (Abs (Tele (Dom Type)))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
-> NamesT (TCMT IO) (Abs (Abs (Tele (Dom Type))))
forall a b. (a -> b) -> a -> b
$ \ forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"i" (((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Tele (Dom Type)))
 -> NamesT (TCMT IO) (Abs (Tele (Dom Type))))
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Tele (Dom Type)))
-> NamesT (TCMT IO) (Abs (Tele (Dom Type)))
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)))
-> [NamesT (TCMT IO) (SubstArg (Tele (Dom Type)))]
-> NamesT (TCMT IO) (Tele (Dom Type))
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)))
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
$ ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"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))
-> Args -> 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) (Args -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Abs Args -> Term -> Args
Abs Args -> SubstArg Args -> Args
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Args -> Term -> Args)
-> NamesT (TCMT IO) (Abs Args) -> NamesT (TCMT IO) (Term -> Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Args)
as01 NamesT (TCMT IO) (Term -> Args)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Args
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
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 = ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"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) -> Args -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg (Args -> [Term])
-> NamesT (TCMT IO) Args -> NamesT (TCMT IO) [Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Abs (Tele (Dom Type))))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Args
trFillPathPTel' NamesT (TCMT IO) (Abs (Abs (Tele (Dom Type))))
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))
-> Args -> 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) (Args -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Abs Args -> Term -> Args
Abs Args -> SubstArg Args -> Args
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Args -> Term -> Args)
-> NamesT (TCMT IO) (Abs Args) -> NamesT (TCMT IO) (Term -> Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Args)
as01 NamesT (TCMT IO) (Term -> Args)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Args
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
i)
                     applyN bsys $ map' (<@> i) delta ++! as01
                let squeezedv0 :: NamesT (TCMT IO) Term
squeezedv0 = ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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]
delta [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
<&> \ NamesT (TCMT IO) Term
p -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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
$ ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
Monad m =>
ArgName
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind ArgName
"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 -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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))))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Args
transpPathPTel' NamesT (TCMT IO) (Abs (Abs (Tele (Dom Type))))
theTel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
theRight NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
theLeft
                  let args = (Args -> Args -> Args)
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) Args
-> NamesT (TCMT IO) Args
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Args -> Args -> Args
forall a. [a] -> [a] -> [a]
(++) ((Arg Term -> Arg Term) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map' (Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) (Args -> Args) -> NamesT (TCMT IO) Args -> NamesT (TCMT IO) Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Args
deltaArg (Term -> NamesT (TCMT IO) Term
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io))
                                         (Args
-> (Arg Term -> NamesT (TCMT IO) (Arg Term))
-> NamesT (TCMT IO) Args
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM Args
q2 ((Arg Term -> NamesT (TCMT IO) (Arg Term))
 -> NamesT (TCMT IO) Args)
-> (Arg Term -> NamesT (TCMT IO) (Arg Term))
-> NamesT (TCMT IO) Args
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
_ -> ArgName
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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)
-> [Arg (Named_ (Pattern' DBPatVar))] -> Type -> Term -> m Clause
mkClause Tele (Dom Type)
gamma [Arg (Named_ (Pattern' DBPatVar))]
ps Type
rhsTy Term
rhs = do
      let
        c :: Clause
c = Clause
            { clauseTel :: Tele (Dom Type)
clauseTel         = Tele (Dom Type)
gamma
            , clauseType :: Maybe (Arg Type)
clauseType        = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Arg Type -> Maybe (Arg Type))
-> (Type -> Arg Type) -> Type -> Maybe (Arg Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Arg Type
forall e. e -> Arg e
argN (Type -> Maybe (Arg Type)) -> Type -> Maybe (Arg Type)
forall a b. (a -> b) -> a -> b
$ Type
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] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Nat
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) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
gamma
      [Char] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Nat
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> 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) -> m a -> m a
addContext Tele (Dom Type)
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] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Nat
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> 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) -> m a -> m a
addContext Tele (Dom Type)
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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
rhsTy
      [Char] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Nat
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> 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) -> m a -> m a
addContext Tele (Dom Type)
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] -> Nat -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.transp.con" Nat
30 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$
        Tele (Dom Type) -> 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) -> m a -> m a
addContext Tele (Dom Type)
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)
-> Tele (Dom Type)
-> [Arg QName]
-> Type
-> TCM
     (Maybe
        ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution))
defineKanOperationForFields Command
cmd Maybe Term
pathCons Term -> QName -> Term
project QName
name Tele (Dom Type)
params Tele (Dom Type)
fsT [Arg QName]
fns Type
rect =
   case Command
cmd of
       Command
DoTransp -> MaybeT
  (TCMT IO)
  ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution)
-> TCM
     (Maybe
        ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   (TCMT IO)
   ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution)
 -> TCM
      (Maybe
         ((QName, Tele (Dom Type), Type, [Dom Type], [Term]),
          Substitution)))
-> MaybeT
     (TCMT IO)
     ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution)
-> TCM
     (Maybe
        ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution))
forall a b. (a -> b) -> a -> b
$ do
         fsT' <- (Dom Type -> MaybeT (TCMT IO) (Dom CType))
-> Tele (Dom Type) -> 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 -> MaybeT (TCMT IO) CType)
-> Dom Type -> 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 -> TCMT IO (Maybe CType))
-> Type
-> MaybeT (TCMT IO) CType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TCMT IO (Maybe CType)
forall (m :: * -> *). MonadReduce m => Type -> m (Maybe CType)
toCType)) Tele (Dom Type)
fsT
         lift $ defineTranspForFields pathCons project name params fsT' fns rect
       Command
DoHComp -> MaybeT
  (TCMT IO)
  ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution)
-> TCM
     (Maybe
        ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   (TCMT IO)
   ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution)
 -> TCM
      (Maybe
         ((QName, Tele (Dom Type), Type, [Dom Type], [Term]),
          Substitution)))
-> MaybeT
     (TCMT IO)
     ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution)
-> TCM
     (Maybe
        ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution))
forall a b. (a -> b) -> a -> b
$ do
         fsT' <- (Dom Type -> MaybeT (TCMT IO) (Dom LType))
-> Tele (Dom Type) -> 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 -> MaybeT (TCMT IO) LType)
-> Dom Type -> 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 -> TCMT IO (Maybe LType))
-> Type
-> MaybeT (TCMT IO) LType
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TCMT IO (Maybe LType)
forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType)) Tele (Dom Type)
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)
-> Tele (Dom CType)
-> [Arg QName]
-> Type
-> TCMT
     IO
     ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution)
defineTranspForFields Maybe Term
pathCons Term -> QName -> Term
applyProj QName
name Tele (Dom Type)
params Tele (Dom CType)
fsT [Arg QName]
fns Type
rect = do
  interval <- TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
  let deltaI = Type -> Tele (Dom Type) -> Tele (Dom Type)
expTelescope Type
interval Tele (Dom Type)
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'_ $ TS.pack (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 -> NamesT Identity Type
forall a. a -> NamesT Identity a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Type
rect')
              nPi' "phi" primIntervalType $ \ NamesT (TCMT IO) Term
phi ->
               (Abs Type -> Term -> Type
Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Type -> Term -> Type)
-> NamesT (TCMT IO) (Abs Type) -> NamesT (TCMT IO) (Term -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Type)
rect' NamesT (TCMT IO) (Term -> Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). HasOptions m => m Type -> m Type -> m Type
--> (Abs Type -> Term -> Type
Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Type -> Term -> Type)
-> NamesT (TCMT IO) (Abs Type) -> NamesT (TCMT IO) (Term -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Type)
rect' NamesT (TCMT IO) (Term -> Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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')

  let fun = FunctionData
emptyFunctionData
  noMutualBlock $ addConstant theName $
    (defaultDefn defaultArgInfo theName theType
       (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 -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` Tele (Dom Type) -> Args
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom Type)
gamma

      -- (γ : Γ) ⊢ (flatten Φ[δ i1])[n ↦ f_n (transpR γ)]
      clause_types = [Term] -> Substitution
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 (Nat -> Term -> Substitution
forall a. DeBruijn a => Nat -> a -> Substitution' a
singletonS Nat
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 = (Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
1 (Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
gamma Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
deltaI)) Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
params) -- Defined but not used

      -- Γ, i : I ⊢ Φ[δ i]
      fsT' = (Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
1 (Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
gamma Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
deltaI)) Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
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
. ArgName -> Term -> Abs Term
forall a. ArgName -> a -> Abs a
Abs ArgName
"i"



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

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

      -- δ : Δ^I, φ : F ⊢ [δ 0] : Δ
      d0 :: Substitution
      d0 = Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
wkS Nat
1 -- Δ^I, φ : F ⊢ Δ
                       (Term -> Substitution -> Substitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
iz Substitution
forall a. Substitution' a
IdS Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
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) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
gamma' (Substitution
Substitution' (SubstArg (Tele (Dom Type)))
d0 Substitution' (SubstArg (Tele (Dom Type)))
-> Tele (Dom Type) -> Tele (Dom Type)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` (Dom CType -> Dom Type) -> Tele (Dom CType) -> Tele (Dom Type)
forall a b. (a -> b) -> Tele a -> Tele b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((CType -> Type) -> Dom CType -> Dom Type
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
fromCType) Tele (Dom CType)
fsT) -- Ξ = δ : Δ^I, φ : F, _ : Φ[δ i0]
                    , (Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
liftS (Tele (Dom CType) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom CType)
fsT) Substitution
d0 Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u) Term -> Substitution -> Substitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
`consS` Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS (Tele (Dom CType) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom CType)
fsT)
                    , Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise (Tele (Dom CType) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom CType)
fsT) (Nat -> Term
var Nat
0)
                    , (Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
liftS (Tele (Dom CType) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom CType)
fsT) Substitution
d0 Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u)
                    , Nat -> [Term] -> [Term]
forall a. Nat -> [a] -> [a]
drop (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
gamma') ([Term] -> [Term]) -> [Term] -> [Term]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> Term) -> Args -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg (Args -> [Term]) -> Args -> [Term]
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> Args
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom Type)
tel)
          Maybe Term
Nothing -> (Tele (Dom Type)
gamma, Substitution
forall a. Substitution' a
IdS, Nat -> Term
var Nat
1, Nat -> Term
var Nat
0, (Arg QName -> Term) -> [Arg QName] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' (\ Arg QName
fname -> Nat -> Term
var Nat
0 Term -> QName -> Term
`applyProj` Arg QName -> QName
forall e. Arg e -> e
unArg Arg QName
fname) [Arg QName]
fns )

      fsT_tel = (Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
1 (Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
tel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
deltaI)) Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
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 -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
x, Term -> Arg Term
forall e. e -> Arg e
argN Term
y]
      iMax Term
x Term
y = Term
imax Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
x, Term -> Arg Term
forall e. e -> Arg e
argN Term
y]
      iNeg Term
x = Term
ineg Term -> Args -> Term
forall t. Apply t => t -> Args -> 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
forall t a. Type'' t a -> a
unEl (Type -> Term) -> (Dom CType -> Type) -> Dom CType -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CType -> Type
fromCType (CType -> Type) -> (Dom CType -> CType) -> Dom CType -> Type
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
l Term
_) -> do
            let lvl :: Term
lvl = Term -> Term
lam_i (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Level -> Term
Level Level
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
forall a. DeBruijn a => [a] -> Substitution' a
parallelS ([Term] -> Substitution) -> [Term] -> Substitution
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 (Nat -> Term
var Nat
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
$ ArgName -> Term -> Abs Term
forall a. ArgName -> a -> Abs a
Abs ArgName
"i" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise Nat
1 Term
d Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ (Term -> Term -> Term
iMin (Nat -> Term
var Nat
0) (Nat -> Term
var Nat
1))]) [Term]
ds
         where
          -- Ξ, i : I
          ([Term]
us, Term
phi:[Term]
ds) = Nat -> [Term] -> ([Term], [Term])
forall a. Nat -> [a] -> ([a], [a])
splitAt' (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
tel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
gamma') ([Term] -> ([Term], [Term])) -> [Term] -> ([Term], [Term])
forall a b. (a -> b) -> a -> b
$ [Term] -> [Term]
forall a. [a] -> [a]
reverse (Nat -> [Term] -> [Term]
forall a. Subst a => Nat -> a -> a
raise Nat
1 ((Arg Term -> Term) -> Args -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg (Tele (Dom Type) -> Args
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom Type)
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
forall a. DeBruijn a => [a] -> Substitution' a
parallelS (Substitution
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
Substitution' (SubstArg [Term])
tau Substitution' (SubstArg [Term]) -> [Term] -> [Term]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` [Term]
bodys) [Term] -> Substitution -> Substitution
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# (Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
1 (Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
tel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
deltaI)) Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
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
rect' = Tele (Dom Type) -> Substitution
forall {a}. Sized a => a -> Substitution
sub Tele (Dom Type)
params Substitution' (SubstArg Type) -> Type -> Type
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Type
rect
    -- Δ^I, i : I |- sub Δ : Δ
    sub :: a -> Substitution
sub a
tel = Nat -> Substitution
expS (Nat -> Substitution) -> Nat -> Substitution
forall a b. (a -> b) -> a -> b
$ a -> Nat
forall a. Sized a => a -> Nat
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)
-> Tele (Dom LType)
-> [Arg QName]
-> LType
-> TCMT
     IO
     ((QName, Tele (Dom Type), Type, [Dom Type], [Term]), Substitution)
defineHCompForFields Term -> QName -> Term
applyProj QName
name Tele (Dom Type)
params Tele (Dom LType)
fsT [Arg QName]
fns LType
rect = do
  interval <- TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
  let delta = Tele (Dom Type)
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'_ $ TS.pack (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 ->
               ArgName
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, MonadDebug m) =>
ArgName
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' ArgName
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT (TCMT IO) Term
i ->
                ArgName
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
ArgName
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' ArgName
"o" NamesT (TCMT IO) Term
phi ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
 -> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Type
rect) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). HasOptions m => m Type -> m Type -> m Type
-->
               NamesT (TCMT IO) Type
rect NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). HasOptions m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Type
rect

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

  let fun = FunctionData
emptyFunctionData
  noMutualBlock $ addConstant theName $
    (defaultDefn defaultArgInfo theName theType
       (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 = Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
gamma Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
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 -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` Tele (Dom Type) -> Args
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs Tele (Dom Type)
gamma

      -- (δ, φ, u, u0) : Γ ⊢ φ : I
      the_phi = Nat -> Term
var Nat
2
      -- (δ, φ, u, u0) : Γ ⊢ u : (i : I) → [φ] → R (δ i)
      the_u   = Nat -> Term
var Nat
1
      -- (δ, φ, u, u0) : Γ ⊢ u0 : R (δ i0)
      the_u0  = Nat -> Term
var Nat
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
forall t a. Type'' t a -> a
unEl  (Type -> Term) -> (LType -> Type) -> LType -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LType -> Type
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 Args
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
<#> ArgName
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"_" (\ 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
<@> ArgName
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"_" (\ 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
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 (Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS (Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
gamma Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
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' = Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS ((Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
gamma Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
delta) Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
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
forall a. DeBruijn a => [a] -> Substitution' a
parallelS [Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise Nat
1 Term
fillTerm Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Nat -> Term
var Nat
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
<#> ArgName
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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
<@> ArgName
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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
<@> ArgName
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"i" (\ NamesT Identity Term
i -> ArgName
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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 (ArgName -> Term -> Abs Term
forall a. ArgName -> a -> Abs a
Abs ArgName
"i" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ (Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> (Dom LType -> Type) -> Dom LType -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. LType -> Type
fromLType (LType -> Type) -> (Dom LType -> LType) -> Dom LType -> Type
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 -> TCMT IO Level
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Level -> TCMT IO Level) -> Level -> TCMT IO Level
forall a b. (a -> b) -> a -> b
$ LType -> Level
lTypeLevel (LType -> Level) -> LType -> Level
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 (ArgName -> Term -> Abs Term
forall a. ArgName -> a -> Abs a
Abs ArgName
"i" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ Level -> Term
Level Level
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 -> ArgName
-> (NamesT Identity Term -> NamesT Identity Term)
-> NamesT Identity Term
forall (m :: * -> *).
Monad m =>
ArgName -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam ArgName
"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 -> (Tele (Dom Type) -> Type -> TCM a) -> TCM a
bindGeneralizedParameters [] Type
t Tele (Dom Type) -> Type -> TCM a
ret = Tele (Dom Type) -> Type -> TCM a
ret Tele (Dom Type)
forall a. Tele a
EmptyTel Type
t
bindGeneralizedParameters (Maybe Name
name : [Maybe Name]
names) Type
t Tele (Dom Type) -> Type -> TCM a
ret =
  case Type -> Term
forall t a. Type'' t a -> a
unEl Type
t of
    Pi Dom Type
a Abs Type
b -> TCM a -> TCM a
ext (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$ [Maybe Name] -> Type -> (Tele (Dom Type) -> Type -> TCM a) -> TCM a
forall a.
[Maybe Name] -> Type -> (Tele (Dom Type) -> Type -> TCM a) -> TCM a
bindGeneralizedParameters [Maybe Name]
names (Abs Type -> Type
forall a. Abs a -> a
unAbs Abs Type
b) ((Tele (Dom Type) -> Type -> TCM a) -> TCM a)
-> (Tele (Dom Type) -> Type -> TCM a) -> TCM a
forall a b. (a -> b) -> a -> b
$ \ Tele (Dom Type)
tel Type
t -> Tele (Dom Type) -> Type -> TCM a
ret (Dom Type -> Abs (Tele (Dom Type)) -> Tele (Dom Type)
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel Dom Type
a (Tele (Dom Type)
tel Tele (Dom Type) -> Abs Type -> Abs (Tele (Dom Type))
forall a b. a -> Abs b -> Abs a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Abs Type
b)) Type
t
      where
        ext :: TCM a -> TCM a
ext | Just Name
x <- Maybe Name
name = (Name, Dom Type) -> 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) -> m a -> m a
addContext (Name
x, Dom Type
a)
            | Bool
otherwise      = (ArgName, Dom Type) -> TCM a -> TCM a
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
(ArgName, Dom Type) -> m a -> m a
addContext (Abs Type -> ArgName
forall a. Abs a -> ArgName
absName Abs Type
b, Dom Type
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 : Type a) : Type a
--     data D A where
--       c : A -> D A
--   @

bindParameters
  :: forall a. DataOrRecord
    -- ^ For error reporting, the name of the declaration we're checking
    -- and whether it is a data/record type.
  -> Int
    -- ^ The number of parameters we expect.
  -> [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.
DataOrRecord
-> Nat
-> [LamBinding]
-> Type
-> (Tele (Dom Type) -> Type -> TCM a)
-> TCM a
bindParameters DataOrRecord
what Nat
npars [LamBinding]
binds Type
ty Tele (Dom Type) -> Type -> TCM a
ret = Nat
-> [LamBinding]
-> Type
-> (UnboundParameters -> Tele (Dom Type) -> Type -> TCM a)
-> TCM a
loop Nat
npars [LamBinding]
binds Type
ty UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret' where
  ret' :: UnboundParameters -> Telescope -> Type -> TCM a
  ret' :: UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret' unb :: UnboundParameters
unb@(UnboundParameters DataOrRecord
_ [Closure (ArgName, Type)]
ps) Tele (Dom Type)
tel Type
ty = do
    Bool -> TCM () -> TCM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless ([Closure (ArgName, Type)] -> Bool
forall a. Null a => a -> Bool
null [Closure (ArgName, Type)]
ps) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$
      UnboundParameters -> TCM ()
forall (m :: * -> *) e.
(HasCallStack, MonadWarning m, Diagnostic e) =>
e -> m ()
warning UnboundParameters
unb
    Tele (Dom Type) -> Type -> TCM a
ret Tele (Dom Type)
tel Type
ty

  loop :: Int -> [A.LamBinding] -> Type -> (UnboundParameters -> Telescope -> Type -> TCM a) -> TCM a
  loop :: Nat
-> [LamBinding]
-> Type
-> (UnboundParameters -> Tele (Dom Type) -> Type -> TCM a)
-> TCM a
loop Nat
0 [] Type
a UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret = UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret (DataOrRecord -> [Closure (ArgName, Type)] -> UnboundParameters
UnboundParameters DataOrRecord
what []) Tele (Dom Type)
forall a. Tele a
EmptyTel Type
a

  loop Nat
0 (LamBinding
par : [LamBinding]
_) Type
_ UnboundParameters -> Tele (Dom Type) -> Type -> 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 :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM a) -> TypeError -> TCM a
forall a b. (a -> b) -> a -> b
$ LamBinding -> TypeError
UnexpectedParameter LamBinding
par

  loop Nat
npars [] Type
t UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret = case Type -> Term
forall t a. Type'' t a -> a
unEl Type
t of
    Pi Dom Type
a Abs Type
b -> do
      x <- Name -> Name
forall a. LensInScope a => a -> a
C.setNotInScope (Name -> Name) -> TCMT IO Name -> TCMT IO Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ArgName -> TCMT IO Name
forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
forall (m :: * -> *). MonadFresh NameId m => ArgName -> m Name
freshName_ (Abs Type -> ArgName
forall a. Abs a -> ArgName
absName Abs Type
b)

      ret' <- if not (visible a) then pure ret else do
        here <- buildClosure (absName b, unDom a)
        pure \UnboundParameters
there Tele (Dom Type)
tel Type
ty -> UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret UnboundParameters
there{ upUnbound = here:upUnbound there } Tele (Dom Type)
tel Type
ty

      step npars [] x a b ret'
    Term
_ -> TCM a
forall a. HasCallStack => a
__IMPOSSIBLE__

  loop Nat
_ (A.DomainFull TypedBinding
_ : [LamBinding]
_) Type
_ UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
_ =
    -- the input to bindParameters comes from defParametersToParameters,
    -- which always produces DomainFree binders.
    TCM a
forall a. HasCallStack => a
__IMPOSSIBLE__

  loop Nat
npars ps0 :: [LamBinding]
ps0@(par :: LamBinding
par@(A.DomainFree TacticAttribute
_ NamedArg Binder
arg) : [LamBinding]
ps) Type
t UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret = do
    let
      x :: Binder
x          = NamedArg Binder -> Binder
forall a. NamedArg a -> a
namedArg NamedArg Binder
arg
      TelV Tele (Dom Type)
tel Type
_ = Type -> TelV Type
telView' Type
t
      Pi Dom Type
dom Abs Type
b = Type -> Term
forall t a. Type'' t a -> a
unEl Type
t
      continue :: [LamBinding] -> Name -> TCM a
continue [LamBinding]
ps Name
x = Nat
-> [LamBinding]
-> Name
-> Dom Type
-> Abs Type
-> (UnboundParameters -> Tele (Dom Type) -> Type -> TCM a)
-> TCM a
step Nat
npars [LamBinding]
ps Name
x Dom Type
dom Abs Type
b UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret

    case NamedArg Binder -> [Dom' Term (ArgName, Type)] -> ImplicitInsertion
forall e a. NamedArg e -> [Dom a] -> ImplicitInsertion
insertImplicit NamedArg Binder
arg ([Dom' Term (ArgName, Type)] -> ImplicitInsertion)
-> [Dom' Term (ArgName, Type)] -> ImplicitInsertion
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> [Dom' Term (ArgName, Type)]
forall t. Tele (Dom t) -> [Dom (ArgName, t)]
telToList Tele (Dom Type)
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
=<< ArgName -> TCMT IO Name
forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
forall (m :: * -> *). MonadFresh NameId m => ArgName -> m Name
freshName_ (Abs Type -> ArgName
forall a. Abs a -> ArgName
absName Abs Type
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 :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM a) -> TypeError -> TCM a
forall a b. (a -> b) -> a -> b
$ LamBinding -> TypeError
UnexpectedParameter LamBinding
par
      NoSuchName ArgName
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 :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM a) -> TypeError -> TCM a
forall a b. (a -> b) -> a -> b
$ ArgName -> TypeError
NoParameterOfName ArgName
x

  step :: Int -> [A.LamBinding] -> Name -> Dom Type -> Abs Type -> (UnboundParameters -> Telescope -> Type -> TCM a) -> TCM a
  step :: Nat
-> [LamBinding]
-> Name
-> Dom Type
-> Abs Type
-> (UnboundParameters -> Tele (Dom Type) -> Type -> TCM a)
-> TCM a
step Nat
npars [LamBinding]
ps Name
x Dom Type
a Abs Type
b UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret = (Name, Dom Type) -> 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) -> m a -> m a
addContext (Name
x, Dom Type
a) (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$
    Nat
-> [LamBinding]
-> Type
-> (UnboundParameters -> Tele (Dom Type) -> Type -> TCM a)
-> TCM a
loop (Nat
npars Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1) [LamBinding]
ps (Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody Abs Type
b) ((UnboundParameters -> Tele (Dom Type) -> Type -> TCM a) -> TCM a)
-> (UnboundParameters -> Tele (Dom Type) -> Type -> TCM a) -> TCM a
forall a b. (a -> b) -> a -> b
$ \UnboundParameters
up Tele (Dom Type)
tel Type
s ->
      UnboundParameters -> Tele (Dom Type) -> Type -> TCM a
ret UnboundParameters
up (Dom Type -> Abs (Tele (Dom Type)) -> Tele (Dom Type)
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel Dom Type
a (Abs (Tele (Dom Type)) -> Tele (Dom Type))
-> Abs (Tele (Dom Type)) -> Tele (Dom Type)
forall a b. (a -> b) -> a -> b
$ ArgName -> Tele (Dom Type) -> Abs (Tele (Dom Type))
forall a. ArgName -> a -> Abs a
Abs (Name -> ArgName
nameToArgName Name
x) Tele (Dom Type)
tel) Type
s

-- | Check that the arguments to a constructor fits inside the sort of the datatype.
--   The third argument is the type of the constructor.
--
--   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
-> Sort
-> TCMT IO Nat
fitsIn DataOrRecord_
dataOrRecord QName
con UniverseCheck
uc [IsForced]
forceds Type
conT Sort
s = do
  [Char] -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.data.fits" Nat
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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
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 -> Sort
forall a. LensSort a => a -> Sort
getSort Type
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

  -- To allow propositional squash in data constructors, we turn @Prop ℓ@ into @Type ℓ@
  -- 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.
  [IsForced] -> Type -> Sort -> Sort -> TCMT IO Nat
fitsIn' [IsForced]
forceds Type
conT Sort
s (Sort -> TCMT IO Nat) -> Sort -> TCMT IO Nat
forall a b. (a -> b) -> a -> b
$ Bool -> (Sort -> Sort) -> Sort -> Sort
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen (DataOrRecord_
dataOrRecord DataOrRecord_ -> DataOrRecord_ -> Bool
forall a. Eq a => a -> a -> Bool
== DataOrRecord_
forall p. DataOrRecord' p
IsData) Sort -> Sort
forall t. Sort' t -> Sort' t
propToType Sort
s
  where
  fitsIn' ::
       [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' :: [IsForced] -> Type -> Sort -> Sort -> TCMT IO Nat
fitsIn' [IsForced]
forceds Type
t Sort
s0 Sort
s = do
    vt <- do
      t <- Type -> TCMT IO (Either (Dom Type, Abs Type) Type)
forall (m :: * -> *).
PureTCM m =>
Type -> m (Either (Dom Type, Abs Type) Type)
pathViewAsPi Type
t
      return $ case t of
                    Left (Dom Type
a,Abs Type
b)     -> (Bool, Dom Type, Abs Type) -> Maybe (Bool, Dom Type, Abs Type)
forall a. a -> Maybe a
Just (Bool
True ,Dom Type
a,Abs Type
b)
                    Right (El Sort
_ Term
t) | Pi Dom Type
a Abs Type
b <- Term
t
                                   -> (Bool, Dom Type, Abs Type) -> Maybe (Bool, Dom Type, Abs Type)
forall a. a -> Maybe a
Just (Bool
False,Dom Type
a,Abs Type
b)
                    Either (Dom Type, Abs Type) Type
_              -> Maybe (Bool, Dom Type, Abs Type)
forall a. Maybe a
Nothing
    case vt of
      Just (Bool
isPath, Dom Type
dom, Abs Type
b) -> do
        let
          (IsForced
forced, [IsForced]
forceds') = [IsForced] -> (IsForced, [IsForced])
nextIsForced [IsForced]
forceds
          isf :: Bool
isf = IsForced -> Bool
isForced IsForced
forced

        Bool -> TCM () -> TCM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless Bool
isf (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ do
          sa <- Sort -> TCMT IO Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> TCMT IO Sort) -> Sort -> TCMT IO Sort
forall a b. (a -> b) -> a -> b
$ Dom Type -> Sort
forall a. LensSort a => a -> Sort
getSort Dom Type
dom
          unless (isPath || uc == NoUniverseCheck) $
            traceCall (CheckConArgFitsIn con isf (unDom dom) s) $
            fitSort sa s0 s

        (ArgName, Dom Type) -> TCMT IO Nat -> TCMT IO Nat
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
(ArgName, Dom Type) -> m a -> m a
addContext (Abs Type -> ArgName
forall a. Abs a -> ArgName
absName Abs Type
b, Dom Type
dom) (TCMT IO Nat -> TCMT IO Nat) -> TCMT IO Nat -> TCMT IO Nat
forall a b. (a -> b) -> a -> b
$ do
          Nat -> Nat
forall a. Enum a => a -> a
succ (Nat -> Nat) -> TCMT IO Nat -> TCMT IO Nat
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [IsForced] -> Type -> Sort -> Sort -> TCMT IO Nat
fitsIn' [IsForced]
forceds' (Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody Abs Type
b) (Nat -> Sort -> Sort
forall a. Subst a => Nat -> a -> a
raise Nat
1 Sort
s0) (Nat -> Sort -> Sort
forall a. Subst a => Nat -> a -> a
raise Nat
1 Sort
s)
      Maybe (Bool, Dom Type, Abs Type)
_ -> do
        Sort -> Sort -> Sort -> TCM ()
fitSort (Type -> Sort
forall a. LensSort a => a -> Sort
getSort Type
t) Sort
s0 Sort
s
        Nat -> TCMT IO Nat
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Nat
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 :: * -> *) e.
(HasCallStack, MonadWarning m, Diagnostic e) =>
e -> 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 :: QName -> Sort -> Telescope -> TCM ()
checkIndexSorts :: QName -> Sort -> Tele (Dom Type) -> TCM ()
checkIndexSorts QName
name Sort
s = \case
  Tele (Dom Type)
EmptyTel -> () -> TCM ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  ExtendTel Dom Type
a Abs (Tele (Dom Type))
tel' -> do
    let sa :: Sort
sa = Dom Type -> Sort
forall a. LensSort a => a -> Sort
getSort Dom Type
a
    -- Andreas, 2020-10-19, allow Size indices
    Call -> TCM () -> TCM ()
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (QName -> Type -> Sort -> Call
CheckIndexSort QName
name (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
a) Sort
s) (TCM () -> TCM ()) -> TCM () -> TCM ()
forall a b. (a -> b) -> a -> b
$ Sort
sa Sort -> Sort -> TCM ()
`leqSort` Sort
s
    Dom Type
-> Abs (Tele (Dom Type)) -> (Tele (Dom Type) -> TCM ()) -> TCM ()
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Dom Type -> Abs a -> (a -> m b) -> m b
underAbstraction Dom Type
a Abs (Tele (Dom Type))
tel' ((Tele (Dom Type) -> TCM ()) -> TCM ())
-> (Tele (Dom Type) -> TCM ()) -> TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> Sort -> Tele (Dom Type) -> TCM ()
checkIndexSorts QName
name (Nat -> Sort -> Sort
forall a. Subst a => Nat -> a -> a
raise Nat
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,Nat -> IsPathCons -> [Char] -> [Char]
[IsPathCons] -> [Char] -> [Char]
IsPathCons -> [Char]
(Nat -> IsPathCons -> [Char] -> [Char])
-> (IsPathCons -> [Char])
-> ([IsPathCons] -> [Char] -> [Char])
-> Show IsPathCons
forall a.
(Nat -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Nat -> IsPathCons -> [Char] -> [Char]
showsPrec :: Nat -> 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 :: Nat -> Nat -> Type -> QName -> TCM IsPathCons
constructs Nat
nofPars Nat
nofExtraVars Type
t QName
q = Nat -> Type -> TCM IsPathCons
constrT Nat
nofExtraVars Type
t
    where
        -- The number n counts the proper (non-parameter) constructor arguments.
        constrT :: Nat -> Type -> TCM IsPathCons
        constrT :: Nat -> Type -> TCM IsPathCons
constrT Nat
n Type
t = do
            t <- Type -> TCMT IO Type
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Type
t
            pathV <- pathViewAsPi'whnf
            case unEl t of
                Pi Dom Type
_ (NoAbs ArgName
_ Type
b)  -> Nat -> Type -> TCM IsPathCons
constrT Nat
n Type
b
                Pi Dom Type
a Abs Type
b            -> Dom Type -> Abs Type -> (Type -> TCM IsPathCons) -> TCM IsPathCons
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Dom Type -> Abs a -> (a -> m b) -> m b
underAbstraction Dom Type
a Abs Type
b ((Type -> TCM IsPathCons) -> TCM IsPathCons)
-> (Type -> TCM IsPathCons) -> TCM IsPathCons
forall a b. (a -> b) -> a -> b
$ Nat -> Type -> TCM IsPathCons
constrT (Nat
n Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
1)
                  -- OR: addCxtString (absName b) a $ constrT (n + 1) (absBody b)
                Term
_ | Left ((Dom Type
a,Abs Type
b),(Term, Term)
_) <- Type -> Either ((Dom Type, Abs Type), (Term, Term)) Type
pathV Type
t -> do
                      _ <- case Abs Type
b of
                             NoAbs ArgName
_ Type
b -> Nat -> Type -> TCM IsPathCons
constrT Nat
n Type
b
                             Abs Type
b         -> Dom Type -> Abs Type -> (Type -> TCM IsPathCons) -> TCM IsPathCons
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Dom Type -> Abs a -> (a -> m b) -> m b
underAbstraction Dom Type
a Abs Type
b ((Type -> TCM IsPathCons) -> TCM IsPathCons)
-> (Type -> TCM IsPathCons) -> TCM IsPathCons
forall a b. (a -> b) -> a -> b
$ Nat -> Type -> TCM IsPathCons
constrT (Nat
n Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
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 :: Args
vs = [Elim' Term] -> Args
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims [Elim' Term]
es
                  let (Args
pars, Args
ixs) = Nat -> Args -> (Args, Args)
forall a. Nat -> [a] -> ([a], [a])
splitAt' Nat
nofPars Args
vs
                  -- check that the constructor parameters are the data parameters
                  Nat -> Args -> TCM ()
checkParams Nat
n Args
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
defType Definition
def
                  -- Split the telescope into indices and parameters.
                  --
                  -- [TODO: Reed M, 09/05/2026]
                  -- Using telView isn't the most efficient thing here; it would
                  -- be better if we had the telescope directly. Unfortunately,
                  -- @DatatypeData@ does not store such a telescope, so this is
                  -- the best we can do without rewriting a large amount of code.
                  TelV parTel idxTp <- telViewUpTo nofPars td
                  TelV idxTel core <- telView idxTp
                  -- The parameters are @n + nofPars - 1 .. n@
                  let us = (Arg ArgName -> Nat -> Arg Term) -> [Arg ArgName] -> [Nat] -> Args
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' (\Arg ArgName
arg Nat
x -> Nat -> Term
var Nat
x Term -> Arg ArgName -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg ArgName
arg) (Tele (Dom Type) -> [Arg ArgName]
forall a. TelToArgs a => a -> [Arg ArgName]
telToArgs Tele (Dom Type)
parTel) (Nat -> [Nat]
forall a. Integral a => a -> [a]
downFrom (Nat
nofPars Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
n))
                  -- The indices are fresh metas
                  xs <- newTelMetaSubst idxTel (raiseS n)
                  let t' = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El (Nat -> Sort -> Sort
forall a. Subst a => Nat -> a -> a
raise Nat
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 -> Type
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) -> Args -> [Elim' Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply (Args -> [Elim' Term]) -> Args -> [Elim' Term]
forall a b. (a -> b) -> a -> b
$ Args
us Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++! Args
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 :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM IsPathCons) -> TypeError -> TCM IsPathCons
forall a b. (a -> b) -> a -> b
$ Type -> TypeError
ShouldEndInApplicationOfTheDatatype Type
t

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

                sameVar :: Arg Term -> Nat -> TCM ()
sameVar Arg Term
arg Nat
i = do
                  t <- Nat -> TCMT IO Type
forall (m :: * -> *). (MonadDebug m, MonadTCEnv m) => Nat -> m Type
typeOfBV Nat
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 -> TCM (Maybe Bool)
isCoinductive Type
t = do
  El s t <- Type -> TCMT IO Type
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Type
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)

-- | A list of parameters expected in the data/record declaration that
-- are missing their binding in the definition site.
data UnboundParameters = UnboundParameters
  { UnboundParameters -> DataOrRecord
upDataOrRecord :: DataOrRecord
    -- ^ What we're defining.
  , UnboundParameters -> [Closure (ArgName, Type)]
upUnbound      :: [Closure (ArgName, Type)]
    -- ^ The list of unbound parameters to report. Can be empty due to
    -- how 'bindParameters' works, but should never be made into a
    -- diagnostic with an empty list.
  }
  deriving (Nat -> UnboundParameters -> [Char] -> [Char]
[UnboundParameters] -> [Char] -> [Char]
UnboundParameters -> [Char]
(Nat -> UnboundParameters -> [Char] -> [Char])
-> (UnboundParameters -> [Char])
-> ([UnboundParameters] -> [Char] -> [Char])
-> Show UnboundParameters
forall a.
(Nat -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Nat -> UnboundParameters -> [Char] -> [Char]
showsPrec :: Nat -> UnboundParameters -> [Char] -> [Char]
$cshow :: UnboundParameters -> [Char]
show :: UnboundParameters -> [Char]
$cshowList :: [UnboundParameters] -> [Char] -> [Char]
showList :: [UnboundParameters] -> [Char] -> [Char]
Show, (forall x. UnboundParameters -> Rep UnboundParameters x)
-> (forall x. Rep UnboundParameters x -> UnboundParameters)
-> Generic UnboundParameters
forall x. Rep UnboundParameters x -> UnboundParameters
forall x. UnboundParameters -> Rep UnboundParameters x
forall a.
(forall x. a -> Rep a x) -> (forall x. Rep a x -> a) -> Generic a
$cfrom :: forall x. UnboundParameters -> Rep UnboundParameters x
from :: forall x. UnboundParameters -> Rep UnboundParameters x
$cto :: forall x. Rep UnboundParameters x -> UnboundParameters
to :: forall x. Rep UnboundParameters x -> UnboundParameters
Generic)

instance NFData UnboundParameters

instance PrettyTCM UnboundParameters where
  prettyTCM :: forall (m :: * -> *). MonadPretty m => UnboundParameters -> m Doc
prettyTCM (UnboundParameters DataOrRecord
_ []) = m Doc
forall a. HasCallStack => a
__IMPOSSIBLE__
  prettyTCM (UnboundParameters DataOrRecord
dOrR [Closure (ArgName, Type)]
pars) = do
    let
      what :: [m Doc]
what = case DataOrRecord
dOrR of
        IsData{}   -> [Char] -> [m Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords [Char]
"data type"
        IsRecord{} -> [Char] -> [m Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords [Char]
"record type"
      par :: (m Doc -> m b) -> a -> m b
par m Doc -> m b
k = (a -> ((a, a) -> m b) -> m b) -> ((a, a) -> m b) -> a -> m b
forall a b c. (a -> b -> c) -> b -> a -> c
flip a -> ((a, a) -> m b) -> m b
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure \(a
nm, a
a) -> m Doc -> m b
k (a -> m Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty a
nm m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> m Doc
forall (m :: * -> *). Applicative m => m Doc
colon m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
a)
      head :: [m Doc]
head = [Char] -> [m Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords [Char]
"This" [m Doc] -> [m Doc] -> [m Doc]
forall a. Semigroup a => a -> a -> a
<> [m Doc]
what [m Doc] -> [m Doc] -> [m Doc]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [m Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords [Char]
"definition is missing"
    case [Closure (ArgName, Type)]
pars of
      [Closure (ArgName, Type)
x] -> [m Doc] -> m Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep ([m Doc] -> m Doc) -> [m Doc] -> m Doc
forall a b. (a -> b) -> a -> b
$ [m Doc]
head [m Doc] -> [m Doc] -> [m Doc]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [m Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords [Char]
"a binding for the parameter" [m Doc] -> [m Doc] -> [m Doc]
forall a. Semigroup a => a -> a -> a
<> [(m Doc -> m Doc) -> Closure (ArgName, Type) -> m Doc
forall {a} {a} {a} {m :: * -> *} {m :: * -> *} {b}.
(LensClosure a (a, a), Pretty a, PrettyTCM a, MonadFresh NameId m,
 MonadInteractionPoints m, MonadStConcreteNames m, PureTCM m,
 IsString (m Doc), Null (m Doc), Semigroup (m Doc), MonadTCEnv m,
 ReadTCState m) =>
(m Doc -> m b) -> a -> m b
par m Doc -> m Doc
forall a. a -> a
id Closure (ArgName, Type)
x]
      [Closure (ArgName, Type)]
_   -> [m Doc] -> m Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep ([m Doc]
head [m Doc] -> [m Doc] -> [m Doc]
forall a. Semigroup a => a -> a -> a
<> [Char] -> [m Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords [Char]
"bindings for the following parameters:")
          m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
$$ [m Doc] -> m Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ((Closure (ArgName, Type) -> m Doc)
-> [Closure (ArgName, Type)] -> [m Doc]
forall a b. (a -> b) -> [a] -> [b]
map ((m Doc -> m Doc) -> Closure (ArgName, Type) -> m Doc
forall {a} {a} {a} {m :: * -> *} {m :: * -> *} {b}.
(LensClosure a (a, a), Pretty a, PrettyTCM a, MonadFresh NameId m,
 MonadInteractionPoints m, MonadStConcreteNames m, PureTCM m,
 IsString (m Doc), Null (m Doc), Semigroup (m Doc), MonadTCEnv m,
 ReadTCState m) =>
(m Doc -> m b) -> a -> m b
par (Nat -> m Doc -> m Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2)) [Closure (ArgName, Type)]
pars)

instance Diagnostic UnboundParameters where
  diagnosticReason :: UnboundParameters -> DiagnosticReason
diagnosticReason UnboundParameters
_ = DiagnosticReason
DiagError
  diagnosticString :: UnboundParameters -> [Char]
diagnosticString UnboundParameters
_ = [Char]
"ExpectedBindingForParameter"