{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TypeFamilies #-}

module Agda.TypeChecking.Primitive.Cubical
  ( module Agda.TypeChecking.Primitive.Cubical
  , module Agda.TypeChecking.Primitive.Cubical.Id
  , module Agda.TypeChecking.Primitive.Cubical.Base
  , module Agda.TypeChecking.Primitive.Cubical.Glue
  , module Agda.TypeChecking.Primitive.Cubical.HCompU
  )
  where

import Prelude hiding (null, (!!))

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

import Data.String ()

import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import qualified Data.List as List
import Data.Foldable hiding (null)

import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.Syntax.Internal.Pattern
import qualified Agda.Syntax.Common.Pretty as P

import Agda.TypeChecking.Names
import Agda.TypeChecking.Positivity.Occurrence
import Agda.TypeChecking.Primitive.Base
import Agda.TypeChecking.Monad

import Agda.TypeChecking.Free
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Telescope

import Agda.Utils.Either
import Agda.Utils.Function
import Agda.Utils.Functor

import Agda.Utils.Impossible
import Agda.Utils.Maybe
import Agda.Utils.Null
import Agda.Utils.Tuple
import Agda.Utils.Size
import Agda.Utils.BoolSet (BoolSet)
import qualified Agda.Utils.BoolSet as BoolSet

import Agda.TypeChecking.Primitive.Cubical.HCompU
import Agda.TypeChecking.Primitive.Cubical.Glue
import Agda.TypeChecking.Primitive.Cubical.Base
import Agda.TypeChecking.Primitive.Cubical.Id

primPOr :: TCM PrimitiveImpl
primPOr :: TCM PrimitiveImpl
primPOr = do
  Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
  Type
t    <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (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
primLevel))    ((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
a  ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
i  ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"j" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
j  ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"A" (String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
j) ((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
o -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (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
primLevelSuc 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
a) (Sort -> Term
Sort (Sort -> Term) -> (Term -> Sort) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Term) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a)) ((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
bA ->
          ((String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"i1" NamesT (TCMT IO) Term
i ((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
i1 -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> (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
primIsOne1 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i1))) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
          ((String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"j1" NamesT (TCMT IO) Term
j ((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
j1 -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> (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
primIsOne2 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j1))) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
          String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
j) (\ NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o)
  PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
6 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
ts -> do
    case [Arg Term]
ts of
     [Arg Term
l,Arg Term
i,Arg Term
j,Arg Term
a,Arg Term
u,Arg Term
v] -> do
       Blocked (Arg Term)
si <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
i
       IntervalView
vi <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
si
       case IntervalView
vi of
        IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u)
        IntervalView
IZero -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
v)
        IntervalView
_ -> do
          Blocked (Arg Term)
sj <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
j
          IntervalView
vj <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sj
          case IntervalView
vj of
            IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
v)
            IntervalView
IZero -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u)
            IntervalView
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
l,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
si,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sj,Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
a,Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
u,Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
v]


     [Arg Term]
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primPartial' :: TCM PrimitiveImpl
primPartial' :: TCM PrimitiveImpl
primPartial' = do
  Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
  Type
t <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (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
primLevel)) (\ NamesT (TCMT IO) Term
a ->
        String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
_ ->
        String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"A" (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a) ((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
bA ->
        (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a))
  Term
isOne <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne
  Term
v <- Names -> NamesT (TCMT IO) Term -> TCMT IO Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Term -> TCMT IO Term)
-> NamesT (TCMT IO) Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$
        String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"a" ((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
l ->
        String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"φ" ((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
phi ->
        String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"A" ((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
a ->
        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
<$> String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"p" NamesT (TCMT IO) Term
phi (\NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
a)
  PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
0 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
_ -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
v

primPartialP' :: TCM PrimitiveImpl
primPartialP' :: TCM PrimitiveImpl
primPartialP' = do
  Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
  Type
t <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (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
primLevel)) (\ NamesT (TCMT IO) Term
a ->
        String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
phi ->
        String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"A" (String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" NamesT (TCMT IO) Term
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) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (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
primLevelSuc 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
a) (Sort -> Term
Sort (Sort -> Term) -> (Term -> Sort) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Term) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a)) ((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
bA ->
        (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a))
  Term
v <- Names -> NamesT (TCMT IO) Term -> TCMT IO Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Term -> TCMT IO Term)
-> NamesT (TCMT IO) Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$
        String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"a" ((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
l ->
        String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"φ" ((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
phi ->
        String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"A" ((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
a ->
        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
<$> String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"p" NamesT (TCMT IO) Term
phi (\ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
l (NamesT (TCMT IO) Term
a 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
p))
  PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
0 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
_ -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
v

primSubOut' :: TCM PrimitiveImpl
primSubOut' :: TCM PrimitiveImpl
primSubOut' = do
  Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
  Type
t    <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (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
primLevel)) ((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
a ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"A" (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (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
primLevelSuc 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
a) (Sort -> Term
Sort (Sort -> Term) -> (Term -> Sort) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Term) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a)) ((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
bA ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
phi ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"u" (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT (TCMT IO) Term
a (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primPartial 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
a 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
bA) ((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
u ->
          NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT (TCMT IO) Term
a (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
primSub 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
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
bA
  PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
5 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
ts -> do
    case [Arg Term]
ts of
      [Arg Term
a,Arg Term
bA,Arg Term
phi,Arg Term
u,Arg Term
x] -> do
        Term -> IntervalView
view <- ReduceM (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
        Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
        case Term -> IntervalView
view (Term -> IntervalView) -> Term -> IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi of
          IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u) ReduceM Term -> ReduceM Term -> ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> String -> BuiltinId -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (PrimitiveId -> String
forall a. IsBuiltin a => a -> String
getBuiltinId PrimitiveId
PrimSubOut) BuiltinId
BuiltinItIsOne)
          IntervalView
_ -> do
            Blocked (Arg Term)
sx <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
            Maybe QName
mSubIn <- BuiltinId -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe QName)
getBuiltinName' BuiltinId
builtinSubIn
            case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sx of
              Def QName
q [Elim
_,Elim
_,Elim
_, Apply Arg Term
t] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mSubIn -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
t)
              Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction (MaybeReducedArgs -> Reduced MaybeReducedArgs Term)
-> MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall a b. (a -> b) -> a -> b
$ (Arg Term -> MaybeReduced (Arg Term))
-> [Arg Term] -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
a,Arg Term
bA] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi, Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
u, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sx]
      [Arg Term]
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primTrans' :: TCM PrimitiveImpl
primTrans' :: TCM PrimitiveImpl
primTrans' = do
  Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
  Type
t    <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (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
primLevel)) ((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
a ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"A" (String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
i -> (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamesT (TCMT IO) Term
a 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) 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
bA ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
phi ->
          (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> 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
primIZero) (NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> 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
primIZero) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> 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
primIOne) (NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> 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
primIOne))
  PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> [Occurrence]
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
4 [] (([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \[Arg Term]
ts Nat
nelims -> do
    Command
-> [Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp Command
DoTransp [Arg Term]
ts Nat
nelims

primHComp' :: TCM PrimitiveImpl
primHComp' :: TCM PrimitiveImpl
primHComp' = do
  Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
  Type
t    <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (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
primLevel)) ((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
a ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"A" (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a) ((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
bA ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
phi ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT (TCMT IO) Term
i -> String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" NamesT (TCMT IO) Term
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) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
bA) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
          (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
bA)
  let occs :: [Occurrence]
occs = [Occurrence
Mixed, Occurrence
StrictPos, Occurrence
Mixed, Occurrence
StrictPos, Occurrence
StrictPos]
  PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> [Occurrence]
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
5 [Occurrence]
occs (([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \[Arg Term]
ts Nat
nelims -> do
    Command
-> [Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp Command
DoHComp [Arg Term]
ts Nat
nelims

-- | Construct a helper for CCHM composition, with a string indicating
-- what function uses it.
mkComp :: forall m. HasBuiltins m
       => String
       -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)
mkComp :: forall (m :: * -> *).
HasBuiltins m =>
String
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
mkComp String
s = do
  let getTermLocal :: IsBuiltin a => a -> NamesT m Term
      getTermLocal :: forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal = String -> a -> NamesT m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
s
  Term
tIMax  <- PrimitiveId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal PrimitiveId
builtinIMax
  Term
tINeg  <- PrimitiveId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal PrimitiveId
builtinINeg
  Term
tHComp <- PrimitiveId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal PrimitiveId
builtinHComp
  Term
tTrans <- PrimitiveId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal PrimitiveId
builtinTrans
  Term
iz     <- BuiltinId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal BuiltinId
builtinIZero
  Term
io     <- BuiltinId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal BuiltinId
builtinIOne

  let
    forward :: NamesT m Term
-> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
forward NamesT m Term
la NamesT m Term
bA NamesT m Term
r NamesT m Term
u = Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans
      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
i -> NamesT m Term
la 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 :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` NamesT m Term
r))
      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
i -> NamesT m Term
bA 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 :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` NamesT m Term
r))
      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
r
      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u

  (NamesT m Term
 -> NamesT m Term
 -> NamesT m Term
 -> NamesT m Term
 -> NamesT m Term
 -> NamesT m Term)
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((NamesT m Term
  -> NamesT m Term
  -> NamesT m Term
  -> NamesT m Term
  -> NamesT m Term
  -> NamesT m Term)
 -> NamesT
      m
      (NamesT m Term
       -> NamesT m Term
       -> NamesT m Term
       -> NamesT m Term
       -> NamesT m Term
       -> NamesT m Term))
-> (NamesT m Term
    -> NamesT m Term
    -> NamesT m Term
    -> NamesT m Term
    -> NamesT m Term
    -> NamesT m Term)
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u NamesT m Term
u0 ->
    Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
phi
                NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (\NamesT m Term
i -> String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
o ->
                        NamesT m Term
-> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
forward NamesT m Term
la NamesT m Term
bA NamesT m Term
i (NamesT m Term
u 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
o))
                NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
-> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
forward NamesT m Term
la NamesT m Term
bA (Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT m Term
u0

-- | Construct an application of buitlinComp. Use instead of 'mkComp' if
-- reducing directly to hcomp + transport would be problematic.
mkCompLazy
  :: HasBuiltins m
  => String
  -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)
mkCompLazy :: forall (m :: * -> *).
HasBuiltins m =>
String
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
mkCompLazy String
s = do
  let getTermLocal :: PrimitiveId -> NamesT m Term
getTermLocal = String -> PrimitiveId -> NamesT m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
s
  Term
tComp <- PrimitiveId -> NamesT m Term
getTermLocal PrimitiveId
builtinComp
  (NamesT m Term
 -> NamesT m Term
 -> NamesT m Term
 -> NamesT m Term
 -> NamesT m Term
 -> NamesT m Term)
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((NamesT m Term
  -> NamesT m Term
  -> NamesT m Term
  -> NamesT m Term
  -> NamesT m Term
  -> NamesT m Term)
 -> NamesT
      m
      (NamesT m Term
       -> NamesT m Term
       -> NamesT m Term
       -> NamesT m Term
       -> NamesT m Term
       -> NamesT m Term))
-> (NamesT m Term
    -> NamesT m Term
    -> NamesT m Term
    -> NamesT m Term
    -> NamesT m Term
    -> NamesT m Term)
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u NamesT m Term
u0 -> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tComp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bA NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0

-- | Implementation of Kan operations for Pi types. The implementation
-- of @transp@ and @hcomp@ for Pi types has many commonalities, so most
-- of it is shared between the two cases.
doPiKanOp
  :: KanOperation -- ^ Are we composing or transporting?
  -> ArgName      -- ^ Name of the binder
  -> FamilyOrNot (Dom Type, Abs Type)
  -- ^ The domain and codomain of the Pi type.
  -> ReduceM (Maybe Term)
doPiKanOp :: KanOperation
-> String
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> ReduceM (Maybe Term)
doPiKanOp KanOperation
cmd String
t FamilyOrNot (Dom' Term Type, Abs Type)
ab = do
  let getTermLocal :: IsBuiltin a => a -> ReduceM Term
      getTermLocal :: forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal = String -> a -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (String -> a -> ReduceM Term) -> String -> a -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ KanOperation -> String
kanOpName KanOperation
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for function types"
  Term
tTrans <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinTrans
  Term
tHComp <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinHComp
  Term
tINeg <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinINeg
  Term
tIMax <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinIMax
  Term
iz    <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIZero

  -- We must guarantee that the codomain is a fibrant type, i.e. one
  -- that supports hcomp and transp. Otherwise, what are we even doing!
  let
    toLevel' :: a -> m (Maybe (Level' Term))
toLevel' a
t = do
      Sort
s <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ a -> Sort
forall a. LensSort a => a -> Sort
getSort a
t
      case Sort
s of
        Type Level' Term
l -> Maybe (Level' Term) -> m (Maybe (Level' Term))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level' Term -> Maybe (Level' Term)
forall a. a -> Maybe a
Just Level' Term
l)
        Sort
_      -> Maybe (Level' Term) -> m (Maybe (Level' Term))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Level' Term)
forall a. Maybe a
Nothing
    -- But this case is actually impossible:
    toLevel :: a -> f (Level' Term)
toLevel a
t = Level' Term -> Maybe (Level' Term) -> Level' Term
forall a. a -> Maybe a -> a
fromMaybe Level' Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Level' Term) -> Level' Term)
-> f (Maybe (Level' Term)) -> f (Level' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f (Maybe (Level' Term))
forall {m :: * -> *} {a}.
(MonadReduce m, LensSort a) =>
a -> m (Maybe (Level' Term))
toLevel' a
t

  ReduceM (Maybe (Level' Term))
-> ReduceM (Maybe Term)
-> (Level' Term -> ReduceM (Maybe Term))
-> ReduceM (Maybe Term)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Type -> ReduceM (Maybe (Level' Term))
forall {m :: * -> *} {a}.
(MonadReduce m, LensSort a) =>
a -> m (Maybe (Level' Term))
toLevel' (Type -> ReduceM (Maybe (Level' Term)))
-> (FamilyOrNot (Dom' Term Type, Abs Type) -> Type)
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> ReduceM (Maybe (Level' Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody (Abs Type -> Type)
-> (FamilyOrNot (Dom' Term Type, Abs Type) -> Abs Type)
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dom' Term Type, Abs Type) -> Abs Type
forall a b. (a, b) -> b
snd ((Dom' Term Type, Abs Type) -> Abs Type)
-> (FamilyOrNot (Dom' Term Type, Abs Type)
    -> (Dom' Term Type, Abs Type))
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> Abs Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamilyOrNot (Dom' Term Type, Abs Type)
-> (Dom' Term Type, Abs Type)
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Dom' Term Type, Abs Type)
 -> ReduceM (Maybe (Level' Term)))
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> ReduceM (Maybe (Level' Term))
forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom' Term Type, Abs Type)
ab) (Maybe Term -> ReduceM (Maybe Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) ((Level' Term -> ReduceM (Maybe Term)) -> ReduceM (Maybe Term))
-> (Level' Term -> ReduceM (Maybe Term)) -> ReduceM (Maybe Term)
forall a b. (a -> b) -> a -> b
$ \ Level' Term
_ -> do
  Names -> NamesT ReduceM (Maybe Term) -> ReduceM (Maybe Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM (Maybe Term) -> ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term) -> ReduceM (Maybe Term)
forall a b. (a -> b) -> a -> b
$ do

    -- When doing transport in Pi types, we need to distinguish a couple
    -- of different cases depending on the sort of the domain, since
    -- there are a couple of different possibilities for how we end up
    -- with a fibrant Pi type:
    Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
trFibrantDomain <- do
      let
        (Dom' Term Type
x, Term -> Term
f) = case FamilyOrNot (Dom' Term Type, Abs Type)
ab of
          IsFam (Dom' Term Type
a, Abs Type
_) -> (Dom' Term Type
a, \ Term
a -> Names -> NamesT Fail Term -> Term
forall a. Names -> NamesT Fail a -> a
runNames [] (NamesT Fail Term -> Term) -> NamesT Fail Term -> Term
forall a b. (a -> b) -> a -> b
$ String
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall a. a -> NamesT Fail a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
a)))
          IsNot (Dom' Term Type
a, Abs Type
_) -> (Dom' Term Type
a, Term -> Term
forall a. a -> a
id)
      Sort
s <- Sort -> NamesT ReduceM Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> NamesT ReduceM Sort) -> Sort -> NamesT ReduceM Sort
forall a b. (a -> b) -> a -> b
$ Dom' Term Type -> Sort
forall a. LensSort a => a -> Sort
getSort Dom' Term Type
x
      case Sort
s of
        -- We're looking at a fibrant Pi with fibrant domain: Transport
        -- backwards along the domain.
        Type Level' Term
lx -> do
          [NamesT ReduceM Term
la, NamesT ReduceM Term
bA] <- (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Term] -> NamesT ReduceM [NamesT ReduceM 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 ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Term -> Term) -> Term -> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
f) [Level' Term -> Term
Level Level' Term
lx, Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term)
-> (Dom' Term Type -> Type) -> Dom' Term Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom (Dom' Term Type -> Term) -> Dom' Term Type -> Term
forall a b. (a -> b) -> a -> b
$ Dom' Term Type
x]
          Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
   ((NamesT ReduceM Term -> NamesT ReduceM Term)
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term)
 -> NamesT
      ReduceM
      (Maybe
         ((NamesT ReduceM Term -> NamesT ReduceM Term)
          -> NamesT ReduceM Term
          -> NamesT ReduceM Term
          -> NamesT ReduceM Term)))
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall a b. (a -> b) -> a -> b
$ ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term)
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a. a -> Maybe a
Just (((NamesT ReduceM Term -> NamesT ReduceM Term)
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term)
 -> Maybe
      ((NamesT ReduceM Term -> NamesT ReduceM Term)
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term))
-> ((NamesT ReduceM Term -> NamesT ReduceM Term)
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term)
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
phi NamesT ReduceM Term
a0 ->
            Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" (\NamesT ReduceM Term
j -> NamesT ReduceM Term
la NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
j)
              NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" (\ NamesT ReduceM Term
j -> NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
j)
              NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi
              NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
a0

        -- We're looking a fibrant Pi whose domain is a lock: No need to do anything.
        Sort
LockUniv -> Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
   ((NamesT ReduceM Term -> NamesT ReduceM Term)
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term)
 -> NamesT
      ReduceM
      (Maybe
         ((NamesT ReduceM Term -> NamesT ReduceM Term)
          -> NamesT ReduceM Term
          -> NamesT ReduceM Term
          -> NamesT ReduceM Term)))
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall a b. (a -> b) -> a -> b
$ ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term)
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a. a -> Maybe a
Just (((NamesT ReduceM Term -> NamesT ReduceM Term)
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term)
 -> Maybe
      ((NamesT ReduceM Term -> NamesT ReduceM Term)
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term))
-> ((NamesT ReduceM Term -> NamesT ReduceM Term)
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term)
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term -> NamesT ReduceM Term
_ NamesT ReduceM Term
_ NamesT ReduceM Term
a0 -> NamesT ReduceM Term
a0

        -- We're looking at an unmarked path type. Make sure that the
        -- domain is actually the interval before continuing without an
        -- adjustment, though!
        Sort
IntervalUniv -> do
          Blocked Type
x' <- Type -> NamesT ReduceM (Blocked Type)
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB (Type -> NamesT ReduceM (Blocked Type))
-> Type -> NamesT ReduceM (Blocked Type)
forall a b. (a -> b) -> a -> b
$ Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom Dom' Term Type
x
          Maybe QName
mInterval <- BuiltinId -> NamesT ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe QName)
getBuiltinName' BuiltinId
builtinInterval
          case Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> Type -> Term
forall a b. (a -> b) -> a -> b
$ Blocked Type -> Type
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Type
x' of
            Def QName
q [] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mInterval -> Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
   ((NamesT ReduceM Term -> NamesT ReduceM Term)
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term)
 -> NamesT
      ReduceM
      (Maybe
         ((NamesT ReduceM Term -> NamesT ReduceM Term)
          -> NamesT ReduceM Term
          -> NamesT ReduceM Term
          -> NamesT ReduceM Term)))
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall a b. (a -> b) -> a -> b
$ ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term)
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a. a -> Maybe a
Just (((NamesT ReduceM Term -> NamesT ReduceM Term)
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term)
 -> Maybe
      ((NamesT ReduceM Term -> NamesT ReduceM Term)
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term))
-> ((NamesT ReduceM Term -> NamesT ReduceM Term)
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term)
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term -> NamesT ReduceM Term
_ NamesT ReduceM Term
_ NamesT ReduceM Term
a0 -> NamesT ReduceM Term
a0
            Term
_ -> Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
forall a. Maybe a
Nothing

        Sort
_ -> Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
forall a. Maybe a
Nothing

    Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
-> NamesT ReduceM (Maybe Term)
-> (((NamesT ReduceM Term -> NamesT ReduceM Term)
     -> NamesT ReduceM Term
     -> NamesT ReduceM Term
     -> NamesT ReduceM Term)
    -> NamesT ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term)
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
trFibrantDomain (Maybe Term -> NamesT ReduceM (Maybe Term)
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) ((((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
  -> NamesT ReduceM (Maybe Term))
 -> NamesT ReduceM (Maybe Term))
-> (((NamesT ReduceM Term -> NamesT ReduceM Term)
     -> NamesT ReduceM Term
     -> NamesT ReduceM Term
     -> NamesT ReduceM Term)
    -> NamesT ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term)
forall a b. (a -> b) -> a -> b
$ \(NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
trA -> Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term)
-> NamesT ReduceM Term -> NamesT ReduceM (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
    [NamesT ReduceM Term
phi, NamesT ReduceM Term
u0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM 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 ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (KanOperation -> Blocked (Arg Term)
kanOpCofib KanOperation
cmd), KanOperation -> Arg Term
kanOpBase KanOperation
cmd]

    ArgInfo
-> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
ArgInfo
-> String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
glam (Dom' Term Type -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo ((Dom' Term Type, Abs Type) -> Dom' Term Type
forall a b. (a, b) -> a
fst ((Dom' Term Type, Abs Type) -> Dom' Term Type)
-> (Dom' Term Type, Abs Type) -> Dom' Term Type
forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom' Term Type, Abs Type)
-> (Dom' Term Type, Abs Type)
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Dom' Term Type, Abs Type)
ab)) (Abs Type -> String
forall a. Abs a -> String
absName (Abs Type -> String) -> Abs Type -> String
forall a b. (a -> b) -> a -> b
$ (Dom' Term Type, Abs Type) -> Abs Type
forall a b. (a, b) -> b
snd ((Dom' Term Type, Abs Type) -> Abs Type)
-> (Dom' Term Type, Abs Type) -> Abs Type
forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom' Term Type, Abs Type)
-> (Dom' Term Type, Abs Type)
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Dom' Term Type, Abs Type)
ab) ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term
u1 -> do
      case (KanOperation
cmd, FamilyOrNot (Dom' Term Type, Abs Type)
ab) of

        -- hcomp u u0 x = hcomp (λ i o → u i o x) (u0 x). Short and sweet :)
        (HCompOp Blocked (Arg Term)
_ Arg Term
u Arg Term
_, IsNot (Dom' Term Type
a , Abs Type
b)) -> do
          Type
bT <- (Nat -> Abs Type -> Abs Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Type
b Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`absApp`) (Term -> Type) -> NamesT ReduceM Term -> NamesT ReduceM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT ReduceM Term
u1
          NamesT ReduceM Term
u <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise Nat
1 (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u))
          Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Level' Term -> Term
Level (Level' Term -> Term)
-> NamesT ReduceM (Level' Term) -> NamesT ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> NamesT ReduceM (Level' Term)
forall {f :: * -> *} {a}.
(MonadReduce f, LensSort a) =>
a -> f (Level' Term)
toLevel Type
bT)
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Term
forall t a. Type'' t a -> a
unEl Type
bT)
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
phi
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (\ NamesT ReduceM Term
i -> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
o -> Hiding
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (Dom' Term Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom' Term Type
a) (NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o) NamesT ReduceM Term
u1)
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Hiding
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (Dom' Term Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom' Term Type
a) NamesT ReduceM Term
u0 NamesT ReduceM Term
u1

        -- transp (λ i → (a : A i) → B i x) φ f u1 =
        --  transp (λ i → B i (transp (λ j → A (i ∨ ~ j)) (φ ∨ i) x)) φ
        --    (f (transp (λ j → A (~ j) φ x)))
        (TranspOp Blocked (Arg Term)
_ Arg Term
_, IsFam (Dom' Term Type
a , Abs Type
b)) -> do
          -- trA is a function of three arguments which builds the
          -- transport fillers in the opposite direction, hence its
          -- first argument is called "iOrNot" where it's relevant.
          let
            -- Γ , u1 : A[i1] , i : I
            v :: NamesT ReduceM Term -> NamesT ReduceM Term
v NamesT ReduceM Term
i = (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
trA (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT ReduceM Term
i (NamesT ReduceM Term -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg) (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT ReduceM Term
phi NamesT ReduceM Term
i) NamesT ReduceM Term
u1
            bB :: Term -> Type
bB Term
v = Term -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
v (Nat -> Substitution' Term -> Substitution' Term
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
1 (Substitution' Term -> Substitution' Term)
-> Substitution' Term -> Substitution' Term
forall a b. (a -> b) -> a -> b
$ Nat -> Substitution' Term
forall a. Nat -> Substitution' a
raiseS Nat
1) Substitution' (SubstArg Type) -> Type -> Type
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst`
              (Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody Abs Type
b {- Γ , i : I , x : A[i] -})

            -- Compute B @0 v, in the right scope
            tLam :: Abs Term -> Term
tLam = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo

          -- We know how to substitute v into B, but it's open in a
          -- variable, so we close over it here:
          Abs Type
bT <- String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b)
    -> NamesT ReduceM Type)
-> NamesT ReduceM (Abs Type)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b)
  -> NamesT ReduceM Type)
 -> NamesT ReduceM (Abs Type))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b)
    -> NamesT ReduceM Type)
-> NamesT ReduceM (Abs Type)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b
x -> (Term -> Type) -> NamesT ReduceM Term -> NamesT ReduceM Type
forall a b. (a -> b) -> NamesT ReduceM a -> NamesT ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Type
bB (NamesT ReduceM Term -> NamesT ReduceM Type)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamesT ReduceM Term -> NamesT ReduceM Term
v (NamesT ReduceM Term -> NamesT ReduceM Type)
-> NamesT ReduceM Term -> NamesT ReduceM Type
forall a b. (a -> b) -> a -> b
$ NamesT ReduceM Term
forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b
x

          Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Abs Term -> Term
tLam (Abs Term -> Term)
-> NamesT ReduceM (Abs Term) -> NamesT ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> NamesT ReduceM Term)
-> Abs Type -> NamesT ReduceM (Abs Term)
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) -> Abs a -> f (Abs b)
traverse ((Level' Term -> Term)
-> NamesT ReduceM (Level' Term) -> NamesT ReduceM Term
forall a b. (a -> b) -> NamesT ReduceM a -> NamesT ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Level' Term -> Term
Level (NamesT ReduceM (Level' Term) -> NamesT ReduceM Term)
-> (Type -> NamesT ReduceM (Level' Term))
-> Type
-> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> NamesT ReduceM (Level' Term)
forall {f :: * -> *} {a}.
(MonadReduce f, LensSort a) =>
a -> f (Level' Term)
toLevel) Abs Type
bT)
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT ReduceM Term)
-> (Abs Term -> Term) -> Abs Term -> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Term -> Term
tLam (Abs Term -> NamesT ReduceM Term)
-> Abs Term -> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> Abs Type -> Abs Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs Type
bT)
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Hiding
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (Dom' Term Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom' Term Type
a) NamesT ReduceM Term
u0 (NamesT ReduceM Term -> NamesT ReduceM Term
v (Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz))

        (KanOperation
_, FamilyOrNot (Dom' Term Type, Abs Type)
_) -> String -> NamesT ReduceM Term
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
String -> m a
__IMPOSSIBLE_VERBOSE__ String
"Invalid Kan operation in doPiKanOp"

-- | Compute Kan operations in a type of dependent paths.
doPathPKanOp
  :: KanOperation
  -> FamilyOrNot (Arg Term)
  -> FamilyOrNot (Arg Term, Arg Term, Arg Term)
  -> ReduceM (Reduced MaybeReducedArgs Term)
doPathPKanOp :: KanOperation
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Reduced MaybeReducedArgs Term)
doPathPKanOp (HCompOp Blocked (Arg Term)
phi Arg Term
u Arg Term
u0) (IsNot Arg Term
l) (IsNot (Arg Term
bA,Arg Term
x,Arg Term
y)) = do
  let getTermLocal :: PrimitiveId -> ReduceM Term
getTermLocal = String -> PrimitiveId -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
"primHComp for path types"
  Term
tHComp <- PrimitiveId -> ReduceM Term
getTermLocal PrimitiveId
builtinHComp

  Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
    [NamesT ReduceM Term
l, NamesT ReduceM Term
u, NamesT ReduceM Term
u0, NamesT ReduceM Term
phi, NamesT ReduceM Term
bA, NamesT ReduceM Term
x, NamesT ReduceM Term
y] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM 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 ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l, Arg Term
u, Arg Term
u0, Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
phi, Arg Term
bA, Arg Term
x, Arg Term
y]

    -- hcomp in path spaces is simply hcomp in the underlying space, but
    -- fixing the endpoints at (j ∨ ~ j) in the new direction to those
    -- in the Path type.
    String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
j ->
      Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` (NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg NamesT ReduceM Term
j NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` NamesT ReduceM Term
j))
        NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i'" (\NamesT ReduceM Term
i -> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
forall (m :: * -> *).
HasBuiltins m =>
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
combineSys NamesT ReduceM Term
l (NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i)
          [ (NamesT ReduceM Term
phi,    String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT ReduceM Term
o -> NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o NamesT ReduceM Term
-> (NamesT ReduceM Term, NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT ReduceM Term
x, NamesT ReduceM Term
y, NamesT ReduceM Term
j)))
          , (NamesT ReduceM Term
j,      String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall a b. a -> b -> a
const NamesT ReduceM Term
y))
          , (NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg NamesT ReduceM Term
j, String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall a b. a -> b -> a
const NamesT ReduceM Term
x)) ])
        NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
u0 NamesT ReduceM Term
-> (NamesT ReduceM Term, NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT ReduceM Term
x, NamesT ReduceM Term
y, NamesT ReduceM Term
j))

doPathPKanOp (TranspOp Blocked (Arg Term)
phi Arg Term
u0) (IsFam Arg Term
l) (IsFam (Arg Term
bA,Arg Term
x,Arg Term
y)) = do
  let getTermLocal :: BuiltinId -> ReduceM Term
getTermLocal = String -> BuiltinId -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
"transport for path types"
  Term
iz <- BuiltinId -> ReduceM Term
getTermLocal BuiltinId
builtinIZero
  Term
io <- BuiltinId -> ReduceM Term
getTermLocal BuiltinId
builtinIOne

  -- Transport in path types becomes /CCHM/ composition in the
  -- underlying line of spaces. The intuition is that not only do we
  -- have to fix the endpoints (using composition) but also actually
  -- transport. CCHM composition conveniently does that for us!
  --
  -- Γ ⊢ l : I → Level
  --     l is already a function "coming in"
  -- Γ, i ⊢ bA   : Type (l i)
  -- Γ, i ⊢ x, y : bA
  -- Γ ⊢ u0 : PathP (A/i0) (x/i0) (y/i0)
  -- Γ, φ ⊢ bA constant
  --
  --   transp {l} (λ i → PathP A x y) φ p = λ j →
  --      comp {λ i → l j} (λ i → A i j) (φ ∨ j ∨ ~ j) λ i where
  --        (φ = i1 ∨ i = i0) → p j
  --        (j = i0)          → x i
  --        (j = i1)          → y i
  --   : PathP A/i1 x/i1 y/i1

  Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
    -- In reality to avoid a round-trip between primComp we use mkComp
    -- here.
    NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp <- String
-> NamesT
     ReduceM
     (NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall (m :: * -> *).
HasBuiltins m =>
String
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
mkComp (String
 -> NamesT
      ReduceM
      (NamesT ReduceM Term
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term))
-> String
-> NamesT
     ReduceM
     (NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ String
"transport for path types"
    [NamesT ReduceM Term
l, NamesT ReduceM Term
u0, NamesT ReduceM Term
phi] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM Term]
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) -> [a] -> f [b]
traverse (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l, Arg Term
u0, Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
phi]
    [NamesT ReduceM Term
bA, NamesT ReduceM Term
x, NamesT ReduceM Term
y] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM 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 (\ Arg Term
a -> Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (NamesT Fail Term -> Term)
-> NamesT Fail Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> NamesT Fail Term -> Term
forall a. Names -> NamesT Fail a -> a
runNames [] (NamesT Fail Term -> NamesT ReduceM (NamesT ReduceM Term))
-> NamesT Fail Term -> NamesT ReduceM (NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ String
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall a. a -> NamesT Fail a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT Fail Term) -> Term -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a))) [Arg Term
bA, Arg Term
x, Arg Term
y]
    -- Γ ⊢ bA : (i : I) → Type (l i)
    -- Γ ⊢ x, y : (i : I) → bA i

    String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
j ->
      NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp NamesT ReduceM Term
l (String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j) (NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` (NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg NamesT ReduceM Term
j NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` NamesT ReduceM Term
j))
        (String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i'" ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term
i -> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
forall (m :: * -> *).
HasBuiltins m =>
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
combineSys (NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) (NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j)
          [ (NamesT ReduceM Term
phi, String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\NamesT ReduceM Term
o -> NamesT ReduceM Term
u0 NamesT ReduceM Term
-> (NamesT ReduceM Term, NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT ReduceM Term
x NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT ReduceM Term
y NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT ReduceM Term
j)))
          -- Note that here we have lines of endpoints, which we must
          -- apply to fix the endpoints:
          , (NamesT ReduceM Term
j,      String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"_" (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall a b. a -> b -> a
const (NamesT ReduceM Term
y NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i)))
          , (NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg NamesT ReduceM Term
j, String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"_" (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall a b. a -> b -> a
const (NamesT ReduceM Term
x NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i)))
          ])
        (NamesT ReduceM Term
u0 NamesT ReduceM Term
-> (NamesT ReduceM Term, NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT ReduceM Term
x NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT ReduceM Term
y NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT ReduceM Term
j))
doPathPKanOp KanOperation
a0 FamilyOrNot (Arg Term)
_ FamilyOrNot (Arg Term, Arg Term, Arg Term)
_ = ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

redReturnNoSimpl :: a -> ReduceM (Reduced a' a)
redReturnNoSimpl :: forall a a'. a -> ReduceM (Reduced a' a)
redReturnNoSimpl = Reduced a' a -> ReduceM (Reduced a' a)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reduced a' a -> ReduceM (Reduced a' a))
-> (a -> Reduced a' a) -> a -> ReduceM (Reduced a' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Simplification -> a -> Reduced a' a
forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
NoSimplification

primTransHComp :: Command -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp :: Command
-> [Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp Command
cmd [Arg Term]
ts Nat
nelims = do
  (FamilyOrNot (Arg Term)
l,FamilyOrNot (Arg Term)
bA,Arg Term
phi,Maybe (Arg Term)
u,Arg Term
u0) <- (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
 Maybe (Arg Term), Arg Term)
-> ReduceM
     (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
      Maybe (Arg Term), Arg Term)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
  Maybe (Arg Term), Arg Term)
 -> ReduceM
      (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
       Maybe (Arg Term), Arg Term))
-> (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
    Maybe (Arg Term), Arg Term)
-> ReduceM
     (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
      Maybe (Arg Term), Arg Term)
forall a b. (a -> b) -> a -> b
$ case (Command
cmd,[Arg Term]
ts) of
    (Command
DoTransp, [Arg Term
l, Arg Term
bA, Arg Term
phi, Arg Term
u0]) -> (Arg Term -> FamilyOrNot (Arg Term)
forall a. a -> FamilyOrNot a
IsFam Arg Term
l, Arg Term -> FamilyOrNot (Arg Term)
forall a. a -> FamilyOrNot a
IsFam Arg Term
bA, Arg Term
phi, Maybe (Arg Term)
forall a. Maybe a
Nothing, Arg Term
u0)
    (Command
DoHComp, [Arg Term
l, Arg Term
bA, Arg Term
phi, Arg Term
u, Arg Term
u0]) -> (Arg Term -> FamilyOrNot (Arg Term)
forall a. a -> FamilyOrNot a
IsNot Arg Term
l, Arg Term -> FamilyOrNot (Arg Term)
forall a. a -> FamilyOrNot a
IsNot Arg Term
bA, Arg Term
phi, Arg Term -> Maybe (Arg Term)
forall a. a -> Maybe a
Just Arg Term
u, Arg Term
u0)
    (Command, [Arg Term])
_ -> (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
 Maybe (Arg Term), Arg Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
  Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
  IntervalView
vphi <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi
  let clP :: a -> m Term
clP a
s = String -> a -> m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
"primTransHComp" a
s

  -- WORK
  case IntervalView
vphi of
    -- When φ = i1, we know what to do! These cases are counted as
    -- simplifications.
    IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Command
cmd of
      Command
DoHComp -> Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ do
        -- If we're composing, then we definitely had a partial element
        -- to extend. But now it's just a total element, so we can
        -- just.. return it:
        NamesT ReduceM Term
u <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Term -> NamesT ReduceM (NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Maybe (Arg Term) -> Arg Term
forall a. a -> Maybe a -> a
fromMaybe Arg Term
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Term)
u
        NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> BuiltinId -> NamesT ReduceM Term
forall {m :: * -> *} {a}.
(HasBuiltins m, IsBuiltin a) =>
a -> m Term
clP BuiltinId
builtinIOne NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> BuiltinId -> NamesT ReduceM Term
forall {m :: * -> *} {a}.
(HasBuiltins m, IsBuiltin a) =>
a -> m Term
clP BuiltinId
builtinItIsOne
      Command
DoTransp ->
        -- Otherwise we're in the constant part of the line to transport
        -- over, so we must return the argument unchanged.
        Term -> ReduceM Term
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> ReduceM Term) -> Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0

    IntervalView
_ -> do
    let
      fallback' :: Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback' Blocked (Arg Term)
sc = do
        -- Possibly optimise the partial element to reduce the size of
        -- hcomps:
        MaybeReducedArgs
u' <- case Command
cmd of
          Command
DoHComp -> (MaybeReduced (Arg Term) -> MaybeReducedArgs -> MaybeReducedArgs
forall a. a -> [a] -> [a]
:[]) (MaybeReduced (Arg Term) -> MaybeReducedArgs)
-> ReduceM (MaybeReduced (Arg Term)) -> ReduceM MaybeReducedArgs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case IntervalView
vphi of
            -- If φ=i0 then tabulating equality for Partial φ A
            -- guarantees that u = is constantly isOneEmpty,
            -- regardless of how big the original term is, and
            -- isOneEmpty is *tiny*, so let's use that:
            IntervalView
IZero -> (Term -> MaybeReduced (Arg Term))
-> ReduceM Term -> ReduceM (MaybeReduced (Arg Term))
forall a b. (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced (Blocked (Arg Term) -> MaybeReduced (Arg Term))
-> (Term -> Blocked (Arg Term)) -> Term -> MaybeReduced (Arg Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Blocked (Arg Term)
forall a t. a -> Blocked' t a
notBlocked (Arg Term -> Blocked (Arg Term))
-> (Term -> Arg Term) -> Term -> Blocked (Arg Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argN) (ReduceM Term -> ReduceM (MaybeReduced (Arg Term)))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (MaybeReduced (Arg Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (MaybeReduced (Arg Term)))
-> NamesT ReduceM Term -> ReduceM (MaybeReduced (Arg Term))
forall a b. (a -> b) -> a -> b
$ do
                [NamesT ReduceM Term
l,NamesT ReduceM Term
c] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM 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 ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Arg Term)
l, Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc]
                String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> BuiltinId -> NamesT ReduceM Term
forall {m :: * -> *} {a}.
(HasBuiltins m, IsBuiltin a) =>
a -> m Term
clP BuiltinId
builtinIsOneEmpty NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT ReduceM Term
_ -> NamesT ReduceM Term
c)

            -- Otherwise we have some interesting formula (though
            -- definitely not IOne!) and we have to keep the partial
            -- element as-is.
            IntervalView
_ -> MaybeReduced (Arg Term) -> ReduceM (MaybeReduced (Arg Term))
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MaybeReduced (Arg Term) -> ReduceM (MaybeReduced (Arg Term)))
-> MaybeReduced (Arg Term) -> ReduceM (MaybeReduced (Arg Term))
forall a b. (a -> b) -> a -> b
$ Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced (Arg Term -> MaybeReduced (Arg Term))
-> Arg Term -> MaybeReduced (Arg Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Maybe (Arg Term) -> Arg Term
forall a. a -> Maybe a -> a
fromMaybe Arg Term
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Term)
u
          Command
DoTransp -> MaybeReducedArgs -> ReduceM MaybeReducedArgs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return []

        Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reduced MaybeReducedArgs Term
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> (MaybeReducedArgs -> Reduced MaybeReducedArgs Term)
-> MaybeReducedArgs
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction (MaybeReducedArgs -> ReduceM (Reduced MaybeReducedArgs Term))
-> MaybeReducedArgs -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced (FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Arg Term)
l), Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sc, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ MaybeReducedArgs
u' MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
u0]

    -- Reduce the type whose Kan operations we're composing over:
    Blocked (FamilyOrNot (Arg Term))
sbA <- FamilyOrNot (Arg Term)
-> ReduceM (Blocked (FamilyOrNot (Arg Term)))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' FamilyOrNot (Arg Term)
bA
    Maybe (Blocked' Term (FamilyOrNot Term))
t <- case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> FamilyOrNot (Arg Term) -> FamilyOrNot Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term)) -> FamilyOrNot (Arg Term)
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (FamilyOrNot (Arg Term))
sbA of
      IsFam (Lam ArgInfo
_ Abs Term
t) -> Blocked' Term (FamilyOrNot Term)
-> Maybe (Blocked' Term (FamilyOrNot Term))
forall a. a -> Maybe a
Just (Blocked' Term (FamilyOrNot Term)
 -> Maybe (Blocked' Term (FamilyOrNot Term)))
-> (Blocked' Term Term -> Blocked' Term (FamilyOrNot Term))
-> Blocked' Term Term
-> Maybe (Blocked' Term (FamilyOrNot Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> FamilyOrNot Term)
-> Blocked' Term Term -> Blocked' Term (FamilyOrNot Term)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> FamilyOrNot Term
forall a. a -> FamilyOrNot a
IsFam (Blocked' Term Term -> Maybe (Blocked' Term (FamilyOrNot Term)))
-> ReduceM (Blocked' Term Term)
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM (Blocked' Term Term)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
t)
      IsFam Term
_         -> Maybe (Blocked' Term (FamilyOrNot Term))
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Blocked' Term (FamilyOrNot Term))
forall a. Maybe a
Nothing
      IsNot Term
t         -> Maybe (Blocked' Term (FamilyOrNot Term))
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Blocked' Term (FamilyOrNot Term))
 -> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term))))
-> (Blocked' Term Term -> Maybe (Blocked' Term (FamilyOrNot Term)))
-> Blocked' Term Term
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' Term (FamilyOrNot Term)
-> Maybe (Blocked' Term (FamilyOrNot Term))
forall a. a -> Maybe a
Just (Blocked' Term (FamilyOrNot Term)
 -> Maybe (Blocked' Term (FamilyOrNot Term)))
-> (Blocked' Term Term -> Blocked' Term (FamilyOrNot Term))
-> Blocked' Term Term
-> Maybe (Blocked' Term (FamilyOrNot Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> FamilyOrNot Term)
-> Blocked' Term Term -> Blocked' Term (FamilyOrNot Term)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> FamilyOrNot Term
forall a. a -> FamilyOrNot a
IsNot (Blocked' Term Term
 -> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term))))
-> Blocked' Term Term
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall a b. (a -> b) -> a -> b
$ (Term
t Term -> Blocked (FamilyOrNot (Arg Term)) -> Blocked' Term Term
forall a b. a -> Blocked' Term b -> Blocked' Term a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Blocked (FamilyOrNot (Arg Term))
sbA)

    case Maybe (Blocked' Term (FamilyOrNot Term))
t of
      -- If we don't have a grasp of the Kan operations then at least we
      -- can reuse the work we did for reducing the type later.
      Maybe (Blocked' Term (FamilyOrNot Term))
Nothing -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback' (FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
sbA)
      Just Blocked' Term (FamilyOrNot Term)
st  -> do
        -- Similarly, if we're stuck for another reason, we can reuse
        -- the work for reducing the family.
        let
          fallback :: ReduceM (Reduced MaybeReducedArgs Term)
fallback = Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback' ((FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term))
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall a b. (a -> b) -> a -> b
$ Blocked' Term (FamilyOrNot Term)
st Blocked' Term (FamilyOrNot Term)
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (FamilyOrNot (Arg Term))
forall a b. Blocked' Term a -> Blocked' Term b -> Blocked' Term b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Blocked (FamilyOrNot (Arg Term))
sbA)
          t :: FamilyOrNot Term
t = Blocked' Term (FamilyOrNot Term) -> FamilyOrNot Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term (FamilyOrNot Term)
st
          operation :: KanOperation
operation = case Command
cmd of
            Command
DoTransp -> TranspOp { kanOpCofib :: Blocked (Arg Term)
kanOpCofib = Blocked (Arg Term)
sphi, kanOpBase :: Arg Term
kanOpBase = Arg Term
u0 }
            Command
DoHComp -> HCompOp
              { kanOpCofib :: Blocked (Arg Term)
kanOpCofib = Blocked (Arg Term)
sphi, kanOpSides :: Arg Term
kanOpSides = Arg Term -> Maybe (Arg Term) -> Arg Term
forall a. a -> Maybe a -> a
fromMaybe Arg Term
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Term)
u, kanOpBase :: Arg Term
kanOpBase = Arg Term
u0 }

        Maybe QName
mHComp <- PrimitiveId -> ReduceM (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
PrimitiveId -> m (Maybe QName)
getPrimitiveName' PrimitiveId
builtinHComp
        Maybe QName
mGlue <- PrimitiveId -> ReduceM (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
PrimitiveId -> m (Maybe QName)
getPrimitiveName' PrimitiveId
builtinGlue
        Maybe QName
mId   <- BuiltinId -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe QName)
getBuiltinName' BuiltinId
builtinId
        Type -> PathView
pathV <- ReduceM (Type -> PathView)
forall (m :: * -> *). HasBuiltins m => m (Type -> PathView)
pathView'

        -- By cases on the family, determine what Kan operation we defer
        -- to:
        case FamilyOrNot Term -> Term
forall a. FamilyOrNot a -> a
famThing FamilyOrNot Term
t of
          -- Metavariables are stuck
          MetaV MetaId
m [Elim]
_ -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback' ((FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term))
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall a b. (a -> b) -> a -> b
$ MetaId -> Blocked' Term ()
forall t. MetaId -> Blocked' t ()
blocked_ MetaId
m Blocked' Term ()
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (FamilyOrNot (Arg Term))
forall a b. Blocked' Term a -> Blocked' Term b -> Blocked' Term b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Blocked (FamilyOrNot (Arg Term))
sbA)

          -- TODO: absName t instead of "i"
          Pi Dom' Term Type
a Abs Type
b
            -- For Π types, we prefer to keep the Kan operations around,
            -- so only actually reduce if we applied them to a nonzero
            -- positive of eliminations
            | Nat
nelims Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
0 -> ReduceM (Reduced MaybeReducedArgs Term)
-> (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Maybe Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe Term) -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KanOperation
-> String
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> ReduceM (Maybe Term)
doPiKanOp KanOperation
operation String
"i" ((Dom' Term Type
a, Abs Type
b) (Dom' Term Type, Abs Type)
-> FamilyOrNot Term -> FamilyOrNot (Dom' Term Type, Abs Type)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t)
            | Bool
otherwise -> ReduceM (Reduced MaybeReducedArgs Term)
fallback

          -- For Type, we have two possibilities:
          Sort (Type Level' Term
l)
            -- transp (λ i → Type _) φ is always the identity function.
            | Command
DoTransp <- Command
cmd -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0
            -- hcomp {Type} is actually a normal form! This is the
            -- "HCompU" optimisation; We do not use Glue for hcomp in
            -- the universe.
            | Command
DoHComp <- Command
cmd -> ReduceM (Reduced MaybeReducedArgs Term)
fallback

          -- Glue types have their own implementation of Kan operations
          -- which are implemented in a different module:
          Def QName
q [Apply Arg Term
la, Apply Arg Term
lb, Apply Arg Term
bA, Apply Arg Term
phi', Apply Arg Term
bT, Apply Arg Term
e] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mGlue -> do
            ReduceM (Reduced MaybeReducedArgs Term)
-> (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Maybe Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe Term) -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KanOperation
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
KanOperation
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
doGlueKanOp
              KanOperation
operation ((Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi', Arg Term
bT, Arg Term
e) (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> FamilyOrNot Term
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) TermPosition
Head

          -- Formal homogeneous compositions in the universe: Our family
          -- is @hcomp {A = Type l}@, so we defer to the implementation
          -- of Kan operations for HCompU implemented above.
          Def QName
q [Apply Arg Term
_, Apply Arg Term
s, Apply Arg Term
phi', Apply Arg Term
bT, Apply Arg Term
bA]
            | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mHComp, Sort (Type Level' Term
la) <- Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
s  -> do
            ReduceM (Reduced MaybeReducedArgs Term)
-> (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Maybe Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe Term) -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KanOperation
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
KanOperation
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
doHCompUKanOp
              KanOperation
operation ((Level' Term -> Term
Level Level' Term
la Term -> Arg Term -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Term
s, Arg Term
phi', Arg Term
bT, Arg Term
bA) (Arg Term, Arg Term, Arg Term, Arg Term)
-> FamilyOrNot Term
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) TermPosition
Head

          -- PathP types have the same optimisation as for Pi types:
          -- Only compute the Kan operation if there's >0 eliminations.
          Term
d | PathType Sort
_ QName
_ Arg Term
_ Arg Term
bA Arg Term
x Arg Term
y <- Type -> PathView
pathV (Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El Sort
HasCallStack => Sort
__DUMMY_SORT__ Term
d) -> do
            if Nat
nelims Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
0 then KanOperation
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Reduced MaybeReducedArgs Term)
doPathPKanOp KanOperation
operation FamilyOrNot (Arg Term)
l ((Arg Term
bA, Arg Term
x, Arg Term
y) (Arg Term, Arg Term, Arg Term)
-> FamilyOrNot Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) else ReduceM (Reduced MaybeReducedArgs Term)
fallback

          -- Identity types:
          Def QName
q [Apply Arg Term
_ , Apply Arg Term
bA , Apply Arg Term
x , Apply Arg Term
y] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mId -> do
            ReduceM (Reduced MaybeReducedArgs Term)
-> (Reduced MaybeReducedArgs Term
    -> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe (Reduced MaybeReducedArgs Term)
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Reduced MaybeReducedArgs Term)
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KanOperation
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Maybe (Reduced MaybeReducedArgs Term))
forall t.
KanOperation
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Maybe (Reduced t Term))
doIdKanOp KanOperation
operation FamilyOrNot (Arg Term)
l ((Arg Term
bA, Arg Term
x, Arg Term
y) (Arg Term, Arg Term, Arg Term)
-> FamilyOrNot Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t)

          Def QName
q [Elim]
es -> do
            Definition
info <- QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
q
            let
              lam_i :: Term -> Term
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
. String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i"

              -- When should Kan operations on a record value reduce?
              doR :: Defn -> Bool
doR r :: Defn
r@Record{recEtaEquality' :: Defn -> EtaEquality
recEtaEquality' = EtaEquality
eta} = case EtaEquality -> HasEta
theEtaEquality EtaEquality
eta of
                -- If it's a no-eta, pattern-matching record, then the
                -- Kan operations behave as they do for data types; Only
                -- reduce when the base is a constructor
                NoEta PatternOrCopattern
PatternMatching -> case Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0 of
                  Con{} -> Bool
True
                  Term
_ -> Bool
False
                -- For every other case, we can reduce into a value
                -- defined by copatterns; However, this would expose the
                -- internal name of transp/hcomp when printed, so hold
                -- off until there are projections.
                HasEta
_ -> Nat
nelims Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
0
              doR Defn
_ = Bool
False

            -- Record and data types have their own implementations of
            -- the Kan operations, which get generated as part of their
            -- definition.
            case Definition -> Defn
theDef Definition
info of
              r :: Defn
r@Record{recComp :: Defn -> CompKit
recComp = CompKit
kit, recEtaEquality' :: Defn -> EtaEquality
recEtaEquality' = EtaEquality
eta}
                | Defn -> Bool
doR Defn
r, Just [Arg Term]
as <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, Command
DoTransp <- Command
cmd, Just QName
transpR <- CompKit -> Maybe QName
nameOfTransp CompKit
kit ->
                  -- Optimisation: If the record has no parameters then we can ditch the transport.
                  if Defn -> Nat
recPars Defn
r Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0
                     then Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0
                     else Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
transpR [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` ((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> Arg Term -> Arg Term
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) [Arg Term]
as [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi, Arg Term
u0])

                -- Records know how to hcomp themselves:
                | Defn -> Bool
doR Defn
r, Just [Arg Term]
as <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, Command
DoHComp <- Command
cmd, Just QName
hCompR <- CompKit -> Maybe QName
nameOfHComp CompKit
kit ->
                  Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
hCompR [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` ([Arg Term]
as [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi, Arg Term -> Maybe (Arg Term) -> Arg Term
forall a. a -> Maybe a -> a
fromMaybe Arg Term
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Term)
u,Arg Term
u0])

                -- If this is a record with no fields, then compData
                -- will know what to do with it:
                | Just [Arg Term]
as <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, [] <- Defn -> [Dom QName]
recFields Defn
r -> Maybe QName
-> Bool
-> Nat
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall {a}.
(Eq a, Num a, Pretty a) =>
Maybe QName
-> Bool
-> a
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
compData Maybe QName
forall a. Maybe a
Nothing Bool
False (Defn -> Nat
recPars Defn
r) Command
cmd FamilyOrNot (Arg Term)
l ([Arg Term]
as [Arg Term] -> FamilyOrNot Term -> FamilyOrNot [Arg Term]
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) Blocked (FamilyOrNot (Arg Term))
sbA Blocked (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
u0

              -- For data types, if this data type is indexed and/or a
              -- higher inductive type, then hcomp is normal; But
              -- compData knows what to do for the general cases.
              Datatype{dataPars :: Defn -> Nat
dataPars = Nat
pars, dataIxs :: Defn -> Nat
dataIxs = Nat
ixs, dataPathCons :: Defn -> [QName]
dataPathCons = [QName]
pcons, dataTransp :: Defn -> Maybe QName
dataTransp = Maybe QName
mtrD}
                | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [[QName] -> Bool
forall a. Null a => a -> Bool
null [QName]
pcons Bool -> Bool -> Bool
&& Nat
ixs Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0 | Command
DoHComp  <- [Command
cmd]], Just [Arg Term]
as <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es ->
                  Maybe QName
-> Bool
-> Nat
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall {a}.
(Eq a, Num a, Pretty a) =>
Maybe QName
-> Bool
-> a
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
compData Maybe QName
mtrD ((Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [QName] -> Bool
forall a. Null a => a -> Bool
null ([QName] -> Bool) -> [QName] -> Bool
forall a b. (a -> b) -> a -> b
$ [QName]
pcons) Bool -> Bool -> Bool
|| Nat
ixs Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
0) (Nat
pars Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
ixs) Command
cmd FamilyOrNot (Arg Term)
l ([Arg Term]
as [Arg Term] -> FamilyOrNot Term -> FamilyOrNot [Arg Term]
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) Blocked (FamilyOrNot (Arg Term))
sbA Blocked (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
u0

              -- Is this an axiom with constrant transport? Then. Well. Transport is constant.
              Axiom Bool
constTransp | Bool
constTransp, [] <- [Elim]
es, Command
DoTransp <- Command
cmd -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0

              Defn
_          -> ReduceM (Reduced MaybeReducedArgs Term)
fallback

          Term
_ -> ReduceM (Reduced MaybeReducedArgs Term)
fallback
  where
    allComponentsBack :: (IntervalView -> Term)
-> Term
-> Term
-> (Term -> a)
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
allComponentsBack IntervalView -> Term
unview Term
phi Term
u Term -> a
p = do
            let
              boolToI :: Bool -> Term
boolToI Bool
b = if Bool
b then IntervalView -> Term
unview IntervalView
IOne else IntervalView -> Term
unview IntervalView
IZero
              lamlam :: Term -> Term
lamlam Term
t = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i" (ArgInfo -> Abs Term -> Term
Lam (Relevance -> ArgInfo -> ArgInfo
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant ArgInfo
defaultArgInfo) (String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"o" Term
t)))
            [(IntMap Bool, [Term])]
as <- Term -> ReduceM [(IntMap Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(IntMap Bool, [Term])]
decomposeInterval Term
phi
            ([a]
flags,[Maybe (Blocked' Term Term, IntMap Bool)]
t_alphas) <- ([(a, Maybe (Blocked' Term Term, IntMap Bool))]
 -> ([a], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> ReduceM [(a, Maybe (Blocked' Term Term, IntMap Bool))]
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, Maybe (Blocked' Term Term, IntMap Bool))]
-> ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. [(a, b)] -> ([a], [b])
unzip (ReduceM [(a, Maybe (Blocked' Term Term, IntMap Bool))]
 -> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> (((IntMap Bool, [Term])
     -> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
    -> ReduceM [(a, Maybe (Blocked' Term Term, IntMap Bool))])
-> ((IntMap Bool, [Term])
    -> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IntMap Bool, [Term])]
-> ((IntMap Bool, [Term])
    -> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> ReduceM [(a, Maybe (Blocked' Term Term, IntMap Bool))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(IntMap Bool, [Term])]
as (((IntMap Bool, [Term])
  -> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
 -> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> ((IntMap Bool, [Term])
    -> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. (a -> b) -> a -> b
$ \ (IntMap Bool
bs,[Term]
ts) -> do
                 let u' :: Term
u' = [(Nat, Term)] -> Substitution' Term
forall a. EndoSubst a => [(Nat, a)] -> Substitution' a
listS [(Nat, Term)]
bs' Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u
                     bs' :: [(Nat, Term)]
bs' = IntMap Term -> [(Nat, Term)]
forall a. IntMap a -> [(Nat, a)]
IntMap.toAscList (IntMap Term -> [(Nat, Term)]) -> IntMap Term -> [(Nat, Term)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Term) -> IntMap Bool -> IntMap Term
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map Bool -> Term
boolToI IntMap Bool
bs
                     -- Γ₁, i : I, Γ₂, j : I, Γ₃  ⊢ weaken : Γ₁, Γ₂, Γ₃   for bs' = [(j,_),(i,_)]
                     -- ordering of "j,i,.." matters.
                 let weaken :: Substitution' Term
weaken = (Nat -> Substitution' Term -> Substitution' Term)
-> Substitution' Term -> [Nat] -> Substitution' Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Nat
j Substitution' Term
s -> Substitution' Term
s Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Nat -> Nat -> Substitution' Term
forall a. Nat -> Nat -> Substitution' a
raiseFromS Nat
j Nat
1) Substitution' Term
forall a. Substitution' a
idS (((Nat, Term) -> Nat) -> [(Nat, Term)] -> [Nat]
forall a b. (a -> b) -> [a] -> [b]
map (Nat, Term) -> Nat
forall a b. (a, b) -> a
fst [(Nat, Term)]
bs')
                 Blocked' Term Term
t <- Term -> ReduceM (Blocked' Term Term)
reduce2Lam Term
u'
                 (a, Maybe (Blocked' Term Term, IntMap Bool))
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Maybe (Blocked' Term Term, IntMap Bool))
 -> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> (a, Maybe (Blocked' Term Term, IntMap Bool))
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool))
forall a b. (a -> b) -> a -> b
$ (Term -> a
p (Term -> a) -> Term -> a
forall a b. (a -> b) -> a -> b
$ Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term Term
t, [(Blocked' Term Term, IntMap Bool)]
-> Maybe (Blocked' Term Term, IntMap Bool)
forall a. [a] -> Maybe a
listToMaybe [ (Substitution' Term
Substitution' (SubstArg (Blocked' Term Term))
weaken Substitution' (SubstArg (Blocked' Term Term))
-> Blocked' Term Term -> Blocked' Term Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` (Term -> Term
lamlam (Term -> Term) -> Blocked' Term Term -> Blocked' Term Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked' Term Term
t),IntMap Bool
bs) | [Term] -> Bool
forall a. Null a => a -> Bool
null [Term]
ts ])
            ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], [Maybe (Blocked' Term Term, IntMap Bool)])
 -> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. (a -> b) -> a -> b
$ ([a]
flags,[Maybe (Blocked' Term Term, IntMap Bool)]
t_alphas)
    compData :: Maybe QName
-> Bool
-> a
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
compData Maybe QName
mtrD Bool
False a
_ cmd :: Command
cmd@Command
DoHComp (IsNot Arg Term
l) (IsNot [Arg Term]
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi (Just Arg Term
u) Arg Term
a0 = do
      let getTermLocal :: IsBuiltin a => a -> ReduceM Term
          getTermLocal :: forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal = String -> a -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (String -> a -> ReduceM Term) -> String -> a -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ String
"builtinHComp for data types"

      let sc :: Blocked (Arg Term)
sc = FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
fsc
      Term
tEmpty <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIsOneEmpty
      Term
tPOr   <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinPOr
      Term
iO   <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIOne
      Term
iZ   <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIZero
      Term
tMin <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinIMin
      Term
tNeg <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinINeg
      let iNeg :: Term -> Term
iNeg Term
t = Term
tNeg Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
t]
          iMin :: Term -> Term -> Term
iMin Term
t Term
u = Term
tMin Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
t, Term -> Arg Term
forall e. e -> Arg e
argN Term
u]
          iz :: NamesT ReduceM Term
iz = Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iZ
      Term -> Term
constrForm <- do
        Maybe Term
mz <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinZero
        Maybe Term
ms <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinSuc
        (Term -> Term) -> ReduceM (Term -> Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Term) -> ReduceM (Term -> Term))
-> (Term -> Term) -> ReduceM (Term -> Term)
forall a b. (a -> b) -> a -> b
$ \ Term
t -> Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
t (Maybe Term -> Maybe Term -> Term -> Maybe Term
forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> Term -> m Term
constructorForm' Maybe Term
mz Maybe Term
ms Term
t)
      Blocked (Arg Term)
su  <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
u
      Blocked (Arg Term)
sa0 <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
a0
      Term -> IntervalView
view   <- ReduceM (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
      IntervalView -> Term
unview <- ReduceM (IntervalView -> Term)
forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
      let f :: Blocked' t (Arg c) -> c
f = Arg c -> c
forall e. Arg e -> e
unArg (Arg c -> c)
-> (Blocked' t (Arg c) -> Arg c) -> Blocked' t (Arg c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg c) -> Arg c
forall t a. Blocked' t a -> a
ignoreBlocking
          phi :: Term
phi = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sphi
          a0 :: Term
a0 = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sa0
          isLit :: Term -> Maybe Term
isLit t :: Term
t@(Lit Literal
lt) = Term -> Maybe Term
forall a. a -> Maybe a
Just Term
t
          isLit Term
_ = Maybe Term
forall a. Maybe a
Nothing
          isCon :: Term -> Maybe ConHead
isCon (Con ConHead
h ConInfo
_ [Elim]
_) = ConHead -> Maybe ConHead
forall a. a -> Maybe a
Just ConHead
h
          isCon Term
_           = Maybe ConHead
forall a. Maybe a
Nothing
          combine :: NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
combine NamesT ReduceM Term
l NamesT ReduceM Term
ty NamesT ReduceM Term
d [] = NamesT ReduceM Term
d
          combine NamesT ReduceM Term
l NamesT ReduceM Term
ty NamesT ReduceM Term
d [(NamesT ReduceM Term
psi,NamesT ReduceM Term
u)] = NamesT ReduceM Term
u
          combine NamesT ReduceM Term
l NamesT ReduceM Term
ty NamesT ReduceM Term
d ((NamesT ReduceM Term
psi,NamesT ReduceM Term
u):[(NamesT ReduceM Term, NamesT ReduceM Term)]
xs)
            = Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
psi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> ((NamesT ReduceM Term, NamesT ReduceM Term)
 -> NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term)
-> ((NamesT ReduceM Term, NamesT ReduceM Term)
    -> NamesT ReduceM Term)
-> (NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamesT ReduceM Term, NamesT ReduceM Term) -> NamesT ReduceM Term
forall a b. (a, b) -> a
fst) NamesT ReduceM Term
iz [(NamesT ReduceM Term, NamesT ReduceM Term)]
xs
                        NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT ReduceM Term
_ -> NamesT ReduceM Term
ty) -- the type
                        NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
combine NamesT ReduceM Term
l NamesT ReduceM Term
ty NamesT ReduceM Term
d [(NamesT ReduceM Term, NamesT ReduceM Term)]
xs)
          noRed' :: Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
noRed' Blocked (Arg Term)
su = Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
l,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sc, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
su', Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sa0]
            where
              su' :: Blocked (Arg Term)
su' = case Term -> IntervalView
view Term
phi of
                     IntervalView
IZero -> Arg Term -> Blocked (Arg Term)
forall a t. a -> Blocked' t a
notBlocked (Arg Term -> Blocked (Arg Term)) -> Arg Term -> Blocked (Arg Term)
forall a b. (a -> b) -> a -> b
$ Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Names -> NamesT Fail Term -> Term
forall a. Names -> NamesT Fail a -> a
runNames [] (NamesT Fail Term -> Term) -> NamesT Fail Term -> Term
forall a b. (a -> b) -> a -> b
$ do
                                 [NamesT Fail Term
l,NamesT Fail Term
c] <- (Arg Term -> NamesT Fail (NamesT Fail Term))
-> [Arg Term] -> NamesT Fail [NamesT Fail 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 Fail (NamesT Fail Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT Fail (NamesT Fail Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT Fail (NamesT Fail Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc]
                                 String
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term)
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
i -> Term -> NamesT Fail Term
forall a. a -> NamesT Fail a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEmpty NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
l
                                                              NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT Fail Term
_ -> NamesT Fail Term
c)
                     IntervalView
_     -> Blocked (Arg Term)
su
          sameConHeadBack :: Maybe Term
-> Maybe ConHead
-> Blocked (Arg Term)
-> (ConHead
    -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
sameConHeadBack Maybe Term
Nothing Maybe ConHead
Nothing Blocked (Arg Term)
su ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
k = Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
noRed' Blocked (Arg Term)
su
          sameConHeadBack Maybe Term
lt Maybe ConHead
h Blocked (Arg Term)
su ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
k = do
            let u :: Term
u = Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term)
-> (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Term) -> Blocked (Arg Term) -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
su
            ([(Bool, Bool)]
b, [Maybe (Blocked' Term Term, IntMap Bool)]
ts) <- (IntervalView -> Term)
-> Term
-> Term
-> (Term -> (Bool, Bool))
-> ReduceM
     ([(Bool, Bool)], [Maybe (Blocked' Term Term, IntMap Bool)])
forall {a}.
(IntervalView -> Term)
-> Term
-> Term
-> (Term -> a)
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
allComponentsBack IntervalView -> Term
unview Term
phi Term
u ((Term -> (Bool, Bool))
 -> ReduceM
      ([(Bool, Bool)], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> (Term -> (Bool, Bool))
-> ReduceM
     ([(Bool, Bool)], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. (a -> b) -> a -> b
$ \ Term
t ->
                        (Term -> Maybe Term
isLit Term
t Maybe Term -> Maybe Term -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Term
lt, Term -> Maybe ConHead
isCon (Term -> Term
constrForm Term
t) Maybe ConHead -> Maybe ConHead -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ConHead
h)
            let
              ([Bool]
lit,[Bool]
hd) = [(Bool, Bool)] -> ([Bool], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, Bool)]
b

            if Maybe Term -> Bool
forall a. Maybe a -> Bool
isJust Maybe Term
lt Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
lit then Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
a0 else do
            Blocked (Arg Term)
su <- Maybe [(Blocked' Term Term, IntMap Bool)]
-> ReduceM (Blocked (Arg Term))
-> ([(Blocked' Term Term, IntMap Bool)]
    -> ReduceM (Blocked (Arg Term)))
-> ReduceM (Blocked (Arg Term))
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe ([Maybe (Blocked' Term Term, IntMap Bool)]
-> Maybe [(Blocked' Term Term, IntMap Bool)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Blocked' Term Term, IntMap Bool)]
ts) (Blocked (Arg Term) -> ReduceM (Blocked (Arg Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocked (Arg Term)
su) (([(Blocked' Term Term, IntMap Bool)]
  -> ReduceM (Blocked (Arg Term)))
 -> ReduceM (Blocked (Arg Term)))
-> ([(Blocked' Term Term, IntMap Bool)]
    -> ReduceM (Blocked (Arg Term)))
-> ReduceM (Blocked (Arg Term))
forall a b. (a -> b) -> a -> b
$ \ [(Blocked' Term Term, IntMap Bool)]
ts -> do
              let ([Blocked' Term Term]
us,[IntMap Bool]
bools) = [(Blocked' Term Term, IntMap Bool)]
-> ([Blocked' Term Term], [IntMap Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Blocked' Term Term, IntMap Bool)]
ts
              (Term -> Blocked (Arg Term))
-> ReduceM Term -> ReduceM (Blocked (Arg Term))
forall a b. (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Blocked' Term Term] -> Blocked' Term ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_ [Blocked' Term Term]
us Blocked' Term () -> Arg Term -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) (Arg Term -> Blocked (Arg Term))
-> (Term -> Arg Term) -> Term -> Blocked (Arg Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argN) (ReduceM Term -> ReduceM (Blocked (Arg Term)))
-> ReduceM Term -> ReduceM (Blocked (Arg Term))
forall a b. (a -> b) -> a -> b
$ do
              let
                phis :: [Term]
                phis :: [Term]
phis = [IntMap Bool] -> (IntMap Bool -> Term) -> [Term]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [IntMap Bool]
bools ((IntMap Bool -> Term) -> [Term])
-> (IntMap Bool -> Term) -> [Term]
forall a b. (a -> b) -> a -> b
$ \ IntMap Bool
m ->
                            ((Nat, Bool) -> Term -> Term) -> Term -> [(Nat, Bool)] -> Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Term -> Term -> Term
iMin (Term -> Term -> Term)
-> ((Nat, Bool) -> Term) -> (Nat, Bool) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Nat
i,Bool
b) -> Bool -> (Term -> Term) -> Term -> Term
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyUnless Bool
b Term -> Term
iNeg (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Nat -> Term
var Nat
i)) Term
iO (IntMap Bool -> [(Nat, Bool)]
forall a. IntMap a -> [(Nat, a)]
IntMap.toList IntMap Bool
m)
              Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ do
                NamesT ReduceM Term
u <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u
                [NamesT ReduceM Term
l,NamesT ReduceM Term
c] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM 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 ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc]
                [NamesT ReduceM Term]
phis <- (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Term] -> NamesT ReduceM [NamesT ReduceM 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 ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Term]
phis
                [NamesT ReduceM Term]
us   <- (Blocked' Term Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Blocked' Term Term] -> NamesT ReduceM [NamesT ReduceM 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 ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Blocked' Term Term -> Term)
-> Blocked' Term Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking) [Blocked' Term Term]
us
                String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> do
                  NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
combine NamesT ReduceM Term
l NamesT ReduceM Term
c (NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) ([(NamesT ReduceM Term, NamesT ReduceM Term)]
 -> NamesT ReduceM Term)
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ [NamesT ReduceM Term]
-> [NamesT ReduceM Term]
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
forall a b. [a] -> [b] -> [(a, b)]
zip [NamesT ReduceM Term]
phis ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> [NamesT ReduceM Term] -> [NamesT ReduceM Term]
forall a b. (a -> b) -> [a] -> [b]
map (\ NamesT ReduceM Term
t -> NamesT ReduceM Term
t NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) [NamesT ReduceM Term]
us)

            if Maybe ConHead -> Bool
forall a. Maybe a -> Bool
isJust Maybe ConHead
h Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
hd then ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
k (ConHead -> Maybe ConHead -> ConHead
forall a. a -> Maybe a -> a
fromMaybe ConHead
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe ConHead
h) Blocked (Arg Term)
su
                      else Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
noRed' Blocked (Arg Term)
su

      Maybe Term
-> Maybe ConHead
-> Blocked (Arg Term)
-> (ConHead
    -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
sameConHeadBack (Term -> Maybe Term
isLit Term
a0) (Term -> Maybe ConHead
isCon Term
a0) Blocked (Arg Term)
su ((ConHead
  -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> (ConHead
    -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ \ ConHead
h Blocked (Arg Term)
su -> do
            let u :: Term
u = Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term)
-> (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Term) -> Blocked (Arg Term) -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
su
            Constructor{ conComp :: Defn -> CompKit
conComp = CompKit
cm } <- Definition -> Defn
theDef (Definition -> Defn) -> ReduceM Definition -> ReduceM Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
h)
            case CompKit -> Maybe QName
nameOfHComp CompKit
cm of
              Just QName
hcompD -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
hcompD [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply`
                                          ([Arg Term]
ps [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Term
phi,Term
u,Term
a0])
              Maybe QName
Nothing        -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
noRed' Blocked (Arg Term)
su

    compData Maybe QName
mtrD        Bool
_     a
0     Command
DoTransp (IsFam Arg Term
l) (IsFam [Arg Term]
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi Maybe (Arg Term)
Nothing Arg Term
a0 = Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a0
    compData (Just QName
trD) Bool
isHIT a
_ cmd :: Command
cmd@Command
DoTransp (IsFam Arg Term
l) (IsFam [Arg Term]
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi Maybe (Arg Term)
Nothing Arg Term
a0 = do
      let sc :: Blocked (Arg Term)
sc = FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
fsc
      let f :: Blocked' t (Arg c) -> c
f = Arg c -> c
forall e. Arg e -> e
unArg (Arg c -> c)
-> (Blocked' t (Arg c) -> Arg c) -> Blocked' t (Arg c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg c) -> Arg c
forall t a. Blocked' t a -> a
ignoreBlocking
          phi :: Term
          phi :: Term
phi = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f (Blocked (Arg Term) -> Term) -> Blocked (Arg Term) -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi
      let lam_i :: Term -> Term
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
. String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i"
      Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
trD [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` ((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> Arg Term -> Arg Term
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) [Arg Term]
ps [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Term
phi,Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a0])

    compData Maybe QName
mtrD Bool
isHIT a
_ cmd :: Command
cmd@Command
DoTransp (IsFam Arg Term
l) (IsFam [Arg Term]
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi Maybe (Arg Term)
Nothing Arg Term
a0 = do
      let getTermLocal :: IsBuiltin a => a -> ReduceM Term
          getTermLocal :: forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal = String -> a -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (String -> a -> ReduceM Term) -> String -> a -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ PrimitiveId -> String
forall a. IsBuiltin a => a -> String
getBuiltinId PrimitiveId
builtinTrans String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for data types"
      let sc :: Blocked (Arg Term)
sc = FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
fsc
      Maybe QName
mhcompName <- PrimitiveId -> ReduceM (Maybe QName)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe QName)
getName' PrimitiveId
builtinHComp
      Term -> Term
constrForm <- do
        Maybe Term
mz <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinZero
        Maybe Term
ms <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinSuc
        (Term -> Term) -> ReduceM (Term -> Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Term) -> ReduceM (Term -> Term))
-> (Term -> Term) -> ReduceM (Term -> Term)
forall a b. (a -> b) -> a -> b
$ \ Term
t -> Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
t (Maybe Term -> Maybe Term -> Term -> Maybe Term
forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> Term -> m Term
constructorForm' Maybe Term
mz Maybe Term
ms Term
t)
      Blocked (Arg Term)
sa0 <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
a0
      let f :: Blocked' t (Arg c) -> c
f = Arg c -> c
forall e. Arg e -> e
unArg (Arg c -> c)
-> (Blocked' t (Arg c) -> Arg c) -> Blocked' t (Arg c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg c) -> Arg c
forall t a. Blocked' t a -> a
ignoreBlocking
          phi :: Term
phi = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sphi
          a0 :: Term
a0 = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sa0
          noRed :: ReduceM (Reduced MaybeReducedArgs Term)
noRed = Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
l,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sc, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sa0]
      let lam_i :: Term -> Term
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
. String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i"
      case Term -> Term
constrForm Term
a0 of
        Con ConHead
h ConInfo
_ [Elim]
args -> do
          Constructor{ conComp :: Defn -> CompKit
conComp = CompKit
cm } <- Definition -> Defn
theDef (Definition -> Defn) -> ReduceM Definition -> ReduceM Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
h)
          case CompKit -> Maybe QName
nameOfTransp CompKit
cm of
              Just QName
transpD -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
transpD [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply`
                                          ((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> Arg Term -> Arg Term
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) [Arg Term]
ps [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Term
phi,Term
a0])
              Maybe QName
Nothing        -> ReduceM (Reduced MaybeReducedArgs Term)
noRed
        Def QName
q [Elim]
es | Bool
isHIT, QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mhcompName, Just [Arg Term
_l0,Arg Term
_c0,Arg Term
psi,Arg Term
u,Arg Term
u0] <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es -> do
           let bC :: Arg Term
bC = Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc
           Term
hcomp <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinHComp
           Term
transp <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinTrans
           Term
io <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIOne
           Term
iz <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIZero
           Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
             [NamesT ReduceM Term
l,NamesT ReduceM Term
bC,NamesT ReduceM Term
phi,NamesT ReduceM Term
psi,NamesT ReduceM Term
u,NamesT ReduceM Term
u0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM 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 ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
bC,Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi,Arg Term
psi,Arg Term
u,Arg Term
u0]
             -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0)
             Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
hcomp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bC NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
psi
                   NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" (\ NamesT ReduceM Term
j -> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
o ->
                        Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
transp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
bC NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o))
                   NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
transp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
bC NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u0)
        Term
_ -> ReduceM (Reduced MaybeReducedArgs Term)
noRed
    compData Maybe QName
mtrX Bool
isHITorIx a
nargs Command
cmd FamilyOrNot (Arg Term)
l FamilyOrNot [Arg Term]
t Blocked (FamilyOrNot (Arg Term))
sbA Blocked (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
u0 = do
      () <- String -> Nat -> TCMT IO Doc -> ReduceM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
"impossible" Nat
10 (TCMT IO Doc -> ReduceM ()) -> TCMT IO Doc -> ReduceM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"compData" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (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) -> [TCMT IO Doc] -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat)
       [ TCMT IO Doc
"mtrX:       " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Maybe QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Maybe QName
mtrX
       , TCMT IO Doc
"isHITorIx:  " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Bool -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Bool
isHITorIx
       , TCMT IO Doc
"nargs:      " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty a
nargs
       , TCMT IO Doc
"cmd:        " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (Command -> String
forall a. Show a => a -> String
show Command
cmd)
       , TCMT IO Doc
"l:          " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> FamilyOrNot (Arg Term) -> TCMT IO Doc
forall p a. IsString p => FamilyOrNot a -> p
familyOrNot FamilyOrNot (Arg Term)
l
       , TCMT IO Doc
"t:          " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> FamilyOrNot [Arg Term] -> TCMT IO Doc
forall p a. IsString p => FamilyOrNot a -> p
familyOrNot FamilyOrNot [Arg Term]
t TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Arg Term] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (FamilyOrNot [Arg Term] -> [Arg Term]
forall a. FamilyOrNot a -> a
famThing FamilyOrNot [Arg Term]
t)
       , TCMT IO Doc
"sbA:          " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> FamilyOrNot (Arg Term) -> TCMT IO Doc
forall p a. IsString p => FamilyOrNot a -> p
familyOrNot (Blocked (FamilyOrNot (Arg Term)) -> FamilyOrNot (Arg Term)
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (FamilyOrNot (Arg Term)) -> FamilyOrNot (Arg Term))
-> Blocked (FamilyOrNot (Arg Term)) -> FamilyOrNot (Arg Term)
forall a b. (a -> b) -> a -> b
$ Blocked (FamilyOrNot (Arg Term))
sbA)
       , TCMT IO Doc
"sphi:       " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi)
       , TCMT IO Doc
"isJust u:   " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Bool -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Maybe (Arg Term) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Arg Term)
u)
       , TCMT IO Doc
"u0:         " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Arg Term
u0
       ]
      ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

--    compData _ _ _ _ _ _ _ _ _ _ = __IMPOSSIBLE__

-- | CCHM 'primComp' is implemented in terms of 'hcomp' and 'transport'.
-- The definition of it comes from 'mkComp'.
primComp :: TCM PrimitiveImpl
primComp :: TCM PrimitiveImpl
primComp = do
  Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
  Type
t    <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (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
primLevel)) ((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
a ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"A" (String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
i -> (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamesT (TCMT IO) Term
a 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) 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
bA ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((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
phi ->
          String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT (TCMT IO) Term
i -> String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" NamesT (TCMT IO) Term
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) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a 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
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i)) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
          (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> 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
primIZero) (NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> 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
primIZero) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> 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
primIOne) (NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> 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
primIOne))
  Term
one <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
  Term
io  <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
  PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> [Occurrence]
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
5 [] (([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \[Arg Term]
ts Nat
nelims -> do
    case [Arg Term]
ts of
      [Arg Term
l,Arg Term
c,Arg Term
phi,Arg Term
u,Arg Term
a0] -> do
        Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
        IntervalView
vphi <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi
        case IntervalView
vphi of
          -- Though we short-circuit evaluation for the rule
          --    comp A i1 (λ _ .1=1 → u) u ==> u
          -- rather than going through the motions of hcomp and transp.
          IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
io, Term -> Arg Term
forall e. e -> Arg e
argN Term
one])
          IntervalView
_    -> do
            Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturnNoSimpl (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
              NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp <- String
-> NamesT
     ReduceM
     (NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall (m :: * -> *).
HasBuiltins m =>
String
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
mkComp (PrimitiveId -> String
forall a. IsBuiltin a => a -> String
getBuiltinId PrimitiveId
PrimComp)
              [NamesT ReduceM Term
l,NamesT ReduceM Term
c,NamesT ReduceM Term
phi,NamesT ReduceM Term
u,NamesT ReduceM Term
a0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM 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 ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
c,Arg Term
phi,Arg Term
u,Arg Term
a0]
              NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp NamesT ReduceM Term
l NamesT ReduceM Term
c NamesT ReduceM Term
phi NamesT ReduceM Term
u NamesT ReduceM Term
a0

      [Arg Term]
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__


-- TODO Andrea: keep reductions that happen under foralls?
primFaceForall' :: TCM PrimitiveImpl
primFaceForall' :: TCM PrimitiveImpl
primFaceForall' = do
  Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
  Type
t <- (TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType TCMT IO Type -> TCMT IO Type -> TCMT IO Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType) TCMT IO Type -> TCMT IO Type -> TCMT IO Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
  PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
1 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \case
    [Arg Term
phi] -> do
      Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
      case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
        Lam ArgInfo
_ Abs Term
t -> do
          Abs Term
t <- Abs Term -> ReduceM (Abs Term)
forall t. Reduce t => t -> ReduceM t
reduce' Abs Term
t
          case Abs Term
t of
            NoAbs String
_ Term
t -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
t
            Abs String
_ Term
t ->
              ReduceM (Reduced MaybeReducedArgs Term)
-> (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi]) Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn
                (Maybe Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe Term) -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> ReduceM (Maybe Term)
forall {m :: * -> *}. HasBuiltins m => Term -> m (Maybe Term)
toFaceMapsPrim Term
t
        Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi])
    [Arg Term]
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
  where
    toFaceMapsPrim :: Term -> m (Maybe Term)
toFaceMapsPrim Term
t = do
      Term -> IntervalView
view <- m (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
      IntervalView -> Term
unview <- m (IntervalView -> Term)
forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
      [(IntMap Bool, [Term])]
us' <- Term -> m [(IntMap Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(IntMap Bool, [Term])]
decomposeInterval Term
t
      Term
fr <- String -> PrimitiveId -> m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (PrimitiveId -> String
forall a. IsBuiltin a => a -> String
getBuiltinId PrimitiveId
PrimFaceForall) PrimitiveId
PrimFaceForall
      let
        v :: IntervalView
v = Term -> IntervalView
view Term
t
        -- We decomposed the interval expression, without regard for
        -- inconsistent mappings, and now we keep only those which are
        -- stuck (the ts) and those which do not mention the 0th variable.
        us :: [[Either (Int, Bool) Term]]
        us :: [[Either (Nat, Bool) Term]]
us = [ ((Nat, Bool) -> Either (Nat, Bool) Term)
-> [(Nat, Bool)] -> [Either (Nat, Bool) Term]
forall a b. (a -> b) -> [a] -> [b]
map (Nat, Bool) -> Either (Nat, Bool) Term
forall a b. a -> Either a b
Left (IntMap Bool -> [(Nat, Bool)]
forall a. IntMap a -> [(Nat, a)]
IntMap.toList IntMap Bool
bsm) [Either (Nat, Bool) Term]
-> [Either (Nat, Bool) Term] -> [Either (Nat, Bool) Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Either (Nat, Bool) Term)
-> [Term] -> [Either (Nat, Bool) Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Either (Nat, Bool) Term
forall a b. b -> Either a b
Right [Term]
ts
             | (IntMap Bool
bsm, [Term]
ts) <- [(IntMap Bool, [Term])]
us', Nat
0 Nat -> IntMap Bool -> Bool
forall a. Nat -> IntMap a -> Bool
`IntMap.notMember` IntMap Bool
bsm
             ]

        -- Turn a face mapping back into an interval expression:
        fm :: (Nat, Bool) -> Term
fm (Nat
i, Bool
b) = if Bool
b then Nat -> Term
var (Nat
i Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1) else IntervalView -> Term
unview (Arg Term -> IntervalView
INeg (Term -> Arg Term
forall e. e -> Arg e
argN (Nat -> Term
var (Nat -> Term) -> Nat -> Term
forall a b. (a -> b) -> a -> b
$ Nat
i Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1)))
        -- Apply ∀ to any indecomposable expressions we have encountered
        ffr :: Term -> Term
ffr Term
t = Term
fr Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i" Term
t]

        -- Unfold one step of the foldr to avoid generation of the last
        -- ∧ i1. Marginal savings at best but it's cleaner.
        conjuncts :: [Either (Int, Bool) Term] -> Term
        conjuncts :: [Either (Nat, Bool) Term] -> Term
conjuncts [] = IntervalView -> Term
unview IntervalView
IOne
        conjuncts [Either (Nat, Bool) Term
x] = ((Nat, Bool) -> Term)
-> (Term -> Term) -> Either (Nat, Bool) Term -> Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Nat, Bool) -> Term
fm Term -> Term
ffr Either (Nat, Bool) Term
x
        conjuncts (Either (Nat, Bool) Term
x:[Either (Nat, Bool) Term]
xs) =
          (Either (Nat, Bool) Term -> Term -> Term)
-> Term -> [Either (Nat, Bool) Term] -> Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Either (Nat, Bool) Term
x Term
r -> IntervalView -> Term
unview (Arg Term -> Arg Term -> IntervalView
IMin (Term -> Arg Term
forall e. e -> Arg e
argN (((Nat, Bool) -> Term)
-> (Term -> Term) -> Either (Nat, Bool) Term -> Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Nat, Bool) -> Term
fm Term -> Term
ffr Either (Nat, Bool) Term
x)) (Term -> Arg Term
forall e. e -> Arg e
argN Term
r)))
            (((Nat, Bool) -> Term)
-> (Term -> Term) -> Either (Nat, Bool) Term -> Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Nat, Bool) -> Term
fm Term -> Term
ffr Either (Nat, Bool) Term
x)
            [Either (Nat, Bool) Term]
xs

        disjuncts :: Term
disjuncts = ([Either (Nat, Bool) Term] -> Term -> Term)
-> Term -> [[Either (Nat, Bool) Term]] -> Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
          (\[Either (Nat, Bool) Term]
conj Term
rest -> IntervalView -> Term
unview (Arg Term -> Arg Term -> IntervalView
IMax (Term -> Arg Term
forall e. e -> Arg e
argN ([Either (Nat, Bool) Term] -> Term
conjuncts [Either (Nat, Bool) Term]
conj)) (Term -> Arg Term
forall e. e -> Arg e
argN Term
rest)))
          (IntervalView -> Term
unview IntervalView
IZero)
          [[Either (Nat, Bool) Term]]
us
      --   traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $
      Maybe Term -> m (Maybe Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Term -> m (Maybe Term)) -> Maybe Term -> m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ case [(IntMap Bool, [Term])]
us' of
        [(IntMap Bool
m, [Term
_])] | IntMap Bool -> Bool
forall a. Null a => a -> Bool
null IntMap Bool
m -> Maybe Term
forall a. Maybe a
Nothing
        [(IntMap Bool, [Term])]
_ -> Term -> Maybe Term
forall a. a -> Maybe a
Just Term
disjuncts

-- | Tries to @primTransp@ a whole telescope of arguments, following the rule for Σ types.
--   If a type in the telescope does not support transp, @transpTel@ throws it as an exception.
transpTel :: Abs Telescope -- Γ ⊢ i.Δ
          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ
          -> Args          -- Γ ⊢ δ : Δ[0]
          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[1]
transpTel :: Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
transpTel = Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpTel' Bool
False


transpTel' :: (PureTCM m, MonadError TCErr m) =>
          Bool -> Abs Telescope -- Γ ⊢ i.Δ
          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ
          -> Args          -- Γ ⊢ δ : Δ[0]
          -> ExceptT (Closure (Abs Type)) m Args      -- Γ ⊢ Δ[1]
transpTel' :: forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpTel' Bool
flag Abs Telescope
delta Term
phi [Arg Term]
args = Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpSysTel' Bool
flag Abs Telescope
delta [] Term
phi [Arg Term]
args

type LM m a = NamesT (ExceptT (Closure (Abs Type)) m) a
-- transporting with an extra system/partial element
-- or composing when some of the system is known to be constant.
transpSysTel' :: forall m. (PureTCM m, MonadError TCErr m) =>
          Bool
          -> Abs Telescope -- Γ ⊢ i.Δ
          -> [(Term,Abs [Term])] -- [(ψ,i.δ)] with  Γ,ψ ⊢ i.δ : [i : I]. Δ[i]  -- the proof of [ψ] is not in scope.
          -> Term          -- Γ ⊢ φ : F  -- i.Δ const on φ and all i.δ const on φ ∧ ψ
          -> Args          -- Γ ⊢ δ : Δ[0]
          -> ExceptT (Closure (Abs Type)) m Args      -- Γ ⊢ Δ[1]
transpSysTel' :: forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpSysTel' Bool
flag Abs Telescope
delta [(Term, Abs [Term])]
us Term
phi [Arg Term]
args = do
  String -> Nat -> TCMT IO Doc -> ExceptT (Closure (Abs Type)) m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
"cubical.prim.transpTel" Nat
20 (TCMT IO Doc -> ExceptT (Closure (Abs Type)) m ())
-> TCMT IO Doc -> ExceptT (Closure (Abs Type)) 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 [ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"transpSysTel'"
          , (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"delta  =" 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 a b. (a -> b) -> a -> b
$ 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
$ (String, Dom' Term 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 =>
(String, Dom' Term Type) -> m a -> m a
addContext (String
"i" :: String, Dom' Term Type
HasCallStack => Dom' Term Type
__DUMMY_DOM__) (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM (Abs Telescope -> Telescope
forall a. Abs a -> a
unAbs Abs Telescope
delta)
--          , (text "us =" <+>) $ nest 2 $ prettyList $ map prettyTCM us
          , (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"phi    =" 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 a b. (a -> b) -> a -> b
$ 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
$ Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
phi
          , (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"args   =" 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 a b. (a -> b) -> a -> b
$ 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, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (Arg Term -> TCMT IO Doc) -> [Arg Term] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM [Arg Term]
args
          ]
  let getTermLocal :: IsBuiltin a => a -> ExceptT e m Term
      getTermLocal :: forall a e. IsBuiltin a => a -> ExceptT e m Term
getTermLocal = String -> a -> ExceptT e m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
"transpSys"
  Term
tTransp <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primTrans
  Term
tComp <- PrimitiveId -> ExceptT (Closure (Abs Type)) m Term
forall a e. IsBuiltin a => a -> ExceptT e m Term
getTermLocal PrimitiveId
builtinComp
  Term
tPOr <- PrimitiveId -> ExceptT (Closure (Abs Type)) m Term
forall a e. IsBuiltin a => a -> ExceptT e m Term
getTermLocal PrimitiveId
builtinPOr
  Term
iz <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
  Term
imin <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin
  Term
imax <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax
  Term
ineg <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
  let
    noTranspError :: Abs a -> t m b
noTranspError Abs a
t = do
      String -> Nat -> TCMT IO Doc -> t m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
"cubical.prim.transpTel" Nat
20 (TCMT IO Doc -> t m ()) -> TCMT IO Doc -> t m ()
forall a b. (a -> b) -> a -> b
$ 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
$ (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"error type =" 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 a b. (a -> b) -> a -> b
$
        (String, Dom' Term 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 =>
(String, Dom' Term Type) -> m a -> m a
addContext (String
"i" :: String, Dom' Term Type
HasCallStack => Dom' Term Type
__DUMMY_DOM__) (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 -> TCMT IO Doc) -> a -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Abs a -> a
forall a. Abs a -> a
unAbs Abs a
t
      m b -> t m b
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> t m b)
-> (Closure (Abs a) -> m b) -> Closure (Abs a) -> t m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Abs a) -> m b
forall a. Closure (Abs a) -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Closure (Abs a) -> t m b) -> t m (Closure (Abs a)) -> t m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Abs a -> t m (Closure (Abs a))
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Abs a
t
    bapp :: forall m a. (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a
    bapp :: forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
bapp m (Abs a)
t m (SubstArg a)
u = Abs a -> SubstArg a -> a
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs a -> SubstArg a -> a) -> m (Abs a) -> m (SubstArg a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Abs a)
t m (SubstArg a -> a) -> m (SubstArg a) -> m a
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (SubstArg a)
u
    doGTransp :: NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
doGTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
us NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a | [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> Bool
forall a. Null a => a -> Bool
null [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
us = Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Abs Type -> Abs Term) -> Abs Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Term) -> Abs Type -> Abs Term
forall a b. (a -> b) -> Abs a -> Abs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Term
forall t a. Type'' t a -> a
unEl (Abs Type -> Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t) NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
a
                           | Bool
otherwise = Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tComp NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Abs Type -> Abs Term) -> Abs Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Term) -> Abs Type -> Abs Term
forall a b. (a -> b) -> Abs a -> Abs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Term
forall t a. Type'' t a -> a
unEl (Abs Type -> Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t) NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) m) Term
face NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
uphi NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
a
      where
        -- [phi -> a; us]
        face :: NamesT (ExceptT (Closure (Abs Type)) m) Term
face = (NamesT (ExceptT (Closure (Abs Type)) m) Term
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ NamesT (ExceptT (Closure (Abs Type)) m) Term
x NamesT (ExceptT (Closure (Abs Type)) m) Term
y -> Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imax NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
x NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
y) (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) (NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
forall a. a -> [a] -> [a]
: ((NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
forall a b. (a -> b) -> [a] -> [b]
map (NamesT (ExceptT (Closure (Abs Type)) m) Term,
 NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a, b) -> a
fst [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
us)
        uphi :: NamesT (ExceptT (Closure (Abs Type)) m) Term
uphi = String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
i -> String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
o -> do
          let sys' :: [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) Term)]
sys' = (NamesT (ExceptT (Closure (Abs Type)) m) Term
phi , NamesT (ExceptT (Closure (Abs Type)) m) Term
a) (NamesT (ExceptT (Closure (Abs Type)) m) Term,
 NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)]
forall a. a -> [a] -> [a]
: ((NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
 -> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)]
forall a b. (a -> b) -> [a] -> [b]
map ((NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
    NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
    NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Term)
i)) [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
us
              sys :: [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) Term)]
sys = ((NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)]
forall a b. (a -> b) -> [a] -> [b]
map ((NamesT (ExceptT (Closure (Abs Type)) m) Term
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
    NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
    NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd ((NamesT (ExceptT (Closure (Abs Type)) m) Term
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
    NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
    NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a b. (a -> b) -> a -> b
$ String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. a -> b -> a
const) [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) Term)]
sys'
          NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
combine (NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
i) (Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
bapp NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
i) NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. HasCallStack => a
__IMPOSSIBLE__ [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) Term)]
sys NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (ExceptT (Closure (Abs Type)) m) Term
o
    combine :: NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
combine NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
ty NamesT (ExceptT (Closure (Abs Type)) m) Term
d [] = NamesT (ExceptT (Closure (Abs Type)) m) Term
d
    combine NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
ty NamesT (ExceptT (Closure (Abs Type)) m) Term
d [(NamesT (ExceptT (Closure (Abs Type)) m) Term
psi,NamesT (ExceptT (Closure (Abs Type)) m) Term
u)] = NamesT (ExceptT (Closure (Abs Type)) m) Term
u
    combine NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
ty NamesT (ExceptT (Closure (Abs Type)) m) Term
d ((NamesT (ExceptT (Closure (Abs Type)) m) Term
psi,NamesT (ExceptT (Closure (Abs Type)) m) Term
u):[(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) Term)]
xs)
            = Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
psi NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> ((NamesT (ExceptT (Closure (Abs Type)) m) Term
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ NamesT (ExceptT (Closure (Abs Type)) m) Term
x NamesT (ExceptT (Closure (Abs Type)) m) Term
y -> Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imax NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
x NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
y) (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) (((NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
forall a b. (a -> b) -> [a] -> [b]
map (NamesT (ExceptT (Closure (Abs Type)) m) Term,
 NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a, b) -> a
fst [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) Term)]
xs))
                        NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
_ -> NamesT (ExceptT (Closure (Abs Type)) m) Term
ty) -- the type
                        NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
u NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
combine NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
ty NamesT (ExceptT (Closure (Abs Type)) m) Term
d [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) Term)]
xs)

    gTransp :: Maybe (LM m Term) -> LM m (Abs Type) -> [(LM m Term,LM m (Abs Term))] -> LM m Term -> LM m Term -> LM m Term
    gTransp :: Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
gTransp (Just NamesT (ExceptT (Closure (Abs Type)) m) Term
l) NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a
     | Bool
flag = do
      Abs Type
t' <- NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t
      [Abs Term]
us' <- ((NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) [Abs 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 (NamesT (ExceptT (Closure (Abs Type)) m) Term,
 NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall a b. (a, b) -> b
snd [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u
      case ( Nat
0 Nat -> Type -> Bool
forall a. Free a => Nat -> a -> Bool
`freeIn` (Nat -> Abs Type -> Abs Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Type
t' Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0)
           , Nat
0 Nat -> [Term] -> Bool
forall a. Free a => Nat -> a -> Bool
`freeIn` (Abs Term -> Term) -> [Abs Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (\ Abs Term
u -> Nat -> Abs Term -> Abs Term
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Term
u Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0) [Abs Term]
us'
           ) of
        (Bool
False,Bool
False) -> NamesT (ExceptT (Closure (Abs Type)) m) Term
a
        (Bool
False,Bool
True)  -> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
doGTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a -- TODO? optimize to "hcomp (l <@> io) (bapp t io) ((phi,NoAbs a):u) a" ?
        (Bool
True,Bool
_) -> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
doGTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a
     | Bool
otherwise = NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
doGTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a

    gTransp Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
Nothing NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
sys NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a = do
      let ([NamesT (ExceptT (Closure (Abs Type)) m) Term]
psis,[NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
us) = [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> ([NamesT (ExceptT (Closure (Abs Type)) m) Term],
    [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
sys
      -- Γ ⊢ i.Ξ
      NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi <- (Abs Telescope
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Telescope
 -> NamesT
      (ExceptT (Closure (Abs Type)) m)
      (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)))
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
 -> NamesT
      (ExceptT (Closure (Abs Type)) m)
      (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)))
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
forall a b. (a -> b) -> a -> b
$ do
        String
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
   (Subst b, DeBruijn b) =>
   NamesT (ExceptT (Closure (Abs Type)) m) b)
  -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> do
          TelV Telescope
xi Type
_ <- (ExceptT (Closure (Abs Type)) m (TelV Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type)
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) m (TelV Type)
 -> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type))
-> (Type -> ExceptT (Closure (Abs Type)) m (TelV Type))
-> Type
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ExceptT (Closure (Abs Type)) m (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView (Type -> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type))
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (ExceptT (Closure (Abs Type)) m) Type
 -> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type))
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type)
forall a b. (a -> b) -> a -> b
$ NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
          Telescope -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Telescope
xi
      [Arg String]
argnames <- do
        Telescope -> [Arg String]
teleArgNames (Telescope -> [Arg String])
-> (Abs Telescope -> Telescope) -> Abs Telescope -> [Arg String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Telescope -> Telescope
forall a. Abs a -> a
unAbs (Abs Telescope -> [Arg String])
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) [Arg String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi
      [Arg String]
-> (NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
(Functor m, MonadFail m) =>
[Arg String]
-> (NamesT m [Arg Term] -> NamesT m Term) -> NamesT m Term
glamN [Arg String]
argnames ((NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
xi_args -> do
        Abs Type
b' <- String
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
   (Subst b, DeBruijn b) =>
   NamesT (ExceptT (Closure (Abs Type)) m) b)
  -> NamesT (ExceptT (Closure (Abs Type)) m) Type)
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> do
          Type
ti <- NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
          Abs Telescope
xin <- String
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
   (Subst b, DeBruijn b) =>
   NamesT (ExceptT (Closure (Abs Type)) m) b)
  -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i)
          [Arg Term]
xi_args <- NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
xi_args
          Term
ni <- Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
          Term
phi <- NamesT (ExceptT (Closure (Abs Type)) m) Term
phi
          ExceptT (Closure (Abs Type)) m Type
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) m Type
 -> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> ExceptT (Closure (Abs Type)) m Type
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall a b. (a -> b) -> a -> b
$ Type -> [Arg Term] -> ExceptT (Closure (Abs Type)) m Type
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
forall (m :: * -> *).
(MonadReduce m, HasBuiltins m) =>
Type -> [Arg Term] -> m Type
piApplyM Type
ti ([Arg Term] -> ExceptT (Closure (Abs Type)) m Type)
-> ExceptT (Closure (Abs Type)) m [Arg Term]
-> ExceptT (Closure (Abs Type)) m Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
trFillTel' Bool
flag Abs Telescope
xin Term
phi [Arg Term]
xi_args Term
ni
        [Abs Term]
usxi <- [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
-> (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
    -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) [Abs Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
us ((NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
  -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
 -> NamesT (ExceptT (Closure (Abs Type)) m) [Abs Term])
-> (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
    -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) [Abs Term]
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
u -> String
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
   (Subst b, DeBruijn b) =>
   NamesT (ExceptT (Closure (Abs Type)) m) b)
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> do
          Term
ui <- NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
u NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Term)
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
          Abs Telescope
xin <- String
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
   (Subst b, DeBruijn b) =>
   NamesT (ExceptT (Closure (Abs Type)) m) b)
  -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i)
          [Arg Term]
xi_args <- NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
xi_args
          Term
ni <- Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
          Term
phi <- NamesT (ExceptT (Closure (Abs Type)) m) Term
phi
          ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) m Term
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
ui ([Arg Term] -> Term)
-> ExceptT (Closure (Abs Type)) m [Arg Term]
-> ExceptT (Closure (Abs Type)) m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
trFillTel' Bool
flag Abs Telescope
xin Term
phi [Arg Term]
xi_args Term
ni
        Term
axi <- do
          Term
a <- NamesT (ExceptT (Closure (Abs Type)) m) Term
a
          Abs Telescope
xif <- String
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
   (Subst b, DeBruijn b) =>
   NamesT (ExceptT (Closure (Abs Type)) m) b)
  -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i)
          Term
phi <- NamesT (ExceptT (Closure (Abs Type)) m) Term
phi
          [Arg Term]
xi_args <- NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
xi_args
          ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) m Term
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
a ([Arg Term] -> Term)
-> ExceptT (Closure (Abs Type)) m [Arg Term]
-> ExceptT (Closure (Abs Type)) m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpTel' Bool
flag Abs Telescope
xif Term
phi [Arg Term]
xi_args
        Sort
s <- Sort -> NamesT (ExceptT (Closure (Abs Type)) m) Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> NamesT (ExceptT (Closure (Abs Type)) m) Sort)
-> Sort -> NamesT (ExceptT (Closure (Abs Type)) m) Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort (Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody Abs Type
b')
        String
-> Nat -> TCMT IO Doc -> NamesT (ExceptT (Closure (Abs Type)) m) ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
"cubical.transp" Nat
20 (TCMT IO Doc -> NamesT (ExceptT (Closure (Abs Type)) m) ())
-> TCMT IO Doc -> NamesT (ExceptT (Closure (Abs Type)) m) ()
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Nat -> Abs Type -> Abs Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Type
b' Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0)
        let noTranspSort :: NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort = if Nat
0 Nat -> Type -> Bool
forall a. Free a => Nat -> a -> Bool
`freeIn` (Nat -> Abs Type -> Abs Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Type
b' Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0) Bool -> Bool -> Bool
|| Nat
0 Nat -> [Term] -> Bool
forall a. Free a => Nat -> a -> Bool
`freeIn` ((Abs Term -> Term) -> [Abs Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0) (Nat -> [Abs Term] -> [Abs Term]
forall a. Subst a => Nat -> a -> a
raise Nat
1 [Abs Term]
usxi))
              then Abs Type -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadDebug (t m), PrettyTCM a, MonadTrans t,
 MonadError (Closure (Abs a)) m, MonadTCEnv (t m),
 ReadTCState (t m)) =>
Abs a -> t m b
noTranspError Abs Type
b'
              else Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
axi

        case Sort
s of
          Type Level' Term
l -> do
            NamesT (ExceptT (Closure (Abs Type)) m) Term
l <- Term
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term
 -> NamesT
      (ExceptT (Closure (Abs Type)) m)
      (NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> Term
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a b. (a -> b) -> a -> b
$ Term -> Term
lam_i (Level' Term -> Term
Level Level' Term
l)
            NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
b' <- Abs Type
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Abs Type
b'
            NamesT (ExceptT (Closure (Abs Type)) m) Term
axi <- Term
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
axi
            [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
usxi <- (Abs Term
 -> NamesT
      (ExceptT (Closure (Abs Type)) m)
      (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> [Abs Term]
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     [NamesT (ExceptT (Closure (Abs Type)) m) (Abs 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 Abs Term
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Abs Term]
usxi
            Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
gTransp (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. a -> Maybe a
Just NamesT (ExceptT (Closure (Abs Type)) m) Term
l) NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
b' ([NamesT (ExceptT (Closure (Abs Type)) m) Term]
-> [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
forall a b. [a] -> [b] -> [(a, b)]
zip [NamesT (ExceptT (Closure (Abs Type)) m) Term]
psis [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
usxi) NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
axi
          Inf Univ
_ Integer
_  -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
          SSet Level' Term
_  -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
          Sort
SizeUniv -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
          Sort
LockUniv -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
          Sort
IntervalUniv -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
          Prop{}  -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
          Sort
_ -> Abs Type -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadDebug (t m), PrettyTCM a, MonadTrans t,
 MonadError (Closure (Abs a)) m, MonadTCEnv (t m),
 ReadTCState (t m)) =>
Abs a -> t m b
noTranspError Abs Type
b'
    lam_i :: Term -> Term
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
. String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i"
    go :: Telescope -> [[(Term,Term)]] -> Term -> Args -> ExceptT (Closure (Abs Type)) m Args
    go :: Telescope
-> [[(Term, Term)]]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
go Telescope
EmptyTel            [] Term
_  []       = [Arg Term] -> ExceptT (Closure (Abs Type)) m [Arg Term]
forall a. a -> ExceptT (Closure (Abs Type)) m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (ExtendTel Dom' Term Type
t Abs Telescope
delta) ([(Term, Term)]
u:[[(Term, Term)]]
us) Term
phi (Arg Term
a:[Arg Term]
args) = do
      -- Γ,i ⊢ t
      -- Γ,i ⊢ (x : t). delta
      -- Γ ⊢ a : t[0]
      Sort
s <- Sort -> ExceptT (Closure (Abs Type)) m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> ExceptT (Closure (Abs Type)) m Sort)
-> Sort -> ExceptT (Closure (Abs Type)) m Sort
forall a b. (a -> b) -> a -> b
$ Dom' Term Type -> Sort
forall a. LensSort a => a -> Sort
getSort Dom' Term Type
t
      -- Γ ⊢ b : t[1]    Γ, i ⊢ bf : t[i]
      (Term
b,Term
bf) <- Names
-> NamesT (ExceptT (Closure (Abs Type)) m) (Term, Term)
-> ExceptT (Closure (Abs Type)) m (Term, Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (ExceptT (Closure (Abs Type)) m) (Term, Term)
 -> ExceptT (Closure (Abs Type)) m (Term, Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) (Term, Term)
-> ExceptT (Closure (Abs Type)) m (Term, Term)
forall a b. (a -> b) -> a -> b
$ do
        Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
l <- case Sort
s of
               SSet Level' Term
_ -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
               Sort
IntervalUniv -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
               Sort
SizeUniv     -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
               Sort
LockUniv     -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
               Inf Univ
_ Integer
_ -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
               Type Level' Term
l -> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. a -> Maybe a
Just (NamesT (ExceptT (Closure (Abs Type)) m) Term
 -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> Term
lam_i (Level' Term -> Term
Level Level' Term
l))
               Sort
_ -> Abs Type
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadDebug (t m), PrettyTCM a, MonadTrans t,
 MonadError (Closure (Abs a)) m, MonadTCEnv (t m),
 ReadTCState (t m)) =>
Abs a -> t m b
noTranspError (String -> Type -> Abs Type
forall a. String -> a -> Abs a
Abs String
"i" (Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom Dom' Term Type
t))
        NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t <- Abs Type
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Type
 -> NamesT
      (ExceptT (Closure (Abs Type)) m)
      (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)))
-> Abs Type
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
forall a b. (a -> b) -> a -> b
$ String -> Type -> Abs Type
forall a. String -> a -> Abs a
Abs String
"i" (Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom Dom' Term Type
t)
        [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u <- [(Term, Term)]
-> ((Term, Term)
    -> NamesT
         (ExceptT (Closure (Abs Type)) m)
         (NamesT (ExceptT (Closure (Abs Type)) m) Term,
          NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
       NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Term, Term)]
u (((Term, Term)
  -> NamesT
       (ExceptT (Closure (Abs Type)) m)
       (NamesT (ExceptT (Closure (Abs Type)) m) Term,
        NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
 -> NamesT
      (ExceptT (Closure (Abs Type)) m)
      [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
        NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))])
-> ((Term, Term)
    -> NamesT
         (ExceptT (Closure (Abs Type)) m)
         (NamesT (ExceptT (Closure (Abs Type)) m) Term,
          NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
       NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
forall a b. (a -> b) -> a -> b
$ \ (Term
psi,Term
upsi) -> do
              (,) (NamesT (ExceptT (Closure (Abs Type)) m) Term
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
 -> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
      -> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
          NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
psi NamesT
  (ExceptT (Closure (Abs Type)) m)
  (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
   -> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
       NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) Term,
      NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
forall a b.
NamesT (ExceptT (Closure (Abs Type)) m) (a -> b)
-> NamesT (ExceptT (Closure (Abs Type)) m) a
-> NamesT (ExceptT (Closure (Abs Type)) m) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Abs Term
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i" Term
upsi)
        [NamesT (ExceptT (Closure (Abs Type)) m) Term
phi,NamesT (ExceptT (Closure (Abs Type)) m) Term
a] <- (Term
 -> NamesT
      (ExceptT (Closure (Abs Type)) m)
      (NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> [Term]
-> NamesT
     (ExceptT (Closure (Abs Type)) m)
     [NamesT (ExceptT (Closure (Abs Type)) m) 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
     (ExceptT (Closure (Abs Type)) m)
     (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Term
phi, Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a]
        Term
b <- Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
gTransp Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a
        Abs Term
bf <- String
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
   (Subst b, DeBruijn b) =>
   NamesT (ExceptT (Closure (Abs Type)) m) b)
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> do
                            Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
     NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
gTransp (((NamesT (ExceptT (Closure (Abs Type)) m) Term
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
l) ((NamesT (ExceptT (Closure (Abs Type)) m) Term
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
l -> String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
  -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
    -> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
j -> NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imin NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
j))
                                    (String
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" (((forall {b}.
   (Subst b, DeBruijn b) =>
   NamesT (ExceptT (Closure (Abs Type)) m) b)
  -> NamesT (ExceptT (Closure (Abs Type)) m) Type)
 -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
-> ((forall {b}.
     (Subst b, DeBruijn b) =>
     NamesT (ExceptT (Closure (Abs Type)) m) b)
    -> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
j -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imin NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
j))
                                    [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
  NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u
                                    (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imax NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i) NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
phi)
                                    NamesT (ExceptT (Closure (Abs Type)) m) Term
a
        (Term, Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Term, Term)
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term
b, Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
bf)
      (:) (Term
b Term -> Arg Term -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Term
a) ([Arg Term] -> [Arg Term])
-> ExceptT (Closure (Abs Type)) m [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope
-> [[(Term, Term)]]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
go (Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp Abs Telescope
delta Term
SubstArg Telescope
bf) [[(Term, Term)]]
us Term
phi [Arg Term]
args
    go Telescope
EmptyTel            [[(Term, Term)]]
_ Term
_ [Arg Term]
_ = ExceptT (Closure (Abs Type)) m [Arg Term]
forall a. HasCallStack => a
__IMPOSSIBLE__
    go (ExtendTel Dom' Term Type
t Abs Telescope
delta) [[(Term, Term)]]
_ Term
_ [Arg Term]
_ = ExceptT (Closure (Abs Type)) m [Arg Term]
forall a. HasCallStack => a
__IMPOSSIBLE__
  let ([Term]
psis,[Abs [Term]]
uss) = [(Term, Abs [Term])] -> ([Term], [Abs [Term]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Term, Abs [Term])]
us
      us' :: [[(Term, Term)]]
us' | [(Term, Abs [Term])] -> Bool
forall a. Null a => a -> Bool
null [(Term, Abs [Term])]
us = Nat -> [(Term, Term)] -> [[(Term, Term)]]
forall a. Nat -> a -> [a]
replicate ([Arg Term] -> Nat
forall a. [a] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [Arg Term]
args) []
          | Bool
otherwise = ([Term] -> [(Term, Term)]) -> [[Term]] -> [[(Term, Term)]]
forall a b. (a -> b) -> [a] -> [b]
map ([Term] -> [Term] -> [(Term, Term)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
psis) ([[Term]] -> [[(Term, Term)]]) -> [[Term]] -> [[(Term, Term)]]
forall a b. (a -> b) -> a -> b
$ [[Term]] -> [[Term]]
forall a. [[a]] -> [[a]]
List.transpose ((Abs [Term] -> [Term]) -> [Abs [Term]] -> [[Term]]
forall a b. (a -> b) -> [a] -> [b]
map Abs [Term] -> [Term]
forall a. Subst a => Abs a -> a
absBody [Abs [Term]]
uss)
  Telescope
-> [[(Term, Term)]]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
go (Abs Telescope -> Telescope
forall a. Subst a => Abs a -> a
absBody Abs Telescope
delta) [[(Term, Term)]]
us' Term
phi [Arg Term]
args

-- | Like @transpTel@ but performing a transpFill.
trFillTel :: Abs Telescope -- Γ ⊢ i.Δ
          -> Term
          -> Args          -- Γ ⊢ δ : Δ[0]
          -> Term          -- Γ ⊢ r : I
          -> ExceptT (Closure (Abs Type)) TCM Args      -- Γ ⊢ Δ[r]
trFillTel :: Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
trFillTel = Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
trFillTel' Bool
False

trFillTel' :: (PureTCM m, MonadError TCErr m) =>
          Bool
          -> Abs Telescope -- Γ ⊢ i.Δ
          -> Term
          -> Args          -- Γ ⊢ δ : Δ[0]
          -> Term          -- Γ ⊢ r : I
          -> ExceptT (Closure (Abs Type)) m Args      -- Γ ⊢ Δ[r]
trFillTel' :: forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
trFillTel' Bool
flag Abs Telescope
delta Term
phi [Arg Term]
args Term
r = do
  Term
imin <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin
  Term
imax <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax
  Term
ineg <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
  Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpTel' Bool
flag (String -> Telescope -> Abs Telescope
forall a. String -> a -> Abs a
Abs String
"j" (Telescope -> Abs Telescope) -> Telescope -> Abs Telescope
forall a b. (a -> b) -> a -> b
$ Nat -> Abs Telescope -> Abs Telescope
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Telescope
delta Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` (Term
imin Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` ((Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Nat -> Term
var Nat
0, Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise Nat
1 Term
r])))
            (Term
imax Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Term
ineg Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
r], Term -> Arg Term
forall e. e -> Arg e
argN Term
phi])
            [Arg Term]
args



-- hcompTel' :: Bool -> Telescope -> [(Term,Abs [Term])] -> [Term] -> ExceptT (Closure (Abs Type)) TCM [Term]
-- hcompTel' b delta sides base = undefined

-- hFillTel' :: Bool -> Telescope -- Γ ⊢ Δ
--           -> [(Term,Abs [Term])]  -- [(φ,i.δ)] with  Γ,φ ⊢ i.δ : I → Δ
--           -> [Term]            -- Γ ⊢ δ0 : Δ, matching the [(φ,i.δ)]
--           -> Term -- Γ ⊢ r : I
--           -> ExceptT (Closure (Abs Type)) TCM [Term]
-- hFillTel' b delta sides base = undefined

pathTelescope
  :: forall m. (PureTCM m, MonadError TCErr m) =>
  Telescope -- Δ
  -> [Arg Term] -- lhs : Δ
  -> [Arg Term] -- rhs : Δ
  -> m Telescope
pathTelescope :: forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
pathTelescope Telescope
tel [Arg Term]
lhs [Arg Term]
rhs = do
  Either (Closure Type) Telescope
x <- ExceptT (Closure Type) m Telescope
-> m (Either (Closure Type) Telescope)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Telescope
-> [Arg Term] -> [Arg Term] -> ExceptT (Closure Type) m Telescope
forall (m :: * -> *).
(PureTCM m, MonadError (Closure Type) m) =>
Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
pathTelescope' Telescope
tel [Arg Term]
lhs [Arg Term]
rhs)
  case Either (Closure Type) Telescope
x of
    Left Closure Type
t -> do
      Closure Type -> (Type -> m Telescope) -> m Telescope
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure Closure Type
t ((Type -> m Telescope) -> m Telescope)
-> (Type -> m Telescope) -> m Telescope
forall a b. (a -> b) -> a -> b
$ \ Type
t ->
                 TypeError -> m Telescope
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m Telescope)
-> (Doc -> TypeError) -> Doc -> m Telescope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> m Telescope) -> m Doc -> m Telescope
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                    (String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"The sort of" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> m Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type
t m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"should be of the form \"Set l\"")
    Right Telescope
tel -> Telescope -> m Telescope
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Telescope
tel

pathTelescope'
  :: forall m. (PureTCM m, MonadError (Closure Type) m) =>
  Telescope -- Δ
  -> [Arg Term] -- lhs : Δ
  -> [Arg Term] -- rhs : Δ
  -> m Telescope
pathTelescope' :: forall (m :: * -> *).
(PureTCM m, MonadError (Closure Type) m) =>
Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
pathTelescope' Telescope
tel [Arg Term]
lhs [Arg Term]
rhs = do
  Term
pathp <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> m (Maybe Term) -> m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuiltinId -> m (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinPathP
  Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
go Term
pathp (Nat -> Telescope -> Telescope
forall a. Subst a => Nat -> a -> a
raise Nat
1 Telescope
tel) [Arg Term]
lhs [Arg Term]
rhs
 where
  -- Γ,i ⊢ Δ, Γ ⊢ lhs : Δ[0], Γ ⊢ rhs : Δ[1]
  go :: Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
  go :: Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
go Term
pathp (ExtendTel Dom' Term Type
a Abs Telescope
tel) (Arg Term
u : [Arg Term]
lhs) (Arg Term
v : [Arg Term]
rhs) = do
    let t :: Type
t = Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom Dom' Term Type
a
    Level' Term
l <- Nat -> SubstArg (Level' Term) -> Level' Term -> Level' Term
forall a. Subst a => Nat -> SubstArg a -> a -> a
subst Nat
0 Term
SubstArg (Level' Term)
HasCallStack => Term
__DUMMY_TERM__ (Level' Term -> Level' Term) -> m (Level' Term) -> m (Level' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m (Level' Term)
getLevel Type
t
    let a' :: Type
a' = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El (Level' Term -> Sort
forall t. Level' t -> Sort' t
Type Level' Term
l) (Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
pathp ([Arg Term] -> Term) -> [Arg Term] -> Term
forall a b. (a -> b) -> a -> b
$ [Term -> Arg Term
forall e. e -> Arg e
argH (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Level' Term -> Term
Level Level' Term
l] [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"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
t), Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u, Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
v])
        -- Γ,eq : u ≡ v, i : I ⊢ m = eq i : t[i]
        -- m  = runNames [] $ do
        --        [u,v] <- mapM (open . unArg) [u,v]
        --        bind "eq" $ \ eq -> bind "i" $ \ i ->
    (Dom' Term Type -> Abs Telescope -> Telescope
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type
a' Type -> Dom' Term Type -> Dom' Term Type
forall a b. a -> Dom' Term b -> Dom' Term a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Dom' Term Type
a) (Abs Telescope -> Telescope) -> m (Abs Telescope) -> m Telescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m (Abs Telescope) -> m Telescope)
-> (NamesT m (Abs Telescope) -> m (Abs Telescope))
-> NamesT m (Abs Telescope)
-> m Telescope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> NamesT m (Abs Telescope) -> m (Abs Telescope)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT m (Abs Telescope) -> m Telescope)
-> NamesT m (Abs Telescope) -> m Telescope
forall a b. (a -> b) -> a -> b
$ do
      let nm :: String
nm = (Abs Telescope -> String
forall a. Abs a -> String
absName Abs Telescope
tel)
      NamesT m (Abs (Abs Telescope))
tel <- Abs (Abs Telescope) -> NamesT m (NamesT m (Abs (Abs Telescope)))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs (Abs Telescope) -> NamesT m (NamesT m (Abs (Abs Telescope))))
-> Abs (Abs Telescope) -> NamesT m (NamesT m (Abs (Abs Telescope)))
forall a b. (a -> b) -> a -> b
$ String -> Abs Telescope -> Abs (Abs Telescope)
forall a. String -> a -> Abs a
Abs String
"i" Abs Telescope
tel
      [NamesT m Term
u,NamesT m Term
v] <- (Arg Term -> NamesT m (NamesT m Term))
-> [Arg Term] -> NamesT m [NamesT m 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 m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
u,Arg Term
v]
      [NamesT m [Arg Term]
lhs,NamesT m [Arg Term]
rhs] <- ([Arg Term] -> NamesT m (NamesT m [Arg Term]))
-> [[Arg Term]] -> NamesT m [NamesT m [Arg 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 [Arg Term] -> NamesT m (NamesT m [Arg Term])
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [[Arg Term]
lhs,[Arg Term]
rhs]
      String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
    -> NamesT m Telescope)
-> NamesT m (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
nm (((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
  -> NamesT m Telescope)
 -> NamesT m (Abs Telescope))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
    -> NamesT m Telescope)
-> NamesT m (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT m b
eq -> do
        [Arg Term]
lhs <- NamesT m [Arg Term]
lhs
        [Arg Term]
rhs <- NamesT m [Arg Term]
rhs
        Abs Telescope
tel' <- String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
    -> NamesT m Telescope)
-> NamesT m (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
  -> NamesT m Telescope)
 -> NamesT m (Abs Telescope))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
    -> NamesT m Telescope)
-> NamesT m (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT m b
i ->
                  Abs Telescope -> Term -> Telescope
Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs Telescope -> Term -> Telescope)
-> NamesT m (Abs Telescope) -> NamesT m (Term -> Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Abs (Abs Telescope) -> Term -> Abs Telescope
Abs (Abs Telescope) -> SubstArg (Abs Telescope) -> Abs Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs (Abs Telescope) -> Term -> Abs Telescope)
-> NamesT m (Abs (Abs Telescope))
-> NamesT m (Term -> Abs Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT m (Abs (Abs Telescope))
tel NamesT m (Term -> Abs Telescope)
-> NamesT m Term -> NamesT m (Abs Telescope)
forall a b. NamesT m (a -> b) -> NamesT m a -> NamesT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT m Term
forall {b}. (Subst b, DeBruijn b) => NamesT m b
i) NamesT m (Term -> Telescope) -> NamesT m Term -> NamesT m Telescope
forall a b. NamesT m (a -> b) -> NamesT m a -> NamesT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (NamesT m Term
forall {b}. (Subst b, DeBruijn b) => NamesT m b
eq NamesT m Term
-> (NamesT m Term, NamesT m Term, NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT m Term
u, NamesT m Term
v, NamesT m Term
forall {b}. (Subst b, DeBruijn b) => NamesT m b
i))
        m Telescope -> NamesT m Telescope
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Telescope -> NamesT m Telescope)
-> m Telescope -> NamesT m Telescope
forall a b. (a -> b) -> a -> b
$ Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
go Term
pathp (Abs Telescope -> Telescope
forall a. Subst a => Abs a -> a
absBody Abs Telescope
tel') [Arg Term]
lhs [Arg Term]
rhs
  go Term
_ Telescope
EmptyTel [] [] = Telescope -> m Telescope
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Telescope
forall a. Tele a
EmptyTel
  go Term
_ Telescope
_ [Arg Term]
_ [Arg Term]
_ = m Telescope
forall a. HasCallStack => a
__IMPOSSIBLE__
  getLevel :: Type -> m Level
  getLevel :: Type -> m (Level' Term)
getLevel Type
t = do
    Sort
s <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort Type
t
    case Sort
s of
      Type Level' Term
l -> Level' Term -> m (Level' Term)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level' Term
l
      Sort
s      -> Closure Type -> m (Level' Term)
forall a. Closure Type -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Closure Type -> m (Level' Term))
-> m (Closure Type) -> m (Level' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> m (Closure Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Type
t

data TranspError = CannotTransp {TranspError -> Closure (Abs Type)
errorType :: (Closure (Abs Type)) }

instance Exception TranspError
instance Show TranspError where
  show :: TranspError -> String
show TranspError
_ = String
"TranspError"

tryTranspError :: TCM a -> TCM (Either (Closure (Abs Type)) a)
tryTranspError :: forall a. TCM a -> TCM (Either (Closure (Abs Type)) a)
tryTranspError (TCM IORef TCState -> TCEnv -> IO a
m) = (IORef TCState -> TCEnv -> IO (Either (Closure (Abs Type)) a))
-> TCMT IO (Either (Closure (Abs Type)) a)
forall (m :: * -> *) a. (IORef TCState -> TCEnv -> m a) -> TCMT m a
TCM ((IORef TCState -> TCEnv -> IO (Either (Closure (Abs Type)) a))
 -> TCMT IO (Either (Closure (Abs Type)) a))
-> (IORef TCState -> TCEnv -> IO (Either (Closure (Abs Type)) a))
-> TCMT IO (Either (Closure (Abs Type)) a)
forall a b. (a -> b) -> a -> b
$ \ IORef TCState
s TCEnv
env -> do
  (TranspError -> Closure (Abs Type))
-> Either TranspError a -> Either (Closure (Abs Type)) a
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft TranspError -> Closure (Abs Type)
errorType (Either TranspError a -> Either (Closure (Abs Type)) a)
-> IO (Either TranspError a) -> IO (Either (Closure (Abs Type)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO a -> IO (Either TranspError a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IORef TCState -> TCEnv -> IO a
m IORef TCState
s TCEnv
env))

transpPathPTel' ::
             NamesT TCM (Abs (Abs Telescope)) -- ^ j.i.Δ                 const on φ
             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[0,i]  const on φ
             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[1,i]  const on φ
             -> NamesT TCM Term            -- ^ φ
             -> [NamesT TCM Term]          -- ^ p : PathP (λ j → Δ[j,0]) (x 0) (y 0)
             -> NamesT TCM [Arg Term] -- PathP (λ j → Δ[j,0]) (x 1) (y 1) [ φ ↦ q ]
transpPathPTel' :: NamesT (TCMT IO) (Abs (Abs Telescope))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathPTel' NamesT (TCMT IO) (Abs (Abs Telescope))
theTel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
y NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p = do
 let neg :: NamesT m Term -> NamesT m Term
neg 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
primINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
 -- is the open overkill?
 NamesT (TCMT IO) [Arg Term]
qs <- ([Arg Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Arg Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term]))
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Arg Term]
 -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term]))
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall a b. (a -> b) -> a -> b
$ (Abs [Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Abs (Arg Term) -> Arg Term) -> [Abs (Arg Term)] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Abs String
n (Arg ArgInfo
i Term
t)) -> ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
n Term
t)) ([Abs (Arg Term)] -> [Arg Term])
-> (Abs [Arg Term] -> [Abs (Arg Term)])
-> Abs [Arg Term]
-> [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs [Arg Term] -> [Abs (Arg Term)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Abs (f a) -> f (Abs a)
sequenceA)
                  (NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) [Arg Term])
 -> NamesT (TCMT IO) (Abs [Arg Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> do
   Abs Telescope
theTel <- Abs (Abs Telescope) -> Term -> Abs Telescope
Abs (Abs Telescope) -> SubstArg (Abs Telescope) -> Abs Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Abs Telescope) -> Term -> Abs Telescope)
-> NamesT (TCMT IO) (Abs (Abs Telescope))
-> NamesT (TCMT IO) (Term -> Abs Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Abs Telescope))
theTel NamesT (TCMT IO) (Term -> Abs Telescope)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Abs Telescope)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j
   [Term]
faces <- [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
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
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j]
   [Abs [Term]]
us <- [[NamesT (TCMT IO) Term]]
-> ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[NamesT (TCMT IO) Term]
x,[NamesT (TCMT IO) Term]
y] (([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
 -> NamesT (TCMT IO) [Abs [Term]])
-> ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]]
forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term]
z -> do
           String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((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 -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
z (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)
   let sys :: [(Term, Abs [Term])]
sys = [Term] -> [Abs [Term]] -> [(Term, Abs [Term])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
faces [Abs [Term]]
us
   -- [(neg j, bind "i" $ \ i -> flip map x (<@> i))
   -- ,(j , bind "i" $ \ i -> flip map y (<@> i))]
   Term
phi <- NamesT (TCMT IO) Term
phi
   [Term]
p0 <- (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term] -> 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 (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
j) [NamesT (TCMT IO) Term]
p
   let toArgs :: [Term] -> [Arg Term]
toArgs = (Arg String -> Term -> Arg Term)
-> [Arg String] -> [Term] -> [Arg Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Arg String
a Term
t -> Term
t Term -> Arg String -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg String
a) (Telescope -> [Arg String]
teleArgNames (Abs Telescope -> Telescope
forall a. Abs a -> a
unAbs (Abs Telescope -> Telescope) -> Abs Telescope -> Telescope
forall a b. (a -> b) -> a -> b
$ Abs Telescope
theTel))
   Either (Closure (Abs Type)) [Arg Term]
eq <- TCM (Either (Closure (Abs Type)) [Arg Term])
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM (Either (Closure (Abs Type)) [Arg Term])
 -> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term]))
-> (ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
    -> TCM (Either (Closure (Abs Type)) [Arg Term]))
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> TCM (Either (Closure (Abs Type)) [Arg Term])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
 -> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term]))
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall a b. (a -> b) -> a -> b
$ Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpSysTel' Bool
False Abs Telescope
theTel [(Term, Abs [Term])]
sys Term
phi ([Term] -> [Arg Term]
toArgs [Term]
p0)
   (Closure (Abs Type) -> NamesT (TCMT IO) [Arg Term])
-> ([Arg Term] -> NamesT (TCMT IO) [Arg Term])
-> Either (Closure (Abs Type)) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TCM [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM [Arg Term] -> NamesT (TCMT IO) [Arg Term])
-> (Closure (Abs Type) -> TCM [Arg Term])
-> Closure (Abs Type)
-> NamesT (TCMT IO) [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [Arg Term] -> TCM [Arg Term]
forall (m :: * -> *) a. Monad m => m a -> TCMT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [Arg Term] -> TCM [Arg Term])
-> (Closure (Abs Type) -> IO [Arg Term])
-> Closure (Abs Type)
-> TCM [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranspError -> IO [Arg Term]
forall a e. Exception e => e -> a
throw (TranspError -> IO [Arg Term])
-> (Closure (Abs Type) -> TranspError)
-> Closure (Abs Type)
-> IO [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Abs Type) -> TranspError
CannotTransp) [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either (Closure (Abs Type)) [Arg Term]
eq
 NamesT (TCMT IO) [Arg Term]
qs

transpPathTel' ::
             NamesT TCM (Abs Telescope) -- ^ i.Δ                 const on φ
             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[i]  const on φ
             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[i]  const on φ
             -> NamesT TCM Term            -- ^ φ
             -> [NamesT TCM Term]          -- ^ p : Path (Δ[0]) (x 0) (y 0)
             -> NamesT TCM [Arg Term] -- Path (Δ[1]) (x 1) (y 1) [ φ ↦ q ]
transpPathTel' :: NamesT (TCMT IO) (Abs Telescope)
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathTel' NamesT (TCMT IO) (Abs Telescope)
theTel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
y NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p = do
 let neg :: NamesT m Term -> NamesT m Term
neg 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
primINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
 -- is the open overkill?
 NamesT (TCMT IO) [Arg Term]
qs <- ([Arg Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Arg Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term]))
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Arg Term]
 -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term]))
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall a b. (a -> b) -> a -> b
$ (Abs [Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Abs (Arg Term) -> Arg Term) -> [Abs (Arg Term)] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Abs String
n (Arg ArgInfo
i Term
t)) -> ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
n Term
t)) ([Abs (Arg Term)] -> [Arg Term])
-> (Abs [Arg Term] -> [Abs (Arg Term)])
-> Abs [Arg Term]
-> [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs [Arg Term] -> [Abs (Arg Term)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Abs (f a) -> f (Abs a)
sequenceA)
                  (NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) [Arg Term])
 -> NamesT (TCMT IO) (Abs [Arg Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> do
   Abs Telescope
theTel <- NamesT (TCMT IO) (Abs Telescope)
theTel
   [Term]
faces <- [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term])
-> [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ [NamesT (TCMT IO) Term -> 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
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j]
   [Abs [Term]]
us <- [[NamesT (TCMT IO) Term]]
-> ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[NamesT (TCMT IO) Term]
x,[NamesT (TCMT IO) Term]
y] (([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
 -> NamesT (TCMT IO) [Abs [Term]])
-> ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]]
forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term]
z -> do
           String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((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 -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
z (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)
   let sys :: [(Term, Abs [Term])]
sys = [Term] -> [Abs [Term]] -> [(Term, Abs [Term])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
faces [Abs [Term]]
us
   -- [(neg j, bind "i" $ \ i -> flip map x (<@> i))
   -- ,(j , bind "i" $ \ i -> flip map y (<@> i))]
   Term
phi <- NamesT (TCMT IO) Term
phi
   [Term]
p0 <- (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term] -> 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 (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
j) [NamesT (TCMT IO) Term]
p
   let toArgs :: [Term] -> [Arg Term]
toArgs = (Arg String -> Term -> Arg Term)
-> [Arg String] -> [Term] -> [Arg Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Arg String
a Term
t -> Term
t Term -> Arg String -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg String
a) (Telescope -> [Arg String]
teleArgNames (Abs Telescope -> Telescope
forall a. Abs a -> a
unAbs Abs Telescope
theTel))
   Either (Closure (Abs Type)) [Arg Term]
eq <- TCM (Either (Closure (Abs Type)) [Arg Term])
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM (Either (Closure (Abs Type)) [Arg Term])
 -> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term]))
-> (ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
    -> TCM (Either (Closure (Abs Type)) [Arg Term]))
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> TCM (Either (Closure (Abs Type)) [Arg Term])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
 -> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term]))
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall a b. (a -> b) -> a -> b
$ Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpSysTel' Bool
False Abs Telescope
theTel [(Term, Abs [Term])]
sys Term
phi ([Term] -> [Arg Term]
toArgs [Term]
p0)
   (Closure (Abs Type) -> NamesT (TCMT IO) [Arg Term])
-> ([Arg Term] -> NamesT (TCMT IO) [Arg Term])
-> Either (Closure (Abs Type)) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TCM [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM [Arg Term] -> NamesT (TCMT IO) [Arg Term])
-> (Closure (Abs Type) -> TCM [Arg Term])
-> Closure (Abs Type)
-> NamesT (TCMT IO) [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [Arg Term] -> TCM [Arg Term]
forall (m :: * -> *) a. Monad m => m a -> TCMT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [Arg Term] -> TCM [Arg Term])
-> (Closure (Abs Type) -> IO [Arg Term])
-> Closure (Abs Type)
-> TCM [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranspError -> IO [Arg Term]
forall a e. Exception e => e -> a
throw (TranspError -> IO [Arg Term])
-> (Closure (Abs Type) -> TranspError)
-> Closure (Abs Type)
-> IO [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Abs Type) -> TranspError
CannotTransp) [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either (Closure (Abs Type)) [Arg Term]
eq
 NamesT (TCMT IO) [Arg Term]
qs

trFillPathTel' ::
               NamesT TCM (Abs Telescope) -- ^ i.Δ                 const on φ
             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[i]  const on φ
             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[i]  const on φ
             -> NamesT TCM Term            -- ^ φ
             -> [NamesT TCM Term]          -- ^ p : Path (Δ[0]) (x 0) (y 0)
             -> NamesT TCM Term            -- ^ r
             -> NamesT TCM [Arg Term] -- Path (Δ[r]) (x r) (y r) [ φ ↦ q; (r = 0) ↦ q ]
trFillPathTel' :: NamesT (TCMT IO) (Abs Telescope)
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) [Arg Term]
trFillPathTel' NamesT (TCMT IO) (Abs Telescope)
tel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
y NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p NamesT (TCMT IO) Term
r = do
  let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
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
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 min :: NamesT m Term -> NamesT m Term -> NamesT m Term
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 -> NamesT m Term
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
  [NamesT (TCMT IO) Term]
x' <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
 -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((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 -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [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
-> 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
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i))
  [NamesT (TCMT IO) Term]
y' <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
 -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((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 -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
y (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i))
  NamesT (TCMT IO) (Abs Telescope)
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathTel' (String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) Telescope)
 -> NamesT (TCMT IO) (Abs Telescope))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> Abs Telescope -> Term -> Telescope
Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Telescope -> Term -> Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
-> NamesT (TCMT IO) (Term -> Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Telescope)
tel NamesT (TCMT IO) (Term -> Telescope)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Telescope
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i)
                 [NamesT (TCMT IO) Term]
x'
                 [NamesT (TCMT IO) Term]
y'
                 (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
phi (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
r))
                 [NamesT (TCMT IO) Term]
p

trFillPathPTel' ::
               NamesT TCM (Abs (Abs Telescope)) -- ^ j.i.Δ                 const on φ
             -> [NamesT TCM Term]          -- ^ x : (i : I) → Δ[0,i]  const on φ
             -> [NamesT TCM Term]          -- ^ y : (i : I) → Δ[1,i]  const on φ
             -> NamesT TCM Term            -- ^ φ
             -> [NamesT TCM Term]          -- ^ p : Path (\ j -> Δ[j,0]) (x 0) (y 0)
             -> NamesT TCM Term            -- ^ r
             -> NamesT TCM [Arg Term] -- Path (\ j → Δ[j,r]) (x r) (y r) [ φ ↦ q; (r = 0) ↦ q ]
trFillPathPTel' :: NamesT (TCMT IO) (Abs (Abs Telescope))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) [Arg Term]
trFillPathPTel' NamesT (TCMT IO) (Abs (Abs Telescope))
tel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
y NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p NamesT (TCMT IO) Term
r = do
  let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
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
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 min :: NamesT m Term -> NamesT m Term -> NamesT m Term
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 -> NamesT m Term
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
  [NamesT (TCMT IO) Term]
x' <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
 -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((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 -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [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
-> 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
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i))
  [NamesT (TCMT IO) Term]
y' <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
 -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((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 -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
y (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i))
  NamesT (TCMT IO) (Abs (Abs Telescope))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathPTel' (String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs Telescope))
-> NamesT (TCMT IO) (Abs (Abs Telescope))
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) (Abs Telescope))
 -> NamesT (TCMT IO) (Abs (Abs Telescope)))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) (Abs Telescope))
-> NamesT (TCMT IO) (Abs (Abs Telescope))
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
  -> NamesT (TCMT IO) Telescope)
 -> NamesT (TCMT IO) (Abs Telescope))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
    -> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> Abs Telescope -> Term -> Telescope
Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Telescope -> Term -> Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
-> NamesT (TCMT IO) (Term -> Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Abs (Abs Telescope) -> Term -> Abs Telescope
Abs (Abs Telescope) -> SubstArg (Abs Telescope) -> Abs Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Abs Telescope) -> Term -> Abs Telescope)
-> NamesT (TCMT IO) (Abs (Abs Telescope))
-> NamesT (TCMT IO) (Term -> Abs Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Abs Telescope))
tel NamesT (TCMT IO) (Term -> Abs Telescope)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Abs Telescope)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j) NamesT (TCMT IO) (Term -> Telescope)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Telescope
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> 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
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i)
                 [NamesT (TCMT IO) Term]
x'
                 [NamesT (TCMT IO) Term]
y'
                 (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
phi (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
r))
                 [NamesT (TCMT IO) Term]
p



-- given Γ ⊢ I type, and Γ ⊢ Δ telescope, build Δ^I such that
-- Γ ⊢ (x : A, y : B x, ...)^I = (x : I → A, y : (i : I) → B (x i), ...)
expTelescope :: Type -> Telescope -> Telescope
expTelescope :: Type -> Telescope -> Telescope
expTelescope Type
int Telescope
tel = Names -> [Dom' Term Type] -> Telescope
unflattenTel Names
names [Dom' Term Type]
ys
  where
    stel :: Nat
stel = Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel
    xs :: [Dom' Term Type]
xs = Telescope -> [Dom' Term Type]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel Telescope
tel
    names :: Names
names = Telescope -> Names
teleNames Telescope
tel
    t :: Telescope
t = Dom' Term Type -> Abs Telescope -> Telescope
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type -> Dom' Term Type
forall a. a -> Dom a
defaultDom (Type -> Dom' Term Type) -> Type -> Dom' Term Type
forall a b. (a -> b) -> a -> b
$ Nat -> Type -> Type
forall a. Subst a => Nat -> a -> a
raise Nat
stel Type
int) (String -> Telescope -> Abs Telescope
forall a. String -> a -> Abs a
Abs String
"i" Telescope
forall a. Tele a
EmptyTel)
    s :: Substitution' Term
s = Nat -> Substitution' Term
expS Nat
stel
    ys :: [Dom' Term Type]
ys = (Dom' Term Type -> Dom' Term Type)
-> [Dom' Term Type] -> [Dom' Term Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Type) -> Dom' Term Type -> Dom' Term 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 (Telescope -> Type -> Type
forall t. Abstract t => Telescope -> t -> t
abstract Telescope
t) (Dom' Term Type -> Dom' Term Type)
-> (Dom' Term Type -> Dom' Term Type)
-> Dom' Term Type
-> Dom' Term Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution' (SubstArg (Dom' Term Type))
-> Dom' Term Type -> Dom' Term Type
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' Term
Substitution' (SubstArg (Dom' Term Type))
s) [Dom' Term Type]
xs


-- | Γ, Δ^I, i : I |- expS |Δ| : Γ, Δ
expS :: Nat -> Substitution
expS :: Nat -> Substitution' Term
expS Nat
stel = Impossible
-> [Maybe Term] -> Substitution' Term -> Substitution' Term
forall a.
DeBruijn a =>
Impossible -> [Maybe a] -> Substitution' a -> Substitution' a
prependS Impossible
forall a. HasCallStack => a
__IMPOSSIBLE__
  [ Term -> Maybe Term
forall a. a -> Maybe a
Just (Nat -> Term
var Nat
n Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Nat -> Term
var Nat
0]) | Nat
n <- [Nat
1..Nat
stel] ]
  (Nat -> Substitution' Term
forall a. Nat -> Substitution' a
raiseS (Nat
stel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
1))


-- * Special cases of Type
-----------------------------------------------------------

-- | A @Type@ with sort @Type l@
--   Such a type supports both hcomp and transp.
data LType = LEl Level Term deriving (LType -> LType -> Bool
(LType -> LType -> Bool) -> (LType -> LType -> Bool) -> Eq LType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LType -> LType -> Bool
== :: LType -> LType -> Bool
$c/= :: LType -> LType -> Bool
/= :: LType -> LType -> Bool
Eq,Nat -> LType -> String -> String
[LType] -> String -> String
LType -> String
(Nat -> LType -> String -> String)
-> (LType -> String) -> ([LType] -> String -> String) -> Show LType
forall a.
(Nat -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Nat -> LType -> String -> String
showsPrec :: Nat -> LType -> String -> String
$cshow :: LType -> String
show :: LType -> String
$cshowList :: [LType] -> String -> String
showList :: [LType] -> String -> String
Show)

fromLType :: LType -> Type
fromLType :: LType -> Type
fromLType (LEl Level' Term
l Term
t) = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El (Level' Term -> Sort
forall t. Level' t -> Sort' t
Type Level' Term
l) Term
t

lTypeLevel :: LType -> Level
lTypeLevel :: LType -> Level' Term
lTypeLevel (LEl Level' Term
l Term
t) = Level' Term
l

toLType :: MonadReduce m => Type -> m (Maybe LType)
toLType :: forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType Type
ty = do
  Sort
sort <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort Type
ty
  case Sort
sort of
    Type Level' Term
l -> Maybe LType -> m (Maybe LType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LType -> m (Maybe LType)) -> Maybe LType -> m (Maybe LType)
forall a b. (a -> b) -> a -> b
$ LType -> Maybe LType
forall a. a -> Maybe a
Just (LType -> Maybe LType) -> LType -> Maybe LType
forall a b. (a -> b) -> a -> b
$ Level' Term -> Term -> LType
LEl Level' Term
l (Type -> Term
forall t a. Type'' t a -> a
unEl Type
ty)
    Sort
_      -> Maybe LType -> m (Maybe LType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LType -> m (Maybe LType)) -> Maybe LType -> m (Maybe LType)
forall a b. (a -> b) -> a -> b
$ Maybe LType
forall a. Maybe a
Nothing

instance Subst LType where
  type SubstArg LType = Term
  applySubst :: Substitution' (SubstArg LType) -> LType -> LType
applySubst Substitution' (SubstArg LType)
rho (LEl Level' Term
l Term
t) = Level' Term -> Term -> LType
LEl (Substitution' (SubstArg (Level' Term))
-> Level' Term -> Level' Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg (Level' Term))
Substitution' (SubstArg LType)
rho Level' Term
l) (Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg Term)
Substitution' (SubstArg LType)
rho Term
t)

-- | A @Type@ that either has sort @Type l@ or is a closed definition.
--   Such a type supports some version of transp.
--   In particular we want to allow the Interval as a @ClosedType@.
data CType = ClosedType Sort QName | LType LType deriving (CType -> CType -> Bool
(CType -> CType -> Bool) -> (CType -> CType -> Bool) -> Eq CType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CType -> CType -> Bool
== :: CType -> CType -> Bool
$c/= :: CType -> CType -> Bool
/= :: CType -> CType -> Bool
Eq,Nat -> CType -> String -> String
[CType] -> String -> String
CType -> String
(Nat -> CType -> String -> String)
-> (CType -> String) -> ([CType] -> String -> String) -> Show CType
forall a.
(Nat -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Nat -> CType -> String -> String
showsPrec :: Nat -> CType -> String -> String
$cshow :: CType -> String
show :: CType -> String
$cshowList :: [CType] -> String -> String
showList :: [CType] -> String -> String
Show)

instance P.Pretty CType where
  pretty :: CType -> Doc
pretty = Type -> Doc
forall a. Pretty a => a -> Doc
P.pretty (Type -> Doc) -> (CType -> Type) -> CType -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CType -> Type
fromCType

fromCType :: CType -> Type
fromCType :: CType -> Type
fromCType (ClosedType Sort
s QName
q) = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El Sort
s (QName -> [Elim] -> Term
Def QName
q [])
fromCType (LType LType
t) = LType -> Type
fromLType LType
t

toCType :: MonadReduce m => Type -> m (Maybe CType)
toCType :: forall (m :: * -> *). MonadReduce m => Type -> m (Maybe CType)
toCType Type
ty = do
  Sort
sort <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort Type
ty
  case Sort
sort of
    Type Level' Term
l -> Maybe CType -> m (Maybe CType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CType -> m (Maybe CType)) -> Maybe CType -> m (Maybe CType)
forall a b. (a -> b) -> a -> b
$ CType -> Maybe CType
forall a. a -> Maybe a
Just (CType -> Maybe CType) -> CType -> Maybe CType
forall a b. (a -> b) -> a -> b
$ LType -> CType
LType (Level' Term -> Term -> LType
LEl Level' Term
l (Type -> Term
forall t a. Type'' t a -> a
unEl Type
ty))
    SSet{} -> do
      Term
t <- Term -> m Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Type -> Term
forall t a. Type'' t a -> a
unEl Type
ty)
      case Term
t of
        Def QName
q [] -> Maybe CType -> m (Maybe CType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CType -> m (Maybe CType)) -> Maybe CType -> m (Maybe CType)
forall a b. (a -> b) -> a -> b
$ CType -> Maybe CType
forall a. a -> Maybe a
Just (CType -> Maybe CType) -> CType -> Maybe CType
forall a b. (a -> b) -> a -> b
$ Sort -> QName -> CType
ClosedType Sort
sort QName
q
        Term
_        -> Maybe CType -> m (Maybe CType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CType -> m (Maybe CType)) -> Maybe CType -> m (Maybe CType)
forall a b. (a -> b) -> a -> b
$ Maybe CType
forall a. Maybe a
Nothing
    Sort
_      -> Maybe CType -> m (Maybe CType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CType -> m (Maybe CType)) -> Maybe CType -> m (Maybe CType)
forall a b. (a -> b) -> a -> b
$ Maybe CType
forall a. Maybe a
Nothing

instance Subst CType where
  type SubstArg CType = Term
  applySubst :: Substitution' (SubstArg CType) -> CType -> CType
applySubst Substitution' (SubstArg CType)
rho (ClosedType Sort
s QName
q) = Sort -> QName -> CType
ClosedType (Substitution' (SubstArg Sort) -> Sort -> Sort
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg Sort)
Substitution' (SubstArg CType)
rho Sort
s) QName
q
  applySubst Substitution' (SubstArg CType)
rho (LType LType
t) = LType -> CType
LType (LType -> CType) -> LType -> CType
forall a b. (a -> b) -> a -> b
$ Substitution' (SubstArg LType) -> LType -> LType
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg CType)
Substitution' (SubstArg LType)
rho LType
t

hcomp
  :: (HasBuiltins m, MonadError TCErr m, MonadReduce m, MonadPretty m)
  => NamesT m Type
  -> [(NamesT m Term, NamesT m Term)]
  -> NamesT m Term
  -> NamesT m Term
hcomp :: forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m,
 MonadPretty m) =>
NamesT m Type
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
hcomp NamesT m Type
ty [(NamesT m Term, NamesT m Term)]
sys NamesT m Term
u0 = do
  Term
iz <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
  Term
tHComp <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primHComp
  let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
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
  Type
ty <- NamesT m Type
ty
  (Level' Term
l, Term
ty) <- Type -> NamesT m (Maybe LType)
forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType Type
ty NamesT m (Maybe LType)
-> (Maybe LType -> NamesT m (Level' Term, Term))
-> NamesT m (Level' Term, Term)
forall a b. NamesT m a -> (a -> NamesT m b) -> NamesT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Just (LEl Level' Term
l Term
ty) -> (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall a. a -> NamesT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level' Term
l, Term
ty)
    Maybe LType
Nothing -> m (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Level' Term, Term) -> NamesT m (Level' Term, Term))
-> m (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall a b. (a -> b) -> a -> b
$ do -- TODO: support Setω properly
      TypeError -> m (Level' Term, Term)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m (Level' Term, Term))
-> (Doc -> TypeError) -> Doc -> m (Level' Term, Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> m (Level' Term, Term)) -> m Doc -> m (Level' Term, Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [m Doc] -> m Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"Cubical Agda: cannot generate hcomp clauses at type", Type -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
ty ]
  NamesT m Term
l <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ Level' Term -> Term
Level Level' Term
l
  NamesT m Term
ty <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ Term
ty
  Term
face <- ((NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m Term -> [NamesT m Term] -> NamesT m Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NamesT m Term -> NamesT m Term -> NamesT m Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max (Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) ([NamesT m Term] -> NamesT m Term)
-> [NamesT m Term] -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ ((NamesT m Term, NamesT m Term) -> NamesT m Term)
-> [(NamesT m Term, NamesT m Term)] -> [NamesT m Term]
forall a b. (a -> b) -> [a] -> [b]
map (NamesT m Term, NamesT m Term) -> NamesT m Term
forall a b. (a, b) -> a
fst ([(NamesT m Term, NamesT m Term)] -> [NamesT m Term])
-> [(NamesT m Term, NamesT m Term)] -> [NamesT m Term]
forall a b. (a -> b) -> a -> b
$ [(NamesT m Term, NamesT m Term)]
sys)
  Term
sys <- String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i'" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
forall (m :: * -> *).
HasBuiltins m =>
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
combineSys NamesT m Term
l NamesT m Term
ty [(NamesT m Term
phi, NamesT m Term
u 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
phi,NamesT m Term
u) <- [(NamesT m Term, NamesT m Term)]
sys]
  Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
l NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
ty NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
face NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
sys NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0

transpSys :: (HasBuiltins m, MonadError TCErr m, MonadReduce m) =>
               NamesT m (Abs Type) -- ty
               -> [(NamesT m Term, NamesT m Term)] -- sys
               -> NamesT m Term -- φ
               -> NamesT m Term
               -> NamesT m Term
transpSys :: forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m) =>
NamesT m (Abs Type)
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpSys NamesT m (Abs Type)
ty [(NamesT m Term, NamesT m Term)]
sys NamesT m Term
phi NamesT m Term
u = do
  let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
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
  Term
iz <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
  Term
tTransp <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primTrans
  Term
tComp <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> NamesT m (Maybe Term) -> NamesT m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrimitiveId -> NamesT m (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' PrimitiveId
builtinComp
  Abs (Level' Term, Term)
l_ty <- String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
    -> NamesT m (Level' Term, Term))
-> NamesT m (Abs (Level' Term, Term))
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
  -> NamesT m (Level' Term, Term))
 -> NamesT m (Abs (Level' Term, Term)))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
    -> NamesT m (Level' Term, Term))
-> NamesT m (Abs (Level' Term, Term))
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT m b
i -> do
      Type
ty <- Abs Type -> Term -> Type
Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Type -> Term -> Type)
-> NamesT m (Abs Type) -> NamesT m (Term -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT m (Abs Type)
ty NamesT m (Term -> Type) -> NamesT m Term -> NamesT m Type
forall a b. NamesT m (a -> b) -> NamesT m a -> NamesT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT m Term
forall {b}. (Subst b, DeBruijn b) => NamesT m b
i
      Type -> NamesT m (Maybe LType)
forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType Type
ty NamesT m (Maybe LType)
-> (Maybe LType -> NamesT m (Level' Term, Term))
-> NamesT m (Level' Term, Term)
forall a b. NamesT m a -> (a -> NamesT m b) -> NamesT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
        Just (LEl Level' Term
l Term
ty) -> (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall a. a -> NamesT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level' Term
l,Term
ty)
        Maybe LType
Nothing -> (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall a. a -> NamesT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level' Term
HasCallStack => Level' Term
__DUMMY_LEVEL__, Type -> Term
forall t a. Type'' t a -> a
unEl Type
ty) -- TODO: properly support Setω
  NamesT m Term
l <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term)
-> (Abs (Level' Term, Term) -> Abs Term)
-> Abs (Level' Term, Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Level' Term, Term) -> Term)
-> Abs (Level' 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 (Level' Term -> Term
Level (Level' Term -> Term)
-> ((Level' Term, Term) -> Level' Term)
-> (Level' Term, Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Level' Term, Term) -> Level' Term
forall a b. (a, b) -> a
fst) (Abs (Level' Term, Term) -> Term)
-> Abs (Level' Term, Term) -> Term
forall a b. (a -> b) -> a -> b
$ Abs (Level' Term, Term)
l_ty
  NamesT m Term
ty <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term)
-> (Abs (Level' Term, Term) -> Abs Term)
-> Abs (Level' Term, Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Level' Term, Term) -> Term)
-> Abs (Level' 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 (Level' Term, Term) -> Term
forall a b. (a, b) -> b
snd (Abs (Level' Term, Term) -> Term)
-> Abs (Level' Term, Term) -> Term
forall a b. (a -> b) -> a -> b
$ Abs (Level' Term, Term)
l_ty

  if [(NamesT m Term, NamesT m Term)] -> Bool
forall a. Null a => a -> Bool
null [(NamesT m Term, NamesT m Term)]
sys then Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
l NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
ty NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u else do

  let face :: NamesT m Term
face = NamesT m Term -> NamesT m Term -> NamesT m Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
phi ((NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m Term -> [NamesT m Term] -> NamesT m Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NamesT m Term -> NamesT m Term -> NamesT m Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max (Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) ([NamesT m Term] -> NamesT m Term)
-> [NamesT m Term] -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ ((NamesT m Term, NamesT m Term) -> NamesT m Term)
-> [(NamesT m Term, NamesT m Term)] -> [NamesT m Term]
forall a b. (a -> b) -> [a] -> [b]
map (NamesT m Term, NamesT m Term) -> NamesT m Term
forall a b. (a, b) -> a
fst ([(NamesT m Term, NamesT m Term)] -> [NamesT m Term])
-> [(NamesT m Term, NamesT m Term)] -> [NamesT m Term]
forall a b. (a -> b) -> a -> b
$ [(NamesT m Term, NamesT m Term)]
sys)
  NamesT m Term
sys <- (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> NamesT m Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT m Term -> NamesT m (NamesT m Term))
-> NamesT m Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i'" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> do
    let base :: (NamesT m Term, NamesT m Term)
base = (NamesT m Term
phi, String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
_ -> NamesT m Term
u)
    NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
forall (m :: * -> *).
HasBuiltins m =>
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
combineSys NamesT m Term
l NamesT m Term
ty ([(NamesT m Term, NamesT m Term)] -> NamesT m Term)
-> [(NamesT m Term, NamesT m Term)] -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ (NamesT m Term, NamesT m Term)
base (NamesT m Term, NamesT m Term)
-> [(NamesT m Term, NamesT m Term)]
-> [(NamesT m Term, NamesT m Term)]
forall a. a -> [a] -> [a]
: [(NamesT m Term
phi, NamesT m Term
u 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
phi,NamesT m Term
u) <- [(NamesT m Term, NamesT m Term)]
sys]

  Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tComp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
l NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
ty NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
face NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
sys NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u

debugClause :: String -> Clause -> TCM ()
debugClause :: String -> Clause -> TCM ()
debugClause String
s Clause
c = do
      String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"gamma:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
gamma
      String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Elim] -> m Doc
prettyTCM ([NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
ps)
      String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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
<+> TCMT IO Doc
-> (Arg Type -> TCMT IO Doc) -> Maybe (Arg Type) -> TCMT IO Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO Doc
"nothing" Arg Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Type -> m Doc
prettyTCM Maybe (Arg Type)
rhsTy
      String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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
<+> TCMT IO Doc -> (Term -> TCMT IO Doc) -> Maybe Term -> TCMT IO Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO Doc
"nothing" Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Maybe Term
rhs

      String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
30 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$
        Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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
  where
    gamma :: Telescope
gamma = Clause -> Telescope
clauseTel Clause
c
    ps :: [NamedArg DeBruijnPattern]
ps = Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
c
    rhsTy :: Maybe (Arg Type)
rhsTy = Clause -> Maybe (Arg Type)
clauseType Clause
c
    rhs :: Maybe Term
rhs = Clause -> Maybe Term
clauseBody Clause
c