{-# 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
""
  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)
  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 6 $ \ [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
       si <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
i
       vi <- intervalView $ unArg $ ignoreBlocking si
       case 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
          sj <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
j
          vj <- intervalView $ unArg $ ignoreBlocking sj
          case 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
""
  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))
  isOne <- primIsOne
  v <- runNamesT [] $
        lam "a" $ \ 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)
  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ [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
""
  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))
  v <- runNamesT [] $
        lam "a" $ \ 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))
  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 0 $ \ [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
""
  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
  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 5 $ \ [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
        view <- ReduceM (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
        sphi <- reduceB' phi
        case view $ unArg $ ignoreBlocking 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
            sx <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
            mSubIn <- getBuiltinName' builtinSubIn
            case unArg $ ignoreBlocking $ 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
""
  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))
  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 4 [] $ \[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
""
  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
Mixed, Occurrence
StrictPos, Occurrence
Mixed, Occurrence
StrictPos, Occurrence
StrictPos]
  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 occs $ \[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
  tIMax  <- PrimitiveId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal PrimitiveId
builtinIMax
  tINeg  <- getTermLocal builtinINeg
  tHComp <- getTermLocal builtinHComp
  tTrans <- getTermLocal builtinTrans
  iz     <- getTermLocal builtinIZero
  io     <- getTermLocal builtinIOne

  let
    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
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
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

  pure $ \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
  tComp <- PrimitiveId -> NamesT m Term
getTermLocal PrimitiveId
builtinComp
  pure $ \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"
  tTrans <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinTrans
  tHComp <- getTermLocal builtinHComp
  tINeg <- getTermLocal builtinINeg
  tIMax <- getTermLocal builtinIMax
  iz    <- getTermLocal 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
t = do
      s <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ a -> Sort
forall a. LensSort a => a -> Sort
getSort a
t
      case s of
        Type Level' 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
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

  caseMaybeM (toLevel' . absBody . snd . famThing $ ab) (return Nothing) $ \ 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:
    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)
      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 s of
        -- We're looking at a fibrant Pi with fibrant domain: Transport
        -- backwards along the domain.
        Type Level' Term
lx -> do
          [la, 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]
          pure $ Just $ \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
          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
          mInterval <- getBuiltinName' builtinInterval
          case unEl $ ignoreBlocking 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

    caseMaybe trFibrantDomain (return Nothing) $ \(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
    [phi, 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]

    glam (getArgInfo (fst $ famThing ab)) (absName $ snd $ famThing ab) $ \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
          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
          u <- open (raise 1 (unArg u))
          pure tHComp
            <#> (Level <$> toLevel bT)
            <#> pure (unEl bT)
            <#> phi
            <@> lam "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)
            <@> gApply (getHiding a) u0 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:
          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

          pure tTrans
            <#> (tLam <$> traverse (fmap Level . toLevel) bT)
            <@> (pure . tLam $ unEl <$> bT)
            <@> phi
            <@> gApply (getHiding a) u0 (v (pure 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"
  tHComp <- PrimitiveId -> ReduceM Term
getTermLocal PrimitiveId
builtinHComp

  redReturn <=< runNamesT [] $ do
    [l, u, u0, phi, bA, x, y] <- mapM (open . unArg) [l, u, u0, ignoreBlocking phi, bA, x, 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.
    lam "j" $ \ 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"
  iz <- BuiltinId -> ReduceM Term
getTermLocal BuiltinId
builtinIZero
  io <- getTermLocal 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

  redReturn <=< runNamesT [] $ do
    -- In reality to avoid a round-trip between primComp we use mkComp
    -- here.
    comp <- mkComp $ "transport for path types"
    [l, u0, phi] <- traverse (open . unArg) [l, u0, ignoreBlocking phi]
    [bA, x, y] <- 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))) [bA, x, y]
    -- Γ ⊢ bA : (i : I) → Type (l i)
    -- Γ ⊢ x, y : (i : I) → bA i

    lam "j" $ \ 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
  (l,bA,phi,u,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__
  sphi <- reduceB' phi
  vphi <- intervalView $ unArg $ ignoreBlocking sphi
  let 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 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:
        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
        u <@> clP builtinIOne <..> clP 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:
        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
                [l,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]
                lam "i" $ \ 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 []

        pure . NoReduction $ [notReduced (famThing l), reduced sc, reduced sphi] ++ u' ++ [notReduced u0]

    -- Reduce the type whose Kan operations we're composing over:
    sbA <- FamilyOrNot (Arg Term)
-> ReduceM (Blocked (FamilyOrNot (Arg Term)))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' FamilyOrNot (Arg Term)
bA
    t <- case unArg <$> ignoreBlocking 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 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 }

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

        -- By cases on the family, determine what Kan operation we defer
        -- to:
        case famThing 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
            info <- QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
q
            let
              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 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 theDef 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 ([QName] -> Bool
forall a. Null a => a -> Bool
null [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)))
            as <- Term -> ReduceM [(IntMap Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(IntMap Bool, [Term])]
decomposeInterval Term
phi
            (flags,t_alphas) <- fmap unzip . forM as $ \ (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')
                 t <- Term -> ReduceM (Blocked' Term Term)
reduce2Lam Term
u'
                 return $ (p $ ignoreBlocking t, listToMaybe [ (weaken `applySubst` (lamlam <$> t),bs) | null ts ])
            return $ (flags,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
      tEmpty <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIsOneEmpty
      tPOr   <- getTermLocal builtinPOr
      iO   <- getTermLocal builtinIOne
      iZ   <- getTermLocal builtinIZero
      tMin <- getTermLocal builtinIMin
      tNeg <- getTermLocal builtinINeg
      let 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
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 = Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iZ
      constrForm <- do
        mz <- getTerm' builtinZero
        ms <- getTerm' builtinSuc
        return $ \ 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)
      su  <- reduceB' u
      sa0 <- reduceB' a0
      view   <- intervalView'
      unview <- intervalUnview'
      let 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 = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sphi
          a0 = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sa0
          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 (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
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)
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
                                 [l,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]
                                 lam "i" $ \ 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
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
            (b, 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
              (lit,hd) = unzip b

            if isJust lt && and lit then redReturn a0 else do
            su <- caseMaybe (sequence ts) (return su) $ \ [(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
                u <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u
                [l,c] <- mapM (open . unArg) [l,ignoreBlocking sc]
                phis <- mapM open phis
                us   <- mapM (open . ignoreBlocking) us
                lam "i" $ \ 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 isJust h && and hd then k (fromMaybe __IMPOSSIBLE__ h) su
                      else noRed' su

      sameConHeadBack (isLit a0) (isCon a0) su $ \ 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 = 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 nameOfHComp 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
      mhcompName <- PrimitiveId -> ReduceM (Maybe QName)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe QName)
getName' PrimitiveId
builtinHComp
      constrForm <- do
        mz <- getTerm' builtinZero
        ms <- getTerm' builtinSuc
        return $ \ 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)
      sa0 <- reduceB' a0
      let 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 = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sphi
          a0 = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sa0
          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 = 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 constrForm a0 of
        Con ConHead
h ConInfo
_ [Elim]
args -> do
          Constructor{ conComp = 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 nameOfTransp 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
           hcomp <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinHComp
           transp <- getTermLocal builtinTrans
           io <- getTermLocal builtinIOne
           iz <- getTermLocal builtinIZero
           redReturn <=< runNamesT [] $ do
             [l,bC,phi,psi,u,u0] <- mapM (open . unArg) [l,bC,ignoreBlocking sphi,psi,u,u0]
             -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0)
             pure hcomp <#> (l <@> pure io) <#> (bC <@> pure io) <#> psi
                   <@> lam "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))
                   <@> (pure transp <#> l <@> bC <@> phi <@> 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
       ]
      __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
""
  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))
  one <- primItIsOne
  io  <- primIOne
  return $ PrimImpl t $ PrimFun __IMPOSSIBLE__ 5 [] $ \[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
        sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
        vphi <- intervalView $ unArg $ ignoreBlocking sphi
        case 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
              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)
              [l,c,phi,u,a0] <- mapM (open . unArg) [l,c,phi,u,a0]
              comp l c phi u 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
""
  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
  return $ PrimImpl t $ primFun __IMPOSSIBLE__ 1 $ \case
    [Arg Term
phi] -> do
      sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
      case unArg $ ignoreBlocking $ sphi of
        Lam ArgInfo
_ Abs Term
t -> do
          t <- Abs Term -> ReduceM (Abs Term)
forall t. Reduce t => t -> ReduceM t
reduce' Abs Term
t
          case 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
      view <- m (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
      unview <- intervalUnview'
      us' <- decomposeInterval t
      fr <- getTerm (getBuiltinId PrimFaceForall) PrimFaceForall
      let
        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 = [ ((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
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
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 [] = 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 = ([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]) $
      return $ case 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"
  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
  tComp <- getTermLocal builtinComp
  tPOr <- getTermLocal builtinPOr
  iz <- lift primIZero
  imin <- lift primIMin
  imax <- lift primIMax
  ineg <- lift primINeg
  let
    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 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
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
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
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 (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
      t' <- NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t
      us' <- mapM snd u
      case ( 0 `freeIn` (raise 1 t' `lazyAbsApp` var 0)
           , 0 `freeIn` 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) 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.Ξ
      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 xi _ <- (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
          return xi
      argnames <- do
        teleArgNames . unAbs <$> xi
      glamN argnames $ \ NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
xi_args -> do
        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
          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
          xin <- bind "i" $ \ 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)
          xi_args <- xi_args
          ni <- pure ineg <@> i
          phi <- phi
          lift $ piApplyM ti =<< trFillTel' flag xin phi xi_args ni
        usxi <- forM us $ \ 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
          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
          xin <- bind "i" $ \ 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)
          xi_args <- xi_args
          ni <- pure ineg <@> i
          phi <- phi
          lift $ apply ui <$> trFillTel' flag xin phi xi_args ni
        axi <- do
          a <- a
          xif <- bind "i" $ \ 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)
          phi <- phi
          xi_args <- xi_args
          lift $ apply a <$> transpTel' flag xif phi xi_args
        s <- reduce $ getSort (absBody b')
        reportSDoc "cubical.transp" 20 $ pretty (raise 1 b' `lazyAbsApp` var 0)
        let 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 s of
          Type Level' Term
l -> do
            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)
            b' <- open b'
            axi <- open axi
            usxi <- mapM open usxi
            gTransp (Just l) b' (zip psis usxi) phi 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 = 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
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]
      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]
      (b,bf) <- runNamesT [] $ do
        l <- case 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))
        t <- open $ Abs "i" (unDom t)
        u <- forM u $ \ (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)
        [phi,a] <- mapM open [phi, unArg a]
        b <- gTransp l t u phi a
        bf <- bind "i" $ \ 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
        return (b, absBody bf)
      (:) (b <$ a) <$> go (lazyAbsApp delta bf) us phi 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 (psis,uss) = unzip us
      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)
  go (absBody delta) us' phi 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
  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
  imax <- lift primIMax
  ineg <- lift primINeg
  transpTel' flag (Abs "j" $ raise 1 delta `lazyAbsApp` (imin `apply` (map argN [var 0, raise 1 r])))
            (imax `apply` [argN $ ineg `apply` [argN r], argN phi])
            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
  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 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
  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
  go pathp (raise 1 tel) lhs 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
    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' = 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 ->
    (ExtendTel (a' <$ a) <$>) . runNamesT [] $ do
      let nm = (Abs Telescope -> String
forall a. Abs a -> String
absName Abs Telescope
tel)
      tel <- open $ Abs "i" tel
      [u,v] <- mapM (open . unArg) [u,v]
      [lhs,rhs] <- mapM open [lhs,rhs]
      bind nm $ \ forall b. (Subst b, DeBruijn b) => NamesT m b
eq -> do
        lhs <- NamesT m [Arg Term]
lhs
        rhs <- rhs
        tel' <- bind "i" $ \ 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))
        lift $ go pathp (absBody tel') lhs 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
    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 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?
 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
   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
   faces <- sequence [neg j, j]
   us <- forM [x,y] $ \ [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]] -> [(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))]
   phi <- phi
   p0 <- mapM (<@> j) p
   let 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))
   eq <- lift . runExceptT $ transpSysTel' False theTel sys phi (toArgs p0)
   either (lift . lift . throw . CannotTransp) pure eq
 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?
 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
   theTel <- NamesT (TCMT IO) (Abs Telescope)
theTel
   faces <- sequence $ [neg j, j]
   us <- forM [x,y] $ \ [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]] -> [(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))]
   phi <- phi
   p0 <- mapM (<@> j) p
   let 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))
   eq <- lift . runExceptT $ transpSysTel' False theTel sys phi (toArgs p0)
   either (lift . lift . throw . CannotTransp) pure eq
 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
  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))
  y' <- (mapM open =<<) $ lamTel $ bind "i" $ \ 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))
  transpPathTel' (bind "i" $ \ 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)
                 x'
                 y'
                 (max phi (neg r))
                 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
  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))
  y' <- (mapM open =<<) $ lamTel $ bind "i" $ \ 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))
  transpPathPTel' (bind "j" $ \ 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)
                 x'
                 y'
                 (max phi (neg r))
                 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 -> 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 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 -> 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 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
      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 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
  iz <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
  tHComp <- primHComp
  let max NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
  ty <- ty
  (l, ty) <- toLType ty >>= \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 ]
  l <- open $ Level l
  ty <- open $ ty
  face <- (foldr max (pure iz) $ map fst $ sys)
  sys <- lam "i'" $ \ 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]
  pure tHComp <#> l <#> ty <#> pure face <@> pure sys <@> 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
  iz <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
  tTransp <- primTrans
  tComp <- fromMaybe __IMPOSSIBLE__ <$> getTerm' builtinComp
  l_ty <- bind "i" $ \ forall b. (Subst b, DeBruijn b) => NamesT m b
i -> do
      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
      toLType ty >>= \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ω
  l <- open $ Lam defaultArgInfo . fmap (Level . fst) $ l_ty
  ty <- open $ Lam defaultArgInfo . fmap snd $ l_ty

  if null sys then pure tTransp <#> l <@> ty <@> phi <@> u else do

  let 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)
  sys <- (open =<<) $ lam "i'" $ \ 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]

  pure tComp <#> l <@> ty <#> face <@> sys <@> 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