{-# LANGUAGE NondecreasingIndentation #-}

module Agda.TypeChecking.Primitive.Cubical where

import Prelude hiding (null, (!!))

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

import Data.Either ( partitionEithers )
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Set (Set)
import qualified Data.Set as Set
import Data.Foldable hiding (null)

import Agda.Interaction.Options ( optCubical )

import Agda.Syntax.Common
import Agda.Syntax.Internal

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

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

import Agda.Utils.Functor
import Agda.Utils.Impossible
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Tuple

-- | Checks that the correct variant of Cubical Agda is activated.
-- Note that @--erased-cubical@ \"counts as\" @--cubical@ in erased
-- contexts.

requireCubical
  :: Cubical -- ^ Which variant of Cubical Agda is required?
  -> String -> TCM ()
requireCubical :: Cubical -> [Char] -> TCM ()
requireCubical Cubical
wanted [Char]
s = do
  Maybe Cubical
cubical         <- PragmaOptions -> Maybe Cubical
optCubical (PragmaOptions -> Maybe Cubical)
-> TCMT IO PragmaOptions -> TCMT IO (Maybe Cubical)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
  Bool
inErasedContext <- TCEnv -> Bool
forall a. LensQuantity a => a -> Bool
hasQuantity0 (TCEnv -> Bool) -> TCMT IO TCEnv -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO TCEnv
getEnv
  case Maybe Cubical
cubical of
    Just Cubical
CFull -> () -> TCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Just Cubical
CErased | Cubical
wanted Cubical -> Cubical -> Bool
forall a. Eq a => a -> a -> Bool
== Cubical
CErased Bool -> Bool -> Bool
|| Bool
inErasedContext -> () -> TCM ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe Cubical
_ -> TypeError -> TCM ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM ()) -> TypeError -> TCM ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$ [Char]
"Missing option " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
opt [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
s
  where
  opt :: [Char]
opt = case Cubical
wanted of
    Cubical
CFull   -> [Char]
"--cubical"
    Cubical
CErased -> [Char]
"--cubical or --erased-cubical"

primIntervalType :: (HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) => m Type
primIntervalType :: forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El (Level' Term -> Sort
forall t. Level' t -> Sort' t
SSet (Level' Term -> Sort) -> Level' Term -> Sort
forall a b. (a -> b) -> a -> b
$ Integer -> Level' Term
ClosedLevel Integer
0) (Term -> Type) -> m Term -> m Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primInterval

primINeg' :: TCM PrimitiveImpl
primINeg' :: TCM PrimitiveImpl
primINeg' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType TCMT IO Type -> TCMT IO Type -> TCMT IO Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
1 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
    case Args
ts of
     [Arg Term
x] -> do
       IntervalView -> Term
unview <- ReduceM (IntervalView -> Term)
forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
       Term -> IntervalView
view <- ReduceM (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
       Blocked (Arg Term)
sx <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
       IntervalView
ix <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sx)
       let
         ineg :: Arg Term -> Arg Term
         ineg :: Arg Term -> Arg Term
ineg = (Term -> Term) -> Arg Term -> Arg Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IntervalView -> Term
unview (IntervalView -> Term) -> (Term -> IntervalView) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntervalView -> IntervalView
f (IntervalView -> IntervalView)
-> (Term -> IntervalView) -> Term -> IntervalView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> IntervalView
view)
         f :: IntervalView -> IntervalView
f IntervalView
ix = case IntervalView
ix of
           IntervalView
IZero -> IntervalView
IOne
           IntervalView
IOne  -> IntervalView
IZero
           IMin Arg Term
x Arg Term
y -> Arg Term -> Arg Term -> IntervalView
IMax (Arg Term -> Arg Term
ineg Arg Term
x) (Arg Term -> Arg Term
ineg Arg Term
y)
           IMax Arg Term
x Arg Term
y -> Arg Term -> Arg Term -> IntervalView
IMin (Arg Term -> Arg Term
ineg Arg Term
x) (Arg Term -> Arg Term
ineg Arg Term
y)
           INeg Arg Term
x -> Term -> IntervalView
OTerm (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
x)
           OTerm Term
t -> Arg Term -> IntervalView
INeg (ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo Term
t)
       case IntervalView
ix of
        OTerm Term
t -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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)
sx]
        IntervalView
_       -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (IntervalView -> Term
unview (IntervalView -> Term) -> IntervalView -> Term
forall a b. (a -> b) -> a -> b
$ IntervalView -> IntervalView
f IntervalView
ix)
     Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primDepIMin' :: TCM PrimitiveImpl
primDepIMin' :: TCM PrimitiveImpl
primDepIMin' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
       [Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ (\ NamesT TCM Term
o -> NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType) NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
2 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
    case Args
ts of
      [Arg Term
x,Arg Term
y] -> do
        Blocked (Arg Term)
sx <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
        IntervalView
ix <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sx)
        Term
itisone <- [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
"primDepIMin" [Char]
builtinItIsOne
        case IntervalView
ix of
          IntervalView
IZero -> 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
=<< IntervalView -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
IZero
          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 (f :: * -> *) a. Applicative f => a -> f a
pure (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
y) ReduceM Term -> ReduceM Term -> ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
itisone)
          IntervalView
_     -> do
            Blocked (Arg Term)
sy <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
y
            IntervalView
iy <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView)
-> ReduceM Term -> ReduceM IntervalView
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' (Term -> ReduceM Term) -> ReduceM Term -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Term -> ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sy) ReduceM Term -> ReduceM Term -> ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
itisone)
            case IntervalView
iy of
              IntervalView
IZero -> 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
=<< IntervalView -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
IZero
              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 -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sx)
              IntervalView
_     -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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)
sx, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sy]
      Args
_      -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl
primIBin :: IntervalView -> IntervalView -> TCM PrimitiveImpl
primIBin IntervalView
unit IntervalView
absorber = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType TCMT IO Type -> TCMT IO Type -> TCMT IO Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType TCMT IO Type -> TCMT IO Type -> TCMT IO Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
2 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
    case Args
ts of
     [Arg Term
x,Arg Term
y] -> do
       Blocked (Arg Term)
sx <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
       IntervalView
ix <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sx)
       case IntervalView
ix of
         IntervalView
ix | IntervalView
ix IntervalView -> IntervalView -> Bool
==% IntervalView
absorber -> 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
=<< IntervalView -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
absorber
         IntervalView
ix | IntervalView
ix IntervalView -> IntervalView -> Bool
==% IntervalView
unit     -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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
$ Simplification -> Term -> Reduced MaybeReducedArgs Term
forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
YesSimplification (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
y)
         IntervalView
_     -> do
           Blocked (Arg Term)
sy <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
y
           IntervalView
iy <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sy)
           case IntervalView
iy of
            IntervalView
iy | IntervalView
iy IntervalView -> IntervalView -> Bool
==% IntervalView
absorber -> 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
=<< IntervalView -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
absorber
            IntervalView
iy | IntervalView
iy IntervalView -> IntervalView -> Bool
==% IntervalView
unit     -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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
$ Simplification -> Term -> Reduced MaybeReducedArgs Term
forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
YesSimplification (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
x)
            IntervalView
_                   -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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)
sx,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sy]
     Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
  where
    ==% :: IntervalView -> IntervalView -> Bool
(==%) IntervalView
IZero IntervalView
IZero = Bool
True
    (==%) IntervalView
IOne IntervalView
IOne = Bool
True
    (==%) IntervalView
_ IntervalView
_ = Bool
False


primIMin' :: TCM PrimitiveImpl
primIMin' :: TCM PrimitiveImpl
primIMin' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  IntervalView -> IntervalView -> TCM PrimitiveImpl
primIBin IntervalView
IOne IntervalView
IZero

primIMax' :: TCM PrimitiveImpl
primIMax' :: TCM PrimitiveImpl
primIMax' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  IntervalView -> IntervalView -> TCM PrimitiveImpl
primIBin IntervalView
IZero IntervalView
IOne

imax :: HasBuiltins m => m Term -> m Term -> m Term
imax :: forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax m Term
x m Term
y = do
  Term
x' <- m Term
x
  Term
y' <- m Term
y
  IntervalView -> m Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview (Arg Term -> Arg Term -> IntervalView
IMax (Term -> Arg Term
forall e. e -> Arg e
argN Term
x') (Term -> Arg Term
forall e. e -> Arg e
argN Term
y'))

imin :: HasBuiltins m => m Term -> m Term -> m Term
imin :: forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imin m Term
x m Term
y = do
  Term
x' <- m Term
x
  Term
y' <- m Term
y
  IntervalView -> m Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview (Arg Term -> Arg Term -> IntervalView
IMin (Term -> Arg Term
forall e. e -> Arg e
argN Term
x') (Term -> Arg Term
forall e. e -> Arg e
argN Term
y'))

-- ∀ {a}{c}{A : Set a}{x : A}(C : ∀ y → Id x y → Set c) → C x (conid i1 (\ i → x)) → ∀ {y} (p : Id x y) → C y p
primIdJ :: TCM PrimitiveImpl
primIdJ :: TCM PrimitiveImpl
primIdJ = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"c" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
c ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"x" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
x ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"C" ([Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"y" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
                 NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (TCMT IO Term -> NamesT TCM 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
primId NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y) NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
c)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bC ->
       NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
c (NamesT TCM Term
bC NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@>
            (TCMT IO Term -> NamesT TCM 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
primConId NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT TCM Term
_ -> NamesT TCM Term
x))) NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"y" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) (\ NamesT TCM Term
y ->
        [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"p" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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
primId NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
p ->
        NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
c (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
bC NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
p)
  Maybe QName
conidn <- [Char] -> TCMT IO (Maybe QName)
forall (m :: * -> *).
(HasBuiltins m, MonadReduce m) =>
[Char] -> m (Maybe QName)
getBuiltinName [Char]
builtinConId
  Term
conid  <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primConId
  -- TODO make a kit
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
8 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
    IntervalView -> Term
unview <- ReduceM (IntervalView -> Term)
forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
    let imax :: NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
imax NamesT Fail Term
x NamesT Fail Term
y = do Term
x' <- NamesT Fail Term
x; IntervalView -> Term
unview (IntervalView -> Term) -> (Term -> IntervalView) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Arg Term -> IntervalView
IMax (Term -> Arg Term
forall e. e -> Arg e
argN Term
x') (Arg Term -> IntervalView)
-> (Term -> Arg Term) -> Term -> IntervalView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Term) -> NamesT Fail Term -> NamesT Fail Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT Fail Term
y;
        imin :: NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
imin NamesT Fail Term
x NamesT Fail Term
y = do Term
x' <- NamesT Fail Term
x; IntervalView -> Term
unview (IntervalView -> Term) -> (Term -> IntervalView) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Arg Term -> IntervalView
IMin (Term -> Arg Term
forall e. e -> Arg e
argN Term
x') (Arg Term -> IntervalView)
-> (Term -> Arg Term) -> Term -> IntervalView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Term) -> NamesT Fail Term -> NamesT Fail Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT Fail Term
y;
        ineg :: NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
x = IntervalView -> Term
unview (IntervalView -> Term) -> (Term -> IntervalView) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> IntervalView
INeg (Arg Term -> IntervalView)
-> (Term -> Arg Term) -> Term -> IntervalView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Term) -> NamesT Fail Term -> NamesT Fail Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT Fail Term
x
    Maybe Term
mcomp <- [Char] -> ReduceM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe Term)
getTerm' [Char]
"primComp"
    case Args
ts of
     [Arg Term
la,Arg Term
lc,Arg Term
a,Arg Term
x,Arg Term
c,Arg Term
d,Arg Term
y,Arg Term
eq] -> do
       Blocked (Arg Term)
seq    <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
eq
       case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
seq of
         (Def QName
q [Apply Arg Term
la,Apply Arg Term
a,Apply Arg Term
x,Apply Arg Term
y,Apply Arg Term
phi,Apply Arg Term
p])
           | 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
conidn, Just Term
comp <- Maybe Term
mcomp -> do
          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
$ Names -> NamesT Fail Term -> Term
forall a. Names -> NamesT Fail a -> a
runNames [] (NamesT Fail Term -> Term) -> NamesT Fail Term -> Term
forall a b. (a -> b) -> a -> b
$ do
             [NamesT Fail Term
lc,NamesT Fail Term
c,NamesT Fail Term
d,NamesT Fail Term
la,NamesT Fail Term
a,NamesT Fail Term
x,NamesT Fail Term
y,NamesT Fail Term
phi,NamesT Fail Term
p] <- (Arg Term -> NamesT Fail (NamesT Fail Term))
-> Args -> NamesT Fail [NamesT Fail Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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
lc,Arg Term
c,Arg Term
d,Arg Term
la,Arg Term
a,Arg Term
x,Arg Term
y,Arg Term
phi,Arg Term
p]
             let w :: NamesT Fail Term -> NamesT Fail Term
w NamesT Fail Term
i = do
                   [Term
x,Term
y,Term
p,Term
i] <- [NamesT Fail Term] -> NamesT Fail [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [NamesT Fail Term
x,NamesT Fail Term
y,NamesT Fail Term
p,NamesT Fail Term
i]
                   Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT Fail Term) -> Term -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ Term
p Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [Term -> Term -> Term -> Elim
forall a. a -> a -> a -> Elim' a
IApply Term
x Term
y Term
i]
             Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
comp NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Fail Term
_ -> NamesT Fail Term
lc)
                       NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Fail Term
i ->
                              NamesT Fail Term
c NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Fail Term -> NamesT Fail Term
w NamesT Fail Term
i)
                                NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
conid NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
la NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
a NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
x NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Fail Term -> NamesT Fail Term
w NamesT Fail Term
i)
                                                NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Fail Term
phi NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
`imax` NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
i)
                                                NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT Fail Term
j -> NamesT Fail Term -> NamesT Fail Term
w (NamesT Fail Term -> NamesT Fail Term)
-> NamesT Fail Term -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
imin NamesT Fail Term
i NamesT Fail Term
j)))
                       NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
phi
                       NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Fail Term
_ -> Term -> Term
nolam (Term -> Term) -> NamesT Fail Term -> NamesT Fail Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT Fail Term
d) -- TODO block
                       NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
d
         Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
la,Arg Term
lc,Arg Term
a,Arg Term
x,Arg Term
c,Arg Term
d,Arg Term
y] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
seq]
     Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primIdElim' :: TCM PrimitiveImpl
primIdElim' :: TCM PrimitiveImpl
primIdElim' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"c" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
c ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"x" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
x ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"C" ([Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"y" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
                 NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (TCMT IO Term -> NamesT TCM 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
primId NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y) NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
c)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bC ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT TCM Term
phi ->
        [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"y" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT TCM Term
a (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"o" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall a b. a -> b -> a
const NamesT TCM Term
x)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
        let pathxy :: NamesT TCM Term
pathxy = (TCMT IO Term -> NamesT TCM 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
primPath NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
oucy)
            oucy :: NamesT TCM Term
oucy = (TCMT IO Term -> NamesT TCM 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
primSubOut NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char] -> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"o" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall a b. a -> b -> a
const NamesT TCM Term
x) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y)
            reflx :: NamesT TCM Term
reflx = ([Char] -> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"o" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> [Char] -> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> NamesT TCM Term
x) -- TODO Andrea, should block on o
        in
        [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"w" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT TCM Term
a (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
pathxy NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
reflx) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
w ->
        let oucw :: NamesT TCM Term
oucw = (TCMT IO Term -> NamesT TCM 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
primSubOut NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
pathxy NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
reflx NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
w) in
        NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
c (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
bC NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
oucy NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (TCMT IO Term -> NamesT TCM 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
primConId NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
oucy NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
oucw))
       NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"y" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) (\ NamesT TCM Term
y ->
        [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"p" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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
primId NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
p ->
        NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
c (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
bC NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
p)
  Term
conid <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primConId
  Term
sin <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSubIn
  Term
path <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primPath
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
8 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
    case Args
ts of
      [Arg Term
a,Arg Term
c,Arg Term
bA,Arg Term
x,Arg Term
bC,Arg Term
f,Arg Term
y,Arg Term
p] -> do
        Blocked (Arg Term)
sp <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
p
        case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sp of
          Def QName
q [Apply Arg Term
_a, Apply Arg Term
_bA, Apply Arg Term
_x, Apply Arg Term
_y, Apply Arg Term
phi , Apply Arg Term
w] -> do
            let y' :: Term
y' = Term
sin Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Arg Term
a,Arg Term
bA                            ,Arg Term
phi,Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
y]
            let w' :: Term
w' = Term
sin Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Arg Term
a,Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Term
path Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Arg Term
a,Arg Term
bA,Arg Term
x,Arg Term
y],Arg Term
phi,Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
w]
            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
f Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Arg Term
phi, Term -> Arg Term
forall e. e -> Arg e
defaultArg Term
y', Term -> Arg Term
forall e. e -> Arg e
defaultArg Term
w']
          Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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)) -> Args -> 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
c,Arg Term
bA,Arg Term
x,Arg Term
bC,Arg Term
f,Arg Term
y] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sp]
      Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__


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


     Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primPartial' :: TCM PrimitiveImpl
primPartial' :: TCM PrimitiveImpl
primPartial' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term
a ->
        [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ ->
        [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM 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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a))
  Term
isOne <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
3 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
    case Args
ts of
      [Arg Term
l,Arg Term
phi,Arg Term
a] -> do
          (El Sort
s (Pi Dom Type
d Abs Type
b)) <- Names -> NamesT ReduceM Type -> ReduceM Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Type -> ReduceM Type)
-> NamesT ReduceM Type -> ReduceM Type
forall a b. (a -> b) -> a -> b
$ do
                             [NamesT ReduceM Term
l,NamesT ReduceM Term
a,NamesT ReduceM Term
phi] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Args -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
a,Arg Term
phi]
                             NamesT ReduceM Term -> NamesT ReduceM Type
forall (m :: * -> *). Functor m => m Term -> m Type
elSSet (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
isOne 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 Type -> NamesT ReduceM Type -> NamesT ReduceM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT ReduceM Term
l NamesT ReduceM Term
a
          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
$ Dom Type -> Abs Type -> Term
Pi (Relevance -> Dom Type -> Dom Type
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant (Dom Type -> Dom Type) -> Dom Type -> Dom Type
forall a b. (a -> b) -> a -> b
$ Dom Type
d { domFinite :: Bool
domFinite = Bool
True }) Abs Type
b
      Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primPartialP' :: TCM PrimitiveImpl
primPartialP' :: TCM PrimitiveImpl
primPartialP' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term
a ->
        [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
        [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"A" ([Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
phi ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM 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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM 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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a))
  let toFinitePi :: Type -> Term
      toFinitePi :: Type -> Term
toFinitePi (El Sort
_ (Pi Dom Type
d Abs Type
b)) = Dom Type -> Abs Type -> Term
Pi (Relevance -> Dom Type -> Dom Type
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant (Dom Type -> Dom Type) -> Dom Type -> Dom Type
forall a b. (a -> b) -> a -> b
$ Dom Type
d { domFinite :: Bool
domFinite = Bool
True }) Abs Type
b
      toFinitePi Type
_               = Term
forall a. HasCallStack => a
__IMPOSSIBLE__
  Term
v <- Names -> NamesT TCM Term -> TCMT IO Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Term -> TCMT IO Term)
-> NamesT TCM Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$
        [Char] -> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"a" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
l ->
        [Char] -> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"φ" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
        [Char] -> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"A" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
        Type -> Term
toFinitePi (Type -> Term) -> NamesT TCM Type -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"p" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
elSSet (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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
primIsOne NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi) (\ NamesT TCM Term
p -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
l (NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
p))
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
0 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
_ -> 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 -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t    <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"A" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM 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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"u" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT TCM Term
a (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
u ->
          NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT TCM Term
a (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
u) NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
    case Args
ts of
      [Arg Term
a,Arg Term
bA,Arg Term
phi,Arg Term
u,Arg Term
x] -> do
        Term -> IntervalView
view <- ReduceM (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
        Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
        case Term -> IntervalView
view (Term -> IntervalView) -> Term -> IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi of
          IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Term -> ReduceM Term
forall (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
<..> ([Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtinSubOut [Char]
builtinItIsOne))
          IntervalView
_ -> do
            Blocked (Arg Term)
sx <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
            Maybe QName
mSubIn <- [Char] -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getBuiltinName' [Char]
builtinSubIn
            case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sx of
              Def QName
q [Elim
_,Elim
_,Elim
_, Apply Arg Term
t] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mSubIn -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
t)
              Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (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)) -> Args -> 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]
      Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primIdFace' :: TCM PrimitiveImpl
primIdFace' :: TCM PrimitiveImpl
primIdFace' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"x" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
x ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"y" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
       NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (TCMT IO Term -> NamesT TCM 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
primId NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y)
       NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
    case Args
ts of
      [Arg Term
l,Arg Term
bA,Arg Term
x,Arg Term
y,Arg Term
t] -> do
        Blocked (Arg Term)
st <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
t
        Maybe QName
mConId <- [Char] -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getName' [Char]
builtinConId
        case Arg Term -> Term
forall e. Arg e -> e
unArg (Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
st) of
          Def QName
q [Elim
_,Elim
_,Elim
_,Elim
_, Apply Arg Term
phi,Elim
_] | 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
mConId -> 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
phi)
          Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
l,Arg Term
bA,Arg Term
x,Arg Term
y] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
st]
      Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primIdPath' :: TCM PrimitiveImpl
primIdPath' :: TCM PrimitiveImpl
primIdPath' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"x" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
x ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"y" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
       NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (TCMT IO Term -> NamesT TCM 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
primId NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y)
       NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (TCMT IO Term -> NamesT TCM 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
primPath NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y)
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
    case Args
ts of
      [Arg Term
l,Arg Term
bA,Arg Term
x,Arg Term
y,Arg Term
t] -> do
        Blocked (Arg Term)
st <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
t
        Maybe QName
mConId <- [Char] -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getName' [Char]
builtinConId
        case Arg Term -> Term
forall e. Arg e -> e
unArg (Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
st) of
          Def QName
q [Elim
_,Elim
_,Elim
_,Elim
_,Elim
_,Apply Arg Term
w] | 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
mConId -> 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
w)
          Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
l,Arg Term
bA,Arg Term
x,Arg Term
y] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
st]
      Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__


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

primHComp' :: TCM PrimitiveImpl
primHComp' :: TCM PrimitiveImpl
primHComp' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t    <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT TCM Term
i -> [Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
phi ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
          (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA)
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 ((Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> (Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts Int
nelims -> do
    TranspOrHComp
-> Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp TranspOrHComp
DoHComp Args
ts Int
nelims

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

cmdToName :: TranspOrHComp -> String
cmdToName :: TranspOrHComp -> [Char]
cmdToName TranspOrHComp
DoTransp = [Char]
builtinTrans
cmdToName TranspOrHComp
DoHComp  = [Char]
builtinHComp

data FamilyOrNot a
  = IsFam { forall a. FamilyOrNot a -> a
famThing :: a }
  | IsNot { famThing :: a }
  deriving (FamilyOrNot a -> FamilyOrNot a -> Bool
(FamilyOrNot a -> FamilyOrNot a -> Bool)
-> (FamilyOrNot a -> FamilyOrNot a -> Bool) -> Eq (FamilyOrNot a)
forall a. Eq a => FamilyOrNot a -> FamilyOrNot a -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: FamilyOrNot a -> FamilyOrNot a -> Bool
$c/= :: forall a. Eq a => FamilyOrNot a -> FamilyOrNot a -> Bool
== :: FamilyOrNot a -> FamilyOrNot a -> Bool
$c== :: forall a. Eq a => FamilyOrNot a -> FamilyOrNot a -> Bool
Eq,Int -> FamilyOrNot a -> [Char] -> [Char]
[FamilyOrNot a] -> [Char] -> [Char]
FamilyOrNot a -> [Char]
(Int -> FamilyOrNot a -> [Char] -> [Char])
-> (FamilyOrNot a -> [Char])
-> ([FamilyOrNot a] -> [Char] -> [Char])
-> Show (FamilyOrNot a)
forall a. Show a => Int -> FamilyOrNot a -> [Char] -> [Char]
forall a. Show a => [FamilyOrNot a] -> [Char] -> [Char]
forall a. Show a => FamilyOrNot a -> [Char]
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
showList :: [FamilyOrNot a] -> [Char] -> [Char]
$cshowList :: forall a. Show a => [FamilyOrNot a] -> [Char] -> [Char]
show :: FamilyOrNot a -> [Char]
$cshow :: forall a. Show a => FamilyOrNot a -> [Char]
showsPrec :: Int -> FamilyOrNot a -> [Char] -> [Char]
$cshowsPrec :: forall a. Show a => Int -> FamilyOrNot a -> [Char] -> [Char]
Show,(forall a b. (a -> b) -> FamilyOrNot a -> FamilyOrNot b)
-> (forall a b. a -> FamilyOrNot b -> FamilyOrNot a)
-> Functor FamilyOrNot
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall a b. (a -> b) -> FamilyOrNot a -> FamilyOrNot b
forall (f :: * -> *).
(forall a b. (a -> b) -> f a -> f b)
-> (forall a b. a -> f b -> f a) -> Functor f
<$ :: forall a b. a -> FamilyOrNot b -> FamilyOrNot a
$c<$ :: forall a b. a -> FamilyOrNot b -> FamilyOrNot a
fmap :: forall a b. (a -> b) -> FamilyOrNot a -> FamilyOrNot b
$cfmap :: forall a b. (a -> b) -> FamilyOrNot a -> FamilyOrNot b
Functor,(forall m. Monoid m => FamilyOrNot m -> m)
-> (forall m a. Monoid m => (a -> m) -> FamilyOrNot a -> m)
-> (forall m a. Monoid m => (a -> m) -> FamilyOrNot a -> m)
-> (forall a b. (a -> b -> b) -> b -> FamilyOrNot a -> b)
-> (forall a b. (a -> b -> b) -> b -> FamilyOrNot a -> b)
-> (forall b a. (b -> a -> b) -> b -> FamilyOrNot a -> b)
-> (forall b a. (b -> a -> b) -> b -> FamilyOrNot a -> b)
-> (forall a. (a -> a -> a) -> FamilyOrNot a -> a)
-> (forall a. (a -> a -> a) -> FamilyOrNot a -> a)
-> (forall a. FamilyOrNot a -> [a])
-> (forall a. FamilyOrNot a -> Bool)
-> (forall a. FamilyOrNot a -> Int)
-> (forall a. Eq a => a -> FamilyOrNot a -> Bool)
-> (forall a. Ord a => FamilyOrNot a -> a)
-> (forall a. Ord a => FamilyOrNot a -> a)
-> (forall a. Num a => FamilyOrNot a -> a)
-> (forall a. Num a => FamilyOrNot a -> a)
-> Foldable FamilyOrNot
forall a. Eq a => a -> FamilyOrNot a -> Bool
forall a. Num a => FamilyOrNot a -> a
forall a. Ord a => FamilyOrNot a -> a
forall m. Monoid m => FamilyOrNot m -> m
forall a. FamilyOrNot a -> Bool
forall a. FamilyOrNot a -> Int
forall a. FamilyOrNot a -> [a]
forall a. (a -> a -> a) -> FamilyOrNot a -> a
forall m a. Monoid m => (a -> m) -> FamilyOrNot a -> m
forall b a. (b -> a -> b) -> b -> FamilyOrNot a -> b
forall a b. (a -> b -> b) -> b -> FamilyOrNot a -> b
forall (t :: * -> *).
(forall m. Monoid m => t m -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall m a. Monoid m => (a -> m) -> t a -> m)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall a b. (a -> b -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall b a. (b -> a -> b) -> b -> t a -> b)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. (a -> a -> a) -> t a -> a)
-> (forall a. t a -> [a])
-> (forall a. t a -> Bool)
-> (forall a. t a -> Int)
-> (forall a. Eq a => a -> t a -> Bool)
-> (forall a. Ord a => t a -> a)
-> (forall a. Ord a => t a -> a)
-> (forall a. Num a => t a -> a)
-> (forall a. Num a => t a -> a)
-> Foldable t
product :: forall a. Num a => FamilyOrNot a -> a
$cproduct :: forall a. Num a => FamilyOrNot a -> a
sum :: forall a. Num a => FamilyOrNot a -> a
$csum :: forall a. Num a => FamilyOrNot a -> a
minimum :: forall a. Ord a => FamilyOrNot a -> a
$cminimum :: forall a. Ord a => FamilyOrNot a -> a
maximum :: forall a. Ord a => FamilyOrNot a -> a
$cmaximum :: forall a. Ord a => FamilyOrNot a -> a
elem :: forall a. Eq a => a -> FamilyOrNot a -> Bool
$celem :: forall a. Eq a => a -> FamilyOrNot a -> Bool
length :: forall a. FamilyOrNot a -> Int
$clength :: forall a. FamilyOrNot a -> Int
null :: forall a. FamilyOrNot a -> Bool
$cnull :: forall a. FamilyOrNot a -> Bool
toList :: forall a. FamilyOrNot a -> [a]
$ctoList :: forall a. FamilyOrNot a -> [a]
foldl1 :: forall a. (a -> a -> a) -> FamilyOrNot a -> a
$cfoldl1 :: forall a. (a -> a -> a) -> FamilyOrNot a -> a
foldr1 :: forall a. (a -> a -> a) -> FamilyOrNot a -> a
$cfoldr1 :: forall a. (a -> a -> a) -> FamilyOrNot a -> a
foldl' :: forall b a. (b -> a -> b) -> b -> FamilyOrNot a -> b
$cfoldl' :: forall b a. (b -> a -> b) -> b -> FamilyOrNot a -> b
foldl :: forall b a. (b -> a -> b) -> b -> FamilyOrNot a -> b
$cfoldl :: forall b a. (b -> a -> b) -> b -> FamilyOrNot a -> b
foldr' :: forall a b. (a -> b -> b) -> b -> FamilyOrNot a -> b
$cfoldr' :: forall a b. (a -> b -> b) -> b -> FamilyOrNot a -> b
foldr :: forall a b. (a -> b -> b) -> b -> FamilyOrNot a -> b
$cfoldr :: forall a b. (a -> b -> b) -> b -> FamilyOrNot a -> b
foldMap' :: forall m a. Monoid m => (a -> m) -> FamilyOrNot a -> m
$cfoldMap' :: forall m a. Monoid m => (a -> m) -> FamilyOrNot a -> m
foldMap :: forall m a. Monoid m => (a -> m) -> FamilyOrNot a -> m
$cfoldMap :: forall m a. Monoid m => (a -> m) -> FamilyOrNot a -> m
fold :: forall m. Monoid m => FamilyOrNot m -> m
$cfold :: forall m. Monoid m => FamilyOrNot m -> m
Foldable,Functor FamilyOrNot
Foldable FamilyOrNot
Functor FamilyOrNot
-> Foldable FamilyOrNot
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> FamilyOrNot a -> f (FamilyOrNot b))
-> (forall (f :: * -> *) a.
    Applicative f =>
    FamilyOrNot (f a) -> f (FamilyOrNot a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> FamilyOrNot a -> m (FamilyOrNot b))
-> (forall (m :: * -> *) a.
    Monad m =>
    FamilyOrNot (m a) -> m (FamilyOrNot a))
-> Traversable FamilyOrNot
forall (t :: * -> *).
Functor t
-> Foldable t
-> (forall (f :: * -> *) a b.
    Applicative f =>
    (a -> f b) -> t a -> f (t b))
-> (forall (f :: * -> *) a. Applicative f => t (f a) -> f (t a))
-> (forall (m :: * -> *) a b.
    Monad m =>
    (a -> m b) -> t a -> m (t b))
-> (forall (m :: * -> *) a. Monad m => t (m a) -> m (t a))
-> Traversable t
forall (m :: * -> *) a.
Monad m =>
FamilyOrNot (m a) -> m (FamilyOrNot a)
forall (f :: * -> *) a.
Applicative f =>
FamilyOrNot (f a) -> f (FamilyOrNot a)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FamilyOrNot a -> m (FamilyOrNot b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FamilyOrNot a -> f (FamilyOrNot b)
sequence :: forall (m :: * -> *) a.
Monad m =>
FamilyOrNot (m a) -> m (FamilyOrNot a)
$csequence :: forall (m :: * -> *) a.
Monad m =>
FamilyOrNot (m a) -> m (FamilyOrNot a)
mapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FamilyOrNot a -> m (FamilyOrNot b)
$cmapM :: forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> FamilyOrNot a -> m (FamilyOrNot b)
sequenceA :: forall (f :: * -> *) a.
Applicative f =>
FamilyOrNot (f a) -> f (FamilyOrNot a)
$csequenceA :: forall (f :: * -> *) a.
Applicative f =>
FamilyOrNot (f a) -> f (FamilyOrNot a)
traverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FamilyOrNot a -> f (FamilyOrNot b)
$ctraverse :: forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> FamilyOrNot a -> f (FamilyOrNot b)
Traversable)

instance Reduce a => Reduce (FamilyOrNot a) where
  reduceB' :: FamilyOrNot a -> ReduceM (Blocked (FamilyOrNot a))
reduceB' FamilyOrNot a
x = (Blocked' Term a -> Blocked' Term a)
-> FamilyOrNot (Blocked' Term a) -> Blocked (FamilyOrNot a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Blocked' Term a -> Blocked' Term a
forall a. a -> a
id (FamilyOrNot (Blocked' Term a) -> Blocked (FamilyOrNot a))
-> ReduceM (FamilyOrNot (Blocked' Term a))
-> ReduceM (Blocked (FamilyOrNot a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> ReduceM (Blocked' Term a))
-> FamilyOrNot a -> ReduceM (FamilyOrNot (Blocked' Term a))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> ReduceM (Blocked' Term a)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' FamilyOrNot a
x
  reduce' :: FamilyOrNot a -> ReduceM (FamilyOrNot a)
reduce' FamilyOrNot a
x = (a -> ReduceM a) -> FamilyOrNot a -> ReduceM (FamilyOrNot a)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse a -> ReduceM a
forall t. Reduce t => t -> ReduceM t
reduce' FamilyOrNot a
x


-- | Define a "ghcomp" version of gcomp. Normal comp looks like:
--
-- comp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u ] (forward A 0 u0)
--
-- So for "gcomp" we compute:
--
-- gcomp^i A [ phi -> u ] u0 = hcomp^i A(1/i) [ phi -> forward A i u, ~ phi -> forward A 0 u0 ] (forward A 0 u0)
--
-- The point of this is that gcomp does not produce any empty
-- systems (if phi = 0 it will reduce to "forward A 0 u".
mkGComp :: HasBuiltins m => String -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)
mkGComp :: forall (m :: * -> *).
HasBuiltins m =>
[Char]
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
mkGComp [Char]
s = do
  let getTermLocal :: [Char] -> NamesT m Term
getTermLocal = [Char] -> [Char] -> NamesT m Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
s
  Term
tPOr <- [Char] -> NamesT m Term
getTermLocal [Char]
"primPOr"
  Term
tIMax <- [Char] -> NamesT m Term
getTermLocal [Char]
builtinIMax
  Term
tIMin <- [Char] -> NamesT m Term
getTermLocal [Char]
builtinIMin
  Term
tINeg <- [Char] -> NamesT m Term
getTermLocal [Char]
builtinINeg
  Term
tHComp <- [Char] -> NamesT m Term
getTermLocal [Char]
builtinHComp
  Term
tTrans <- [Char] -> NamesT m Term
getTermLocal [Char]
builtinTrans
  Term
io      <- [Char] -> NamesT m Term
getTermLocal [Char]
builtinIOne
  Term
iz      <- [Char] -> NamesT m Term
getTermLocal [Char]
builtinIZero
  let ineg :: NamesT m Term -> NamesT m Term
ineg NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
      imax :: NamesT m Term -> NamesT m Term -> NamesT m Term
imax NamesT m Term
i NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax 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 forward :: NamesT m Term
-> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
forward NamesT m Term
la NamesT m Term
bA NamesT m Term
r NamesT m Term
u = Term -> NamesT m Term
forall (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
<#> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
`imax` NamesT m Term
r))
                                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
`imax` NamesT m Term
r))
                                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
r
                                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u
  (NamesT m Term
 -> NamesT m Term
 -> NamesT m Term
 -> NamesT m Term
 -> NamesT m Term
 -> NamesT m Term)
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT m Term
  -> NamesT m Term
  -> NamesT m Term
  -> NamesT m Term
  -> NamesT m Term
  -> NamesT m Term)
 -> NamesT
      m
      (NamesT m Term
       -> NamesT m Term
       -> NamesT m Term
       -> NamesT m Term
       -> NamesT m Term
       -> NamesT m Term))
-> (NamesT m Term
    -> NamesT m Term
    -> NamesT m Term
    -> NamesT m Term
    -> NamesT m Term
    -> NamesT m Term)
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u NamesT m Term
u0 ->
    Term -> NamesT m Term
forall (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 (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 (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 -> NamesT m Term -> NamesT m Term
imax NamesT m Term
phi (NamesT m Term -> NamesT m Term
ineg NamesT m Term
phi)
                NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT m Term
i ->
                      Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
i)
                                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 -> NamesT m Term
ineg NamesT m Term
phi
                                NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
a -> 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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ 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 (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT m Term
u0))
                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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT m Term
u0


unglueTranspGlue :: PureTCM m =>
                  Arg Term
                  -> Arg Term
                  -> FamilyOrNot
                       (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
                  -> m Term
-- ...    |- psi, u0
-- ..., i |- la, lb, bA, phi, bT, e
unglueTranspGlue :: forall (m :: * -> *).
PureTCM m =>
Arg Term
-> Arg Term
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> m Term
unglueTranspGlue Arg Term
psi Arg Term
u0 (IsFam (Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi, Arg Term
bT, Arg Term
e)) = do
      let
        localUse :: [Char]
localUse = [Char]
builtinTrans [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
builtinGlue
        getTermLocal :: [Char] -> m Term
getTermLocal = [Char] -> [Char] -> m Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
localUse
      Term
tPOr <- [Char] -> m Term
getTermLocal [Char]
"primPOr"
      Term
tIMax <- [Char] -> m Term
getTermLocal [Char]
builtinIMax
      Term
tIMin <- [Char] -> m Term
getTermLocal [Char]
builtinIMin
      Term
tINeg <- [Char] -> m Term
getTermLocal [Char]
builtinINeg
      Term
tHComp <- [Char] -> m Term
getTermLocal [Char]
builtinHComp
      Term
tTrans <- [Char] -> m Term
getTermLocal [Char]
builtinTrans
      Term
tForall  <- [Char] -> m Term
getTermLocal [Char]
builtinFaceForall
      Term
tEFun  <- [Char] -> m Term
getTermLocal [Char]
builtinEquivFun
      Term
tEProof <- [Char] -> m Term
getTermLocal [Char]
builtinEquivProof
      Term
tglue   <- [Char] -> m Term
getTermLocal [Char]
builtin_glue
      Term
tunglue <- [Char] -> m Term
getTermLocal [Char]
builtin_unglue
      Term
io      <- [Char] -> m Term
getTermLocal [Char]
builtinIOne
      Term
iz      <- [Char] -> m Term
getTermLocal [Char]
builtinIZero
      Term
tLMax   <- [Char] -> m Term
getTermLocal [Char]
builtinLevelMax
      Term
tPath   <- [Char] -> m Term
getTermLocal [Char]
builtinPath
      Term
tTransp <- [Char] -> m Term
getTermLocal [Char]
builtinTranspProof
      Term
tItIsOne <- [Char] -> m Term
getTermLocal [Char]
builtinItIsOne
      SigmaKit
kit <- SigmaKit -> Maybe SigmaKit -> SigmaKit
forall a. a -> Maybe a -> a
fromMaybe SigmaKit
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe SigmaKit -> SigmaKit) -> m (Maybe SigmaKit) -> m SigmaKit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe SigmaKit)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m) =>
m (Maybe SigmaKit)
getSigmaKit
      Names -> NamesT m Term -> m Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT m Term -> m Term) -> NamesT m Term -> m Term
forall a b. (a -> b) -> a -> b
$ do
        let ineg :: NamesT m Term -> NamesT m Term
ineg NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
            imax :: NamesT m Term -> NamesT m Term -> NamesT m Term
imax NamesT m Term
i NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax 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
            imin :: NamesT m Term -> NamesT m Term -> NamesT m Term
imin NamesT m Term
i NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin 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

        NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
gcomp <- [Char]
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
forall (m :: * -> *).
HasBuiltins m =>
[Char]
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
mkGComp [Char]
localUse

        let transpFill :: NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpFill NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u0 NamesT m Term
i =
              Term -> NamesT m Term
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
<#> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"j" (\ NamesT m Term
j -> 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 -> NamesT m Term -> NamesT m Term
imin NamesT m Term
i NamesT m Term
j)
                          NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"j" (\ NamesT m Term
j -> 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 -> NamesT m Term -> NamesT m Term
imin NamesT m Term
i NamesT m Term
j)
                          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
imax NamesT m Term
phi (NamesT m Term -> NamesT m Term
ineg 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
u0
        [NamesT m Term
psi,NamesT m Term
u0] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
psi,Arg Term
u0]

        -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a
        NamesT m Term -> NamesT m Term -> NamesT m Term
glue1 <- do
          NamesT m Term
g <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ (Term
tglue Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply`) (Args -> Term) -> (Args -> Args) -> Args -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Arg Term -> Arg Term) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map ((Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) (Arg Term -> Arg Term)
-> (Arg Term -> Arg Term) -> Arg Term -> Arg Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> SubstArg (Arg Term) -> Arg Term -> Arg Term
forall a. Subst a => Int -> SubstArg a -> a -> a
subst Int
0 Term
SubstArg (Arg Term)
io)) (Args -> Term) -> Args -> Term
forall a b. (a -> b) -> a -> b
$ [Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi, Arg Term
bT, Arg Term
e]
          (NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT m Term -> NamesT m Term -> NamesT m Term)
 -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term))
-> (NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
t NamesT m Term
a -> NamesT m Term
g NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
t NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a

        [NamesT m Term
la, NamesT m Term
lb, NamesT m Term
bA, NamesT m Term
phi, NamesT m Term
bT, NamesT m Term
e] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (NamesT Fail Term -> Term)
-> NamesT Fail Term
-> NamesT m (NamesT m 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 m (NamesT m Term))
-> NamesT Fail Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT Fail Term) -> Term -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a))) [Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi, Arg Term
bT, Arg Term
e]

        -- Andreas, 2022-03-24, fixing #5838
        -- Following the updated note
        --
        --   Simon Huber, A Cubical Type Theory for Higher Inductive Types
        --   https://simhu.github.io/misc/hcomp.pdf (February 2022)
        --
        -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776

        -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/i] u0
        let unglue_u0 :: NamesT m Term -> NamesT m Term
unglue_u0 NamesT m Term
i =
              (NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m Term -> [NamesT m Term] -> NamesT m Term
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
(<#>) (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue) ((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 (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i) [NamesT m Term
la, NamesT m Term
lb, NamesT m Term
bA, NamesT m Term
phi, NamesT m Term
bT, NamesT m Term
e]) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0

        Term -> IntervalView
view <- NamesT m (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'

        let
          tf :: NamesT m Term -> NamesT m Term -> NamesT m Term
tf NamesT m Term
i NamesT m Term
o = NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpFill NamesT m Term
lb ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> NamesT m Term
bT 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
psi NamesT m Term
u0 NamesT m Term
i
          t1 :: NamesT m Term -> NamesT m Term
t1 NamesT m Term
o = NamesT m Term -> NamesT m Term -> NamesT m Term
tf (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o

          -- compute "forall. phi"
          forallphi :: NamesT m Term
forallphi = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tForall NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi

          -- a1 with gcomp
          a1 :: NamesT m Term
a1 = NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
gcomp NamesT m Term
la NamesT m Term
bA
                 (NamesT m Term -> NamesT m Term -> NamesT m Term
imax NamesT m Term
psi NamesT m Term
forallphi)
                 ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
i)
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
a -> 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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ -> NamesT m Term -> NamesT m Term
unglue_u0 NamesT m Term
i)
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb 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
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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT 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
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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e 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
tf NamesT m Term
i NamesT m Term
o)))
                 (NamesT m Term -> NamesT m Term
unglue_u0 (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz))

          max :: NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
l NamesT m Term
l' = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLMax NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
l NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
l'
          sigCon :: NamesT m Term -> NamesT m Term -> NamesT m Term
sigCon NamesT m Term
x NamesT m Term
y = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConHead -> ConInfo -> [Elim] -> Term
Con (SigmaKit -> ConHead
sigmaCon SigmaKit
kit) ConInfo
ConOSystem []) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
x NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
y
          w :: NamesT m Term -> NamesT m Term -> NamesT m Term
w NamesT m Term
i NamesT m Term
o = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb 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
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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT 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
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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e 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)
          fiber :: NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
fiber NamesT m Term
la NamesT m Term
lb NamesT m Term
bA NamesT m Term
bB NamesT m Term
f NamesT m Term
b =
            (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QName -> [Elim] -> Term
Def (SigmaKit -> QName
sigmaName SigmaKit
kit) []) 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
lb
                                           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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"a" (\ NamesT m Term
a -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPath NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
lb NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bB NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
f NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
b))

          -- We don't have to do anything special for "~ forall. phi"
          -- here (to implement "ghcomp") as it is taken care off by
          -- tEProof in t1'alpha below
          pe :: NamesT m Term -> NamesT m Term
pe NamesT m Term
o = -- o : [ φ 1 ]
            Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
max (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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) (NamesT m Term
lb NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
psi
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ ->
                             NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
fiber (NamesT m Term
lb NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) (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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
                                   (NamesT m Term
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT m Term
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
o) (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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
                                   (NamesT m Term -> NamesT m Term -> NamesT m Term
w (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o) NamesT m Term
a1)
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term -> NamesT m Term
sigCon NamesT m Term
u0 ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" ((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
a1))
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term -> NamesT m Term
sigCon (NamesT m Term -> NamesT m Term
t1 NamesT m Term
o) ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" ((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
a1))

          -- "ghcomp" is implemented in the proof of tEProof
          -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)
          t1'alpha :: NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o = -- o : [ φ 1 ]
             Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEProof NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
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 (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
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
o)
                          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 (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
e NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
o)
                          NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1
                          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
imax NamesT m Term
psi NamesT m Term
forallphi)
                          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
pe NamesT m Term
o

          -- TODO: optimize?
          t1' :: NamesT m Term -> NamesT m Term
t1' NamesT m Term
o = NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o NamesT m Term -> (Term -> Term) -> NamesT m Term
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [ProjOrigin -> QName -> Elim
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (SigmaKit -> QName
sigmaFst SigmaKit
kit)])
          alpha :: NamesT m Term -> NamesT m Term
alpha NamesT m Term
o = NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o NamesT m Term -> (Term -> Term) -> NamesT m Term
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [ProjOrigin -> QName -> Elim
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (SigmaKit -> QName
sigmaSnd SigmaKit
kit)])
          a1' :: NamesT m Term
a1' = Term -> NamesT m Term
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 (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 (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 -> NamesT m Term -> NamesT m Term
imax (NamesT m Term
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
psi)
                  NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j ->
                         Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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 (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
<@> Term -> NamesT m Term
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
psi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT 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 (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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term
alpha NamesT m Term
o 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 -> NamesT m Term -> NamesT m Term
w (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) 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
t1' NamesT m Term
o,NamesT m Term
a1,NamesT m Term
j))
                                   NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ -> NamesT m Term
a1))
                  NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1
        -- glue1 (ilam "o" t1') a1'
        NamesT m Term
a1'
unglueTranspGlue Arg Term
_ Arg Term
_ FamilyOrNot
  (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
_ = m Term
forall a. HasCallStack => a
__IMPOSSIBLE__

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

headStop :: PureTCM m => TermPosition -> m Term -> m Bool
headStop :: forall (m :: * -> *). PureTCM m => TermPosition -> m Term -> m Bool
headStop TermPosition
tpos m Term
phi
  | TermPosition
Head <- TermPosition
tpos = do
      IntervalView
phi <- Term -> m IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> m IntervalView) -> m Term -> m IntervalView
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Term -> m Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Term -> m Term) -> m Term -> m Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Term
phi)
      Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> m Bool) -> Bool -> m Bool
forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ IntervalView -> Bool
isIOne IntervalView
phi
  | Bool
otherwise = Bool -> m Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

compGlue :: PureTCM m =>
                  TranspOrHComp
                  -> Arg Term
                  -> Maybe (Arg Term)
                  -> Arg Term
                  -> FamilyOrNot
                       (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
                  -> TermPosition
                  -> m (Maybe Term)
compGlue :: forall (m :: * -> *).
PureTCM m =>
TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
compGlue TranspOrHComp
DoHComp Arg Term
psi (Just Arg Term
u) Arg Term
u0 (IsNot (Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi, Arg Term
bT, Arg Term
e)) TermPosition
tpos = do
      let getTermLocal :: [Char] -> m Term
getTermLocal = [Char] -> [Char] -> m Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm ([Char] -> [Char] -> m Term) -> [Char] -> [Char] -> m Term
forall a b. (a -> b) -> a -> b
$ ([Char]
builtinHComp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
builtinGlue)
      Term
tPOr <- [Char] -> m Term
getTermLocal [Char]
"primPOr"
      Term
tIMax <- [Char] -> m Term
getTermLocal [Char]
builtinIMax
      Term
tIMin <- [Char] -> m Term
getTermLocal [Char]
builtinIMin
      Term
tINeg <- [Char] -> m Term
getTermLocal [Char]
builtinINeg
      Term
tHComp <- [Char] -> m Term
getTermLocal [Char]
builtinHComp
      Term
tEFun  <- [Char] -> m Term
getTermLocal [Char]
builtinEquivFun
      Term
tglue   <- [Char] -> m Term
getTermLocal [Char]
builtin_glue
      Term
tunglue <- [Char] -> m Term
getTermLocal [Char]
builtin_unglue
      Term
io      <- [Char] -> m Term
getTermLocal [Char]
builtinIOne
      Term
tItIsOne <- [Char] -> m Term
getTermLocal [Char]
builtinItIsOne
      Term -> IntervalView
view <- m (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
      Names -> NamesT m (Maybe Term) -> m (Maybe Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT m (Maybe Term) -> m (Maybe Term))
-> NamesT m (Maybe Term) -> m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ do
        [NamesT m Term
psi, NamesT m Term
u, NamesT m Term
u0] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
psi, Arg Term
u, Arg Term
u0]
        [NamesT m Term
la, NamesT m Term
lb, NamesT m Term
bA, NamesT m Term
phi, NamesT m Term
bT, NamesT m Term
e] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi, Arg Term
bT, Arg Term
e]
        NamesT m Bool
-> NamesT m (Maybe Term)
-> NamesT m (Maybe Term)
-> NamesT m (Maybe Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TermPosition -> NamesT m Term -> NamesT m Bool
forall (m :: * -> *). PureTCM m => TermPosition -> m Term -> m Bool
headStop TermPosition
tpos NamesT m Term
phi) (Maybe Term -> NamesT m (Maybe Term)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) (NamesT m (Maybe Term) -> NamesT m (Maybe Term))
-> NamesT m (Maybe Term) -> NamesT m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> NamesT m Term -> NamesT m (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do

        let
          hfill :: NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
hfill NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u NamesT m Term
u0 NamesT m Term
i = Term -> NamesT m Term
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
<#> 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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax 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
<@> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
a -> NamesT m Term
bA)
                                                     NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term
u NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin 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) 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ -> NamesT m Term
u0))
                                               NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
          tf :: NamesT m Term -> NamesT m Term -> NamesT m Term
tf NamesT m Term
i NamesT m Term
o = NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
hfill NamesT m Term
lb (NamesT m Term
bT 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
psi NamesT m Term
u NamesT m Term
u0 NamesT m Term
i
          unglue :: NamesT m Term -> NamesT m Term
unglue NamesT m Term
g = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue 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
lb 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
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
e NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
g
          a1 :: NamesT m Term
a1 = Term -> NamesT m Term
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
<#> 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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT m Term
i -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
psi 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (\ NamesT 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term
unglue (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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
lb 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
bT 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
bA NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e 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
tf NamesT m Term
i 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
unglue NamesT m Term
u0)
          t1 :: NamesT m Term -> NamesT m Term
t1 = NamesT m Term -> NamesT m Term -> NamesT m Term
tf (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
        -- pure tglue <#> la <#> lb <#> bA <#> phi <#> bT <#> e <@> (ilam "o" $ \ o -> t1 o) <@> a1
        case TermPosition
tpos of
          TermPosition
Head -> NamesT m Term -> NamesT m Term
t1 (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tItIsOne)
          TermPosition
Eliminated -> NamesT m Term
a1

-- ...    |- psi, u0
-- ..., i |- la, lb, bA, phi, bT, e
compGlue TranspOrHComp
DoTransp Arg Term
psi Maybe (Arg Term)
Nothing Arg Term
u0 (IsFam (Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi, Arg Term
bT, Arg Term
e)) TermPosition
tpos = do
      let
        localUse :: [Char]
localUse = [Char]
builtinTrans [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
builtinGlue
        getTermLocal :: [Char] -> m Term
getTermLocal = [Char] -> [Char] -> m Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
localUse
      Term
tPOr <- [Char] -> m Term
getTermLocal [Char]
"primPOr"
      Term
tIMax <- [Char] -> m Term
getTermLocal [Char]
builtinIMax
      Term
tIMin <- [Char] -> m Term
getTermLocal [Char]
builtinIMin
      Term
tINeg <- [Char] -> m Term
getTermLocal [Char]
builtinINeg
      Term
tHComp <- [Char] -> m Term
getTermLocal [Char]
builtinHComp
      Term
tTrans <- [Char] -> m Term
getTermLocal [Char]
builtinTrans
      Term
tForall  <- [Char] -> m Term
getTermLocal [Char]
builtinFaceForall
      Term
tEFun  <- [Char] -> m Term
getTermLocal [Char]
builtinEquivFun
      Term
tEProof <- [Char] -> m Term
getTermLocal [Char]
builtinEquivProof
      Term
tglue   <- [Char] -> m Term
getTermLocal [Char]
builtin_glue
      Term
tunglue <- [Char] -> m Term
getTermLocal [Char]
builtin_unglue
      Term
io      <- [Char] -> m Term
getTermLocal [Char]
builtinIOne
      Term
iz      <- [Char] -> m Term
getTermLocal [Char]
builtinIZero
      Term
tLMax   <- [Char] -> m Term
getTermLocal [Char]
builtinLevelMax
      Term
tPath   <- [Char] -> m Term
getTermLocal [Char]
builtinPath
      Term
tTransp <- [Char] -> m Term
getTermLocal [Char]
builtinTranspProof
      Term
tItIsOne <- [Char] -> m Term
getTermLocal [Char]
builtinItIsOne
      SigmaKit
kit <- SigmaKit -> Maybe SigmaKit -> SigmaKit
forall a. a -> Maybe a -> a
fromMaybe SigmaKit
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe SigmaKit -> SigmaKit) -> m (Maybe SigmaKit) -> m SigmaKit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe SigmaKit)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m) =>
m (Maybe SigmaKit)
getSigmaKit
      Names -> NamesT m (Maybe Term) -> m (Maybe Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT m (Maybe Term) -> m (Maybe Term))
-> NamesT m (Maybe Term) -> m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ do
        let ineg :: NamesT m Term -> NamesT m Term
ineg NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
            imax :: NamesT m Term -> NamesT m Term -> NamesT m Term
imax NamesT m Term
i NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax 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
            imin :: NamesT m Term -> NamesT m Term -> NamesT m Term
imin NamesT m Term
i NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin 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

        NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
gcomp <- [Char]
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
forall (m :: * -> *).
HasBuiltins m =>
[Char]
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
mkGComp [Char]
localUse

        let transpFill :: NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpFill NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u0 NamesT m Term
i =
              Term -> NamesT m Term
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
<#> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"j" (\ NamesT m Term
j -> 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 -> NamesT m Term -> NamesT m Term
imin NamesT m Term
i NamesT m Term
j)
                          NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"j" (\ NamesT m Term
j -> 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 -> NamesT m Term -> NamesT m Term
imin NamesT m Term
i NamesT m Term
j)
                          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
imax NamesT m Term
phi (NamesT m Term -> NamesT m Term
ineg 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
u0
        [NamesT m Term
psi,NamesT m Term
u0] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
psi,Arg Term
u0]

        -- glue1 t a = glue la[i1/i] lb[i1/i] bA[i1/i] phi[i1/i] bT[i1/i] e[i1/i] t a
        NamesT m Term -> NamesT m Term -> NamesT m Term
glue1 <- do
          NamesT m Term
g <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ (Term
tglue Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply`) (Args -> Term) -> (Args -> Args) -> Args -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Arg Term -> Arg Term) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map ((Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) (Arg Term -> Arg Term)
-> (Arg Term -> Arg Term) -> Arg Term -> Arg Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int -> SubstArg (Arg Term) -> Arg Term -> Arg Term
forall a. Subst a => Int -> SubstArg a -> a -> a
subst Int
0 Term
SubstArg (Arg Term)
io)) (Args -> Term) -> Args -> Term
forall a b. (a -> b) -> a -> b
$ [Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi, Arg Term
bT, Arg Term
e]
          (NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT m Term -> NamesT m Term -> NamesT m Term)
 -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term))
-> (NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
t NamesT m Term
a -> NamesT m Term
g NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
t NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a

        [NamesT m Term
la, NamesT m Term
lb, NamesT m Term
bA, NamesT m Term
phi, NamesT m Term
bT, NamesT m Term
e] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (NamesT Fail Term -> Term)
-> NamesT Fail Term
-> NamesT m (NamesT m 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 m (NamesT m Term))
-> NamesT Fail Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT Fail Term) -> Term -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a))) [Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi, Arg Term
bT, Arg Term
e]

        -- Andreas, 2022-03-24, fixing #5838
        -- Following the updated note
        --
        --   Simon Huber, A Cubical Type Theory for Higher Inductive Types
        --   https://simhu.github.io/misc/hcomp.pdf (February 2022)
        --
        -- See: https://github.com/agda/agda/issues/5755#issuecomment-1043797776

        -- unglue_u0 i = unglue la[i/i] lb[i/i] bA[i/i] phi[i/i] bT[i/i] e[i/e] u0
        let unglue_u0 :: NamesT m Term -> NamesT m Term
unglue_u0 NamesT m Term
i =
              (NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m Term -> [NamesT m Term] -> NamesT m Term
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
(<#>) (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue) ((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 (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i) [NamesT m Term
la, NamesT m Term
lb, NamesT m Term
bA, NamesT m Term
phi, NamesT m Term
bT, NamesT m Term
e]) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0

        Term -> IntervalView
view <- NamesT m (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'

        NamesT m Bool
-> NamesT m (Maybe Term)
-> NamesT m (Maybe Term)
-> NamesT m (Maybe Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TermPosition -> NamesT m Term -> NamesT m Bool
forall (m :: * -> *). PureTCM m => TermPosition -> m Term -> m Bool
headStop TermPosition
tpos (NamesT m Term
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)) (Maybe Term -> NamesT m (Maybe Term)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) (NamesT m (Maybe Term) -> NamesT m (Maybe Term))
-> NamesT m (Maybe Term) -> NamesT m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> NamesT m Term -> NamesT m (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
        let
          tf :: NamesT m Term -> NamesT m Term -> NamesT m Term
tf NamesT m Term
i NamesT m Term
o = NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpFill NamesT m Term
lb ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> NamesT m Term
bT 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
psi NamesT m Term
u0 NamesT m Term
i
          t1 :: NamesT m Term -> NamesT m Term
t1 NamesT m Term
o = NamesT m Term -> NamesT m Term -> NamesT m Term
tf (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o

          -- compute "forall. phi"
          forallphi :: NamesT m Term
forallphi = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tForall NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi

          -- a1 with gcomp
          a1 :: NamesT m Term
a1 = NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
gcomp NamesT m Term
la NamesT m Term
bA
                 (NamesT m Term -> NamesT m Term -> NamesT m Term
imax NamesT m Term
psi NamesT m Term
forallphi)
                 ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
i)
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT 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
i)
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ -> NamesT m Term -> NamesT m Term
unglue_u0 NamesT m Term
i)
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb 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
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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT 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
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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e 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
tf NamesT m Term
i NamesT m Term
o)))
                 (NamesT m Term -> NamesT m Term
unglue_u0 (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz))

          max :: NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
l NamesT m Term
l' = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLMax NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
l NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
l'
          sigCon :: NamesT m Term -> NamesT m Term -> NamesT m Term
sigCon NamesT m Term
x NamesT m Term
y = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConHead -> ConInfo -> [Elim] -> Term
Con (SigmaKit -> ConHead
sigmaCon SigmaKit
kit) ConInfo
ConOSystem []) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
x NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
y
          w :: NamesT m Term -> NamesT m Term -> NamesT m Term
w NamesT m Term
i NamesT m Term
o = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb 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
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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT 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
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 :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e 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)
          fiber :: NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
fiber NamesT m Term
la NamesT m Term
lb NamesT m Term
bA NamesT m Term
bB NamesT m Term
f NamesT m Term
b =
            (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QName -> [Elim] -> Term
Def (SigmaKit -> QName
sigmaName SigmaKit
kit) []) 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
lb
                                           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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"a" (\ NamesT m Term
a -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPath NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
lb NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bB NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
f NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
b))

          -- We don't have to do anything special for "~ forall. phi"
          -- here (to implement "ghcomp") as it is taken care off by
          -- tEProof in t1'alpha below
          pe :: NamesT m Term -> NamesT m Term
pe NamesT m Term
o = -- o : [ φ 1 ]
            Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
max (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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) (NamesT m Term
lb NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
psi
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ ->
                             NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
fiber (NamesT m Term
lb NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) (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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
                                   (NamesT m Term
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT m Term
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
o) (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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
                                   (NamesT m Term -> NamesT m Term -> NamesT m Term
w (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o) NamesT m Term
a1)
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term -> NamesT m Term
sigCon NamesT m Term
u0 ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" ((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
a1))
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term -> NamesT m Term
sigCon (NamesT m Term -> NamesT m Term
t1 NamesT m Term
o) ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" ((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
a1))

          -- "ghcomp" is implemented in the proof of tEProof
          -- (see src/data/lib/prim/Agda/Builtin/Cubical/Glue.agda)
          t1'alpha :: NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o = -- o : [ φ 1 ]
             Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEProof NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
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 (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
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
o)
                          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 (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
e NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
o)
                          NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1
                          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
imax NamesT m Term
psi NamesT m Term
forallphi)
                          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
pe NamesT m Term
o

          -- TODO: optimize?
          t1' :: NamesT m Term -> NamesT m Term
t1' NamesT m Term
o = NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o NamesT m Term -> (Term -> Term) -> NamesT m Term
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [ProjOrigin -> QName -> Elim
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (SigmaKit -> QName
sigmaFst SigmaKit
kit)])
          alpha :: NamesT m Term -> NamesT m Term
alpha NamesT m Term
o = NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o NamesT m Term -> (Term -> Term) -> NamesT m Term
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [ProjOrigin -> QName -> Elim
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (SigmaKit -> QName
sigmaSnd SigmaKit
kit)])
          a1' :: NamesT m Term
a1' = Term -> NamesT m Term
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 (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 (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 -> NamesT m Term -> NamesT m Term
imax (NamesT m Term
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
psi)
                  NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j ->
                         Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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 (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
<@> Term -> NamesT m Term
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
psi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT 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 (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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term
alpha NamesT m Term
o 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 -> NamesT m Term -> NamesT m Term
w (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) 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
t1' NamesT m Term
o,NamesT m Term
a1,NamesT m Term
j))
                                   NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ -> NamesT m Term
a1))
                  NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1

        -- glue1 (ilam "o" t1') a1'
        case TermPosition
tpos of
          TermPosition
Head -> NamesT m Term -> NamesT m Term
t1' (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tItIsOne)
          TermPosition
Eliminated -> NamesT m Term
a1'
compGlue TranspOrHComp
cmd Arg Term
phi Maybe (Arg Term)
u Arg Term
u0 FamilyOrNot
  (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
_ TermPosition
_ = m (Maybe Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

compHCompU :: PureTCM m =>
                    TranspOrHComp
                    -> Arg Term
                    -> Maybe (Arg Term)
                    -> Arg Term
                    -> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
                    -> TermPosition
                    -> m (Maybe Term)

compHCompU :: forall (m :: * -> *).
PureTCM m =>
TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
compHCompU TranspOrHComp
DoHComp Arg Term
psi (Just Arg Term
u) Arg Term
u0 (IsNot (Arg Term
la, Arg Term
phi, Arg Term
bT, Arg Term
bA)) TermPosition
tpos = do
      let getTermLocal :: [Char] -> m Term
getTermLocal = [Char] -> [Char] -> m Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm ([Char] -> [Char] -> m Term) -> [Char] -> [Char] -> m Term
forall a b. (a -> b) -> a -> b
$ ([Char]
builtinHComp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
builtinHComp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of Set")
      Term
io      <- [Char] -> m Term
getTermLocal [Char]
builtinIOne
      Term
iz      <- [Char] -> m Term
getTermLocal [Char]
builtinIZero
      Term
tPOr <- [Char] -> m Term
getTermLocal [Char]
"primPOr"
      Term
tIMax <- [Char] -> m Term
getTermLocal [Char]
builtinIMax
      Term
tIMin <- [Char] -> m Term
getTermLocal [Char]
builtinIMin
      Term
tINeg <- [Char] -> m Term
getTermLocal [Char]
builtinINeg
      Term
tHComp <- [Char] -> m Term
getTermLocal [Char]
builtinHComp
      Term
tTransp  <- [Char] -> m Term
getTermLocal [Char]
builtinTrans
      Term
tglue   <- [Char] -> m Term
getTermLocal [Char]
builtin_glueU
      Term
tunglue <- [Char] -> m Term
getTermLocal [Char]
builtin_unglueU
      Term
tLSuc   <- [Char] -> m Term
getTermLocal [Char]
builtinLevelSuc
      Term
tSubIn <- [Char] -> m Term
getTermLocal [Char]
builtinSubIn
      Term
tItIsOne <- [Char] -> m Term
getTermLocal [Char]
builtinItIsOne
      Names -> NamesT m (Maybe Term) -> m (Maybe Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT m (Maybe Term) -> m (Maybe Term))
-> NamesT m (Maybe Term) -> m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ do
        [NamesT m Term
psi, NamesT m Term
u, NamesT m Term
u0] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
psi, Arg Term
u, Arg Term
u0]
        [NamesT m Term
la, NamesT m Term
phi, NamesT m Term
bT, NamesT m Term
bA] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
la, Arg Term
phi, Arg Term
bT, Arg Term
bA]

        NamesT m Bool
-> NamesT m (Maybe Term)
-> NamesT m (Maybe Term)
-> NamesT m (Maybe Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TermPosition -> NamesT m Term -> NamesT m Bool
forall (m :: * -> *). PureTCM m => TermPosition -> m Term -> m Bool
headStop TermPosition
tpos NamesT m Term
phi) (Maybe Term -> NamesT m (Maybe Term)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) (NamesT m (Maybe Term) -> NamesT m (Maybe Term))
-> NamesT m (Maybe Term) -> NamesT m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> NamesT m Term -> NamesT m (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do

        let
          hfill :: NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
hfill NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u NamesT m Term
u0 NamesT m Term
i = Term -> NamesT m Term
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
<#> 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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax 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
<@> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
a -> NamesT m Term
bA)
                                                     NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term
u NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin 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) 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ -> NamesT m Term
u0))
                                               NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
          transp :: NamesT m Term
-> (NamesT m Term -> NamesT m Term)
-> NamesT m Term
-> NamesT m Term
transp NamesT m Term
la NamesT m Term -> NamesT m Term
bA NamesT m Term
a0 = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (NamesT m Term -> NamesT m Term -> NamesT m Term
forall a b. a -> b -> a
const NamesT m Term
la) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" NamesT 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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a0
          tf :: NamesT m Term -> NamesT m Term -> NamesT m Term
tf NamesT m Term
i NamesT m Term
o = NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
hfill NamesT m Term
la (NamesT m Term
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
o) NamesT m Term
psi NamesT m Term
u NamesT m Term
u0 NamesT m Term
i
          bAS :: NamesT m Term
bAS = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tSubIn NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLSuc 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
<#> (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 m Term -> NamesT m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
bA
          unglue :: NamesT m Term -> NamesT m Term
unglue NamesT m Term
g = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue 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
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bAS NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
g
          a1 :: NamesT m Term
a1 = Term -> NamesT m Term
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
<#> 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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT m Term
i -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
psi 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (\ NamesT 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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term
unglue (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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term
-> (NamesT m Term -> NamesT m Term)
-> NamesT m Term
-> NamesT m Term
transp NamesT m Term
la (\ NamesT m Term
i -> NamesT m Term
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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
tf NamesT m Term
i 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
unglue NamesT m Term
u0
          t1 :: NamesT m Term -> NamesT m Term
t1 = NamesT m Term -> NamesT m Term -> NamesT m Term
tf (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)

        -- pure tglue <#> la <#> phi <#> bT <#> bAS <@> (ilam "o" $ \ o -> t1 o) <@> a1
        case TermPosition
tpos of
          TermPosition
Eliminated -> NamesT m Term
a1
          TermPosition
Head       -> NamesT m Term -> NamesT m Term
t1 (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tItIsOne)



compHCompU TranspOrHComp
DoTransp Arg Term
psi Maybe (Arg Term)
Nothing Arg Term
u0 (IsFam (Arg Term
la, Arg Term
phi, Arg Term
bT, Arg Term
bA)) TermPosition
tpos = do
      let
        localUse :: [Char]
localUse = [Char]
builtinTrans [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
builtinHComp [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" of Set"
        getTermLocal :: [Char] -> m Term
getTermLocal = [Char] -> [Char] -> m Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
localUse
      Term
tPOr <- [Char] -> m Term
getTermLocal [Char]
"primPOr"
      Term
tIMax <- [Char] -> m Term
getTermLocal [Char]
builtinIMax
      Term
tIMin <- [Char] -> m Term
getTermLocal [Char]
builtinIMin
      Term
tINeg <- [Char] -> m Term
getTermLocal [Char]
builtinINeg
      Term
tHComp <- [Char] -> m Term
getTermLocal [Char]
builtinHComp
      Term
tTrans <- [Char] -> m Term
getTermLocal [Char]
builtinTrans
      Term
tTranspProof <- [Char] -> m Term
getTermLocal [Char]
builtinTranspProof
      Term
tSubIn <- [Char] -> m Term
getTermLocal [Char]
builtinSubIn
      Term
tForall  <- [Char] -> m Term
getTermLocal [Char]
builtinFaceForall
      Term
io      <- [Char] -> m Term
getTermLocal [Char]
builtinIOne
      Term
iz      <- [Char] -> m Term
getTermLocal [Char]
builtinIZero
      Term
tLSuc   <- [Char] -> m Term
getTermLocal [Char]
builtinLevelSuc
      Term
tPath   <- [Char] -> m Term
getTermLocal [Char]
builtinPath
      Term
tItIsOne   <- [Char] -> m Term
getTermLocal [Char]
builtinItIsOne
      SigmaKit
kit <- SigmaKit -> Maybe SigmaKit -> SigmaKit
forall a. a -> Maybe a -> a
fromMaybe SigmaKit
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe SigmaKit -> SigmaKit) -> m (Maybe SigmaKit) -> m SigmaKit
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Maybe SigmaKit)
forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m) =>
m (Maybe SigmaKit)
getSigmaKit
      Names -> NamesT m (Maybe Term) -> m (Maybe Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT m (Maybe Term) -> m (Maybe Term))
-> NamesT m (Maybe Term) -> m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ do
        let ineg :: NamesT m Term -> NamesT m Term
ineg NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
            imax :: NamesT m Term -> NamesT m Term -> NamesT m Term
imax NamesT m Term
i NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax 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
            imin :: NamesT m Term -> NamesT m Term -> NamesT m Term
imin NamesT m Term
i NamesT m Term
j = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin 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
            transp :: NamesT m Term
-> (NamesT m Term -> NamesT m Term)
-> NamesT m Term
-> NamesT m Term
transp NamesT m Term
la NamesT m Term -> NamesT m Term
bA NamesT m Term
a0 = Term -> NamesT m Term
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
<#> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (NamesT m Term -> NamesT m Term -> NamesT m Term
forall a b. a -> b -> a
const NamesT m Term
la) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" NamesT 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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a0

        NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
gcomp <- [Char]
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
forall (m :: * -> *).
HasBuiltins m =>
[Char]
-> NamesT
     m
     (NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term
      -> NamesT m Term)
mkGComp [Char]
localUse

        let transpFill :: NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpFill NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u0 NamesT m Term
i =
              Term -> NamesT m Term
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
<#> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"j" (\ NamesT m Term
j -> 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 -> NamesT m Term -> NamesT m Term
imin NamesT m Term
i NamesT m Term
j)
                          NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"j" (\ NamesT m Term
j -> 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 -> NamesT m Term -> NamesT m Term
imin NamesT m Term
i NamesT m Term
j)
                          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
imax NamesT m Term
phi (NamesT m Term -> NamesT m Term
ineg 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
u0
        [NamesT m Term
psi,NamesT m Term
u0] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
psi,Arg Term
u0]
        NamesT m Term -> NamesT m Term -> NamesT m Term
glue1 <- do
          Term
tglue   <- m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl (m Term -> NamesT m Term) -> m Term -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ [Char] -> m Term
getTermLocal [Char]
builtin_glueU
          [NamesT m Term
la, NamesT m Term
phi, NamesT m Term
bT, NamesT m Term
bA] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> (Arg Term -> Arg Term) -> Arg Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> SubstArg (Arg Term) -> Arg Term -> Arg Term
forall a. Subst a => Int -> SubstArg a -> a -> a
subst Int
0 Term
SubstArg (Arg Term)
io) (Args -> NamesT m [NamesT m Term])
-> Args -> NamesT m [NamesT m Term]
forall a b. (a -> b) -> a -> b
$ [Arg Term
la, Arg Term
phi, Arg Term
bT, Arg Term
bA]
          let bAS :: NamesT m Term
bAS = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tSubIn NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLSuc 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
<#> (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 m Term -> NamesT m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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
phi 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
g <- (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> NamesT m Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT m Term -> NamesT m (NamesT m Term))
-> NamesT m Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tglue 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
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bAS
          (NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT m Term -> NamesT m Term -> NamesT m Term)
 -> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term))
-> (NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
t NamesT m Term
a -> NamesT m Term
g NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
t NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a

        [NamesT m Term
la, NamesT m Term
phi, NamesT m Term
bT, NamesT m Term
bA] <- (Arg Term -> NamesT m (NamesT m Term))
-> Args -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (NamesT Fail Term -> Term)
-> NamesT Fail Term
-> NamesT m (NamesT m 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 m (NamesT m Term))
-> NamesT Fail Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT Fail Term) -> Term -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a))) [Arg Term
la, Arg Term
phi, Arg Term
bT, Arg Term
bA]

        -- Andreas, 2022-03-25, issue #5838.
        -- Port the fix of @unglueTranspGlue@ and @compGlue DoTransp@
        -- also to @compHCompU DoTransp@, as suggested by Tom Jack and Anders Mörtberg.
        -- We define @unglue_u0 i@ that is first used with @i@ and then with @i0@.
        -- The original code used it only with @i0@.
        Term
tunglue <- m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl (m Term -> NamesT m Term) -> m Term -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ [Char] -> m Term
getTermLocal [Char]
builtin_unglueU
        let bAS :: NamesT m Term -> NamesT m Term
bAS NamesT m Term
i =
              Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tSubIn  NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLSuc 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
i))
                           NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (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 m Term -> NamesT m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (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 :: * -> *). 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
i)
                           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
i)
        let unglue_u0 :: NamesT m Term -> NamesT m Term
unglue_u0 NamesT m Term
i =
              Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue 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
i)
                           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
i)
                           NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT 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 -> NamesT m Term
bAS 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
u0

        NamesT m Bool
-> NamesT m (Maybe Term)
-> NamesT m (Maybe Term)
-> NamesT m (Maybe Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TermPosition -> NamesT m Term -> NamesT m Bool
forall (m :: * -> *). PureTCM m => TermPosition -> m Term -> m Bool
headStop TermPosition
tpos (NamesT m Term
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)) (Maybe Term -> NamesT m (Maybe Term)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) (NamesT m (Maybe Term) -> NamesT m (Maybe Term))
-> NamesT m (Maybe Term) -> NamesT m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> NamesT m Term -> NamesT m (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do

        let
          lb :: NamesT m Term
lb = NamesT m Term
la
          tf :: NamesT m Term -> NamesT m Term -> NamesT m Term
tf NamesT m Term
i NamesT m Term
o = NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpFill NamesT m Term
lb ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> NamesT m Term
bT 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
<@> Term -> NamesT m Term
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
o) NamesT m Term
psi NamesT m Term
u0 NamesT m Term
i
          t1 :: NamesT m Term -> NamesT m Term
t1 NamesT m Term
o = NamesT m Term -> NamesT m Term -> NamesT m Term
tf (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o

          -- compute "forall. phi"
          forallphi :: NamesT m Term
forallphi = Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tForall NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi

          -- a1 with gcomp
          a1 :: NamesT m Term
a1 = NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
gcomp NamesT m Term
la NamesT m Term
bA
                 (NamesT m Term -> NamesT m Term -> NamesT m Term
imax NamesT m Term
psi NamesT m Term
forallphi)
                 ([Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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
i)
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT 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
i)
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ -> NamesT m Term -> NamesT m Term
unglue_u0 NamesT m Term
i)
                                             NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term
-> (NamesT m Term -> NamesT m Term)
-> NamesT m Term
-> NamesT m Term
transp (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
j -> NamesT m Term
bT 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 -> NamesT m Term
ineg NamesT m Term
j 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
tf NamesT m Term
i NamesT m Term
o)))
                 (NamesT m Term -> NamesT m Term
unglue_u0 (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz))

          w :: NamesT m Term -> NamesT m Term -> NamesT m Term
w NamesT m Term
i NamesT m Term
o = [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"x" ((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 -> NamesT m Term)
-> NamesT m Term
-> NamesT m Term
transp (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
j -> NamesT m Term
bT 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 -> NamesT m Term
ineg NamesT m Term
j NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)

          pt :: NamesT m Term -> NamesT m Term
pt NamesT m Term
o = -- o : [ φ 1 ]
            Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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 (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
psi
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ -> NamesT m Term
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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
<@> Term -> NamesT m Term
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
o)
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term
u0)
                      NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term
t1 NamesT m Term
o)

          -- "ghcomp" is implemented in the proof of tTranspProof
          -- (see src/data/lib/prim/Agda/Builtin/Cubical/HCompU.agda)
          t1'alpha :: NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o = -- o : [ φ 1 ]
             Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTranspProof 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 (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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT m Term
i -> NamesT m Term
bT NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
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 -> NamesT m Term
ineg 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
imax NamesT m Term
psi NamesT m Term
forallphi
                               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
pt NamesT m Term
o
                               NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tSubIn 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 (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 (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 -> NamesT m Term -> NamesT m Term
imax NamesT m Term
psi NamesT m Term
forallphi
                                                NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1)

          -- TODO: optimize?
          t1' :: NamesT m Term -> NamesT m Term
t1' NamesT m Term
o = NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o NamesT m Term -> (Term -> Term) -> NamesT m Term
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [ProjOrigin -> QName -> Elim
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (SigmaKit -> QName
sigmaFst SigmaKit
kit)])
          alpha :: NamesT m Term -> NamesT m Term
alpha NamesT m Term
o = NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o NamesT m Term -> (Term -> Term) -> NamesT m Term
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [ProjOrigin -> QName -> Elim
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (SigmaKit -> QName
sigmaSnd SigmaKit
kit)])
          a1' :: NamesT m Term
a1' = Term -> NamesT m Term
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 (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 (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 -> NamesT m Term -> NamesT m Term
imax (NamesT m Term
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
psi)
                  NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j ->
                         Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr 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 (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
<@> Term -> NamesT m Term
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
psi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT 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 (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
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> NamesT m Term -> NamesT m Term
alpha NamesT m Term
o 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 -> NamesT m Term -> NamesT m Term
w (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) 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
t1' NamesT m Term
o,NamesT m Term
a1,NamesT m Term
j))
                                   NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
_ -> NamesT m Term
a1))
                  NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1

        -- glue1 (ilam "o" t1') a1'
        case TermPosition
tpos of
          TermPosition
Eliminated -> NamesT m Term
a1'
          TermPosition
Head       -> NamesT m Term -> NamesT m Term
t1' (Term -> NamesT m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tItIsOne)
compHCompU TranspOrHComp
_ Arg Term
psi Maybe (Arg Term)
_ Arg Term
u0 FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
_ TermPosition
_ = m (Maybe Term)
forall a. HasCallStack => a
__IMPOSSIBLE__


primTransHComp :: TranspOrHComp -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp :: TranspOrHComp
-> Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp TranspOrHComp
cmd Args
ts Int
nelims = do
  (FamilyOrNot (Arg Term)
l,FamilyOrNot (Arg Term)
bA,Arg Term
phi,Maybe (Arg Term)
u,Arg Term
u0) <- case (TranspOrHComp
cmd,Args
ts) of
        (TranspOrHComp
DoTransp, [Arg Term
l,Arg Term
bA,Arg Term
phi,  Arg Term
u0]) -> do
          -- u <- runNamesT [] $ do
          --       u0 <- open $ unArg u0
          --       defaultArg <$> (ilam "o" $ \ _ -> 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 (m :: * -> *) a. Monad m => a -> m a
return ((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
$ (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)
        (TranspOrHComp
DoHComp, [Arg Term
l,Arg Term
bA,Arg Term
phi,Arg Term
u,Arg Term
u0]) -> do
          -- [l,bA] <- runNamesT [] $ do
          --   forM [l,bA] $ \ a -> do
          --     let info = argInfo a
          --     a <- open $ unArg a
          --     Arg info <$> (lam "i" $ \ _ -> a)
          (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 (m :: * -> *) a. Monad m => a -> m a
return ((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
$ (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)
        (TranspOrHComp, Args)
_                          -> ReduceM
  (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
   Maybe (Arg Term), Arg Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
  Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
  IntervalView
vphi <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi
  let clP :: [Char] -> NamesT ReduceM Term
clP [Char]
s = [Char] -> [Char] -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm (TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd) [Char]
s

  -- WORK
  case IntervalView
vphi 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
=<< case Maybe (Arg Term)
u of
                            -- cmd == DoComp
                            Just Arg Term
u -> Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ do
                                       NamesT ReduceM Term
u <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u)
                                       NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> NamesT ReduceM Term
clP [Char]
builtinIOne NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> [Char] -> NamesT ReduceM Term
clP [Char]
builtinItIsOne
                            -- cmd == DoTransp
                            Maybe (Arg Term)
Nothing -> Term -> ReduceM Term
forall (m :: * -> *) a. Monad m => a -> m a
return (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
             MaybeReducedArgs
u' <- case Maybe (Arg Term)
u of
                            -- cmd == DoComp
                     Just Arg Term
u ->
                              (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
                                          IntervalView
IZero -> (Term -> MaybeReduced (Arg Term))
-> ReduceM Term -> ReduceM (MaybeReduced (Arg Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced (Blocked (Arg Term) -> MaybeReduced (Arg Term))
-> (Term -> Blocked (Arg Term)) -> Term -> MaybeReduced (Arg Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Blocked (Arg Term)
forall a t. a -> Blocked' t a
notBlocked (Arg Term -> Blocked (Arg Term))
-> (Term -> Arg Term) -> Term -> Blocked (Arg Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argN) (ReduceM Term -> ReduceM (MaybeReduced (Arg Term)))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (MaybeReduced (Arg Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (MaybeReduced (Arg Term)))
-> NamesT ReduceM Term -> ReduceM (MaybeReduced (Arg Term))
forall a b. (a -> b) -> a -> b
$ do
                                            [NamesT ReduceM Term
l,NamesT ReduceM Term
c] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Args -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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]
                                            [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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 -> [Char] -> NamesT ReduceM Term
clP [Char]
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
<#> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT ReduceM Term
_ -> NamesT ReduceM Term
c)
                                          IntervalView
_     -> MaybeReduced (Arg Term) -> ReduceM (MaybeReduced (Arg Term))
forall (m :: * -> *) a. Monad m => a -> m a
return (Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
u)
                            -- cmd == DoTransp
                     Maybe (Arg Term)
Nothing -> MaybeReducedArgs -> ReduceM MaybeReducedArgs
forall (m :: * -> *) a. Monad m => a -> m a
return []
             Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
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)
forall a. a -> MaybeReduced a
notReduced (FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Arg Term)
l), Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sc, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ MaybeReducedArgs
u' MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
u0]
       Blocked (FamilyOrNot (Arg Term))
sbA <- FamilyOrNot (Arg Term)
-> ReduceM (Blocked (FamilyOrNot (Arg Term)))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' FamilyOrNot (Arg Term)
bA
       Maybe (Blocked' Term (FamilyOrNot Term))
t <- case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> FamilyOrNot (Arg Term) -> FamilyOrNot Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term)) -> FamilyOrNot (Arg Term)
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (FamilyOrNot (Arg Term))
sbA of
              IsFam (Lam ArgInfo
_info 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 (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 (m :: * -> *) a. Monad m => a -> m a
return 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 (m :: * -> *) a. Monad m => a -> m a
return (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 (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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Blocked (FamilyOrNot (Arg Term))
sbA)
       case Maybe (Blocked' Term (FamilyOrNot Term))
t of
         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
               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 (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 (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
               Maybe QName
mHComp <- [Char] -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinHComp
               Maybe QName
mGlue <- [Char] -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinGlue
               Maybe QName
mId   <- [Char] -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getBuiltinName' [Char]
builtinId
               Type -> PathView
pathV <- ReduceM (Type -> PathView)
forall (m :: * -> *). HasBuiltins m => m (Type -> PathView)
pathView'
               case FamilyOrNot Term -> Term
forall a. FamilyOrNot a -> a
famThing FamilyOrNot Term
t of
                 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 (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 (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Blocked (FamilyOrNot (Arg Term))
sbA)
                 -- absName t instead of "i"
                 Pi Dom Type
a Abs Type
b | Int
nelims Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
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
=<< TranspOrHComp
-> [Char]
-> FamilyOrNot (Dom Type, Abs Type)
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Maybe Term)
compPi TranspOrHComp
cmd [Char]
"i" ((Dom Type
a,Abs Type
b) (Dom Type, Abs Type)
-> FamilyOrNot Term -> FamilyOrNot (Dom Type, Abs Type)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) (Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi) Maybe (Arg Term)
u Arg Term
u0
                        | Bool
otherwise -> ReduceM (Reduced MaybeReducedArgs Term)
fallback

                 Sort (Type Level' Term
l) | TranspOrHComp
DoTransp <- TranspOrHComp
cmd -> TranspOrHComp
-> ReduceM (Reduced MaybeReducedArgs Term)
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Level' Term)
-> ReduceM (Reduced MaybeReducedArgs Term)
forall {p} {p} {a} {a} {a} {a'}.
TranspOrHComp
-> p
-> p
-> Maybe a
-> Arg a
-> FamilyOrNot a
-> ReduceM (Reduced a' a)
compSort TranspOrHComp
cmd ReduceM (Reduced MaybeReducedArgs Term)
fallback Arg Term
phi Maybe (Arg Term)
u Arg Term
u0 (Level' Term
l Level' Term -> FamilyOrNot Term -> FamilyOrNot (Level' Term)
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t)

                 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
=<< TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
compGlue TranspOrHComp
cmd Arg Term
phi Maybe (Arg Term)
u Arg Term
u0 ((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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) TermPosition
Head

                 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
=<< TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
compHCompU TranspOrHComp
cmd Arg Term
phi Maybe (Arg Term)
u Arg Term
u0 ((Level' Term -> Term
Level Level' Term
la Term -> Arg Term -> Arg Term
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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) TermPosition
Head

                 -- Path/PathP
                 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 Int
nelims Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0 then TranspOrHComp
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Reduced MaybeReducedArgs Term)
forall {t} {a'}.
TranspOrHComp
-> Blocked' t (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Reduced a' Term)
compPathP TranspOrHComp
cmd Blocked (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
u0 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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) else ReduceM (Reduced MaybeReducedArgs Term)
fallback

                 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 (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
=<< TranspOrHComp
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Maybe (Reduced MaybeReducedArgs Term))
forall {t} {a'}.
TranspOrHComp
-> Blocked' t (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Maybe (Reduced a' Term))
compId TranspOrHComp
cmd Blocked (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
u0 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 (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t)

                 Def QName
q [Elim]
es -> do
                   Definition
info <- QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
q
                   let   lam_i :: Term -> Term
lam_i = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Term -> Abs Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"i"

                   case Definition -> Defn
theDef Definition
info of
                     r :: Defn
r@Record{recComp :: Defn -> CompKit
recComp = CompKit
kit} | Int
nelims Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0, Just Args
as <- [Elim] -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, TranspOrHComp
DoTransp <- TranspOrHComp
cmd, Just QName
transpR <- CompKit -> Maybe QName
nameOfTransp CompKit
kit
                                -> if Defn -> Int
recPars Defn
r Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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 -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply`
                                               ((Arg Term -> Arg Term) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> Arg Term -> Arg Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) Args
as Args -> Args -> Args
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])
                         | Int
nelims Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0, Just Args
as <- [Elim] -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, TranspOrHComp
DoHComp <- TranspOrHComp
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 -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply`
                                               (Args
as Args -> Args -> Args
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])

                         | Just Args
as <- [Elim] -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, [] <- Defn -> [Dom QName]
recFields Defn
r -> Bool
-> Int
-> TranspOrHComp
-> FamilyOrNot (Arg Term)
-> FamilyOrNot Args
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall {p}.
(Eq p, Num p) =>
Bool
-> p
-> TranspOrHComp
-> FamilyOrNot (Arg Term)
-> FamilyOrNot Args
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
compData Bool
False (Defn -> Int
recPars Defn
r) TranspOrHComp
cmd FamilyOrNot (Arg Term)
l (Args
as Args -> FamilyOrNot Term -> FamilyOrNot Args
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
                     Datatype{dataPars :: Defn -> Int
dataPars = Int
pars, dataIxs :: Defn -> Int
dataIxs = Int
ixs, dataPathCons :: Defn -> [QName]
dataPathCons = [QName]
pcons}
                       | [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [[QName] -> Bool
forall a. Null a => a -> Bool
null [QName]
pcons | TranspOrHComp
DoHComp  <- [TranspOrHComp
cmd]], Just Args
as <- [Elim] -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es -> Bool
-> Int
-> TranspOrHComp
-> FamilyOrNot (Arg Term)
-> FamilyOrNot Args
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall {p}.
(Eq p, Num p) =>
Bool
-> p
-> TranspOrHComp
-> FamilyOrNot (Arg Term)
-> FamilyOrNot Args
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
compData (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [QName] -> Bool
forall a. Null a => a -> Bool
null ([QName] -> Bool) -> [QName] -> Bool
forall a b. (a -> b) -> a -> b
$ [QName]
pcons) (Int
parsInt -> Int -> Int
forall a. Num a => a -> a -> a
+Int
ixs) TranspOrHComp
cmd FamilyOrNot (Arg Term)
l (Args
as Args -> FamilyOrNot Term -> FamilyOrNot Args
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
                     Axiom Bool
constTransp | Bool
constTransp, [] <- [Elim]
es, TranspOrHComp
DoTransp <- TranspOrHComp
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
    compSort :: TranspOrHComp
-> p
-> p
-> Maybe a
-> Arg a
-> FamilyOrNot a
-> ReduceM (Reduced a' a)
compSort TranspOrHComp
DoTransp p
fallback p
phi Maybe a
Nothing Arg a
u0 (IsFam a
l) = do
      -- TODO should check l is constant
      a -> ReduceM (Reduced a' a)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (a -> ReduceM (Reduced a' a)) -> a -> ReduceM (Reduced a' a)
forall a b. (a -> b) -> a -> b
$ Arg a -> a
forall e. Arg e -> e
unArg Arg a
u0
    -- compSort DoHComp fallback phi (Just u) u0 (IsNot l) = -- hcomp for Set is a whnf, handled above.
    compSort TranspOrHComp
_ p
fallback p
phi Maybe a
u Arg a
u0 FamilyOrNot a
_ = ReduceM (Reduced a' a)
forall a. HasCallStack => a
__IMPOSSIBLE__
    compPi :: TranspOrHComp -> ArgName -> FamilyOrNot (Dom Type, Abs Type) -- Γ , i : I
            -> Arg Term -- Γ
            -> Maybe (Arg Term) -- Γ
            -> Arg Term -- Γ
            -> ReduceM (Maybe Term)
    compPi :: TranspOrHComp
-> [Char]
-> FamilyOrNot (Dom Type, Abs Type)
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Maybe Term)
compPi TranspOrHComp
cmd [Char]
t FamilyOrNot (Dom Type, Abs Type)
ab Arg Term
phi Maybe (Arg Term)
u Arg Term
u0 = do
     let getTermLocal :: [Char] -> ReduceM Term
getTermLocal = [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm ([Char] -> [Char] -> ReduceM Term)
-> [Char] -> [Char] -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for function types"

     Term
tTrans <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinTrans
     Term
tHComp <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinHComp
     Term
tINeg <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinINeg
     Term
tIMax <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIMax
     Term
iz    <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIZero
     let
      toLevel' :: a -> m (Maybe (Level' Term))
toLevel' a
t = do
        Sort
s <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ a -> Sort
forall a. LensSort a => a -> Sort
getSort a
t
        case Sort
s of
          (Type Level' Term
l) -> Maybe (Level' Term) -> m (Maybe (Level' Term))
forall (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 (m :: * -> *) a. Monad m => a -> m a
return Maybe (Level' Term)
forall a. Maybe a
Nothing
      toLevel :: a -> f (Level' Term)
toLevel a
t = Level' Term -> Maybe (Level' Term) -> Level' Term
forall a. a -> Maybe a -> a
fromMaybe Level' Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Level' Term) -> Level' Term)
-> f (Maybe (Level' Term)) -> f (Level' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f (Maybe (Level' Term))
forall {m :: * -> *} {a}.
(MonadReduce m, LensSort a) =>
a -> m (Maybe (Level' Term))
toLevel' a
t
     -- make sure the codomain has a level.
     ReduceM (Maybe (Level' Term))
-> ReduceM (Maybe Term)
-> (Level' Term -> ReduceM (Maybe Term))
-> ReduceM (Maybe Term)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Type -> ReduceM (Maybe (Level' Term))
forall {m :: * -> *} {a}.
(MonadReduce m, LensSort a) =>
a -> m (Maybe (Level' Term))
toLevel' (Type -> ReduceM (Maybe (Level' Term)))
-> (FamilyOrNot (Dom Type, Abs Type) -> Type)
-> FamilyOrNot (Dom Type, Abs Type)
-> ReduceM (Maybe (Level' Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody (Abs Type -> Type)
-> (FamilyOrNot (Dom Type, Abs Type) -> Abs Type)
-> FamilyOrNot (Dom Type, Abs Type)
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dom Type, Abs Type) -> Abs Type
forall a b. (a, b) -> b
snd ((Dom Type, Abs Type) -> Abs Type)
-> (FamilyOrNot (Dom Type, Abs Type) -> (Dom Type, Abs Type))
-> FamilyOrNot (Dom Type, Abs Type)
-> Abs Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamilyOrNot (Dom Type, Abs Type) -> (Dom Type, Abs Type)
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Dom Type, Abs Type) -> ReduceM (Maybe (Level' Term)))
-> FamilyOrNot (Dom Type, Abs Type)
-> ReduceM (Maybe (Level' Term))
forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom Type, Abs Type)
ab) (Maybe Term -> ReduceM (Maybe Term)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) ((Level' Term -> ReduceM (Maybe Term)) -> ReduceM (Maybe Term))
-> (Level' Term -> ReduceM (Maybe Term)) -> ReduceM (Maybe Term)
forall a b. (a -> b) -> a -> b
$ \ Level' Term
_ -> do
     Names -> NamesT ReduceM (Maybe Term) -> ReduceM (Maybe Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM (Maybe Term) -> ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term) -> ReduceM (Maybe Term)
forall a b. (a -> b) -> a -> b
$ do
      Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
labA <- do
        let (Dom Type
x,Term -> Term
f) = case FamilyOrNot (Dom Type, Abs Type)
ab of
              IsFam (Dom Type
a,Abs Type
_) -> (Dom 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
$ [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
a)))
              IsNot (Dom Type
a,Abs Type
_) -> (Dom Type
a, Term -> Term
forall a. a -> a
id)
        Sort
s <- Sort -> NamesT ReduceM Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> NamesT ReduceM Sort) -> Sort -> NamesT ReduceM Sort
forall a b. (a -> b) -> a -> b
$ Dom Type -> Sort
forall a. LensSort a => a -> Sort
getSort Dom Type
x
        case Sort
s of
          Type Level' Term
lx -> do
            [NamesT ReduceM Term
la,NamesT ReduceM Term
bA] <- (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
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 Type -> Type) -> Dom Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Term) -> Dom Type -> Term
forall a b. (a -> b) -> a -> b
$ Dom Type
x]
            Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
   ((NamesT ReduceM Term -> NamesT ReduceM Term)
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term)
 -> NamesT
      ReduceM
      (Maybe
         ((NamesT ReduceM Term -> NamesT ReduceM Term)
          -> NamesT ReduceM Term
          -> NamesT ReduceM Term
          -> NamesT ReduceM Term)))
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (Maybe
        ((NamesT ReduceM Term -> NamesT ReduceM Term)
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term
         -> NamesT ReduceM Term))
forall a b. (a -> b) -> a -> b
$ ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term)
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a. a -> Maybe a
Just (((NamesT ReduceM Term -> NamesT ReduceM Term)
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term)
 -> Maybe
      ((NamesT ReduceM Term -> NamesT ReduceM Term)
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term
       -> NamesT ReduceM Term))
-> ((NamesT ReduceM Term -> NamesT ReduceM Term)
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term)
-> Maybe
     ((NamesT ReduceM Term -> NamesT ReduceM Term)
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
phi NamesT ReduceM Term
a0 -> Term -> NamesT ReduceM Term
forall (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
<#> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
<@> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
          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 (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
          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 (m :: * -> *) a. Monad m => a -> m a
return Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
forall a. Maybe a
Nothing
      Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
-> NamesT ReduceM (Maybe Term)
-> (((NamesT ReduceM Term -> NamesT ReduceM Term)
     -> NamesT ReduceM Term
     -> NamesT ReduceM Term
     -> NamesT ReduceM Term)
    -> NamesT ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term)
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe
  ((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
labA (Maybe Term -> NamesT ReduceM (Maybe Term)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) ((((NamesT ReduceM Term -> NamesT ReduceM Term)
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term
   -> NamesT ReduceM Term)
  -> NamesT ReduceM (Maybe Term))
 -> NamesT ReduceM (Maybe Term))
-> (((NamesT ReduceM Term -> NamesT ReduceM Term)
     -> NamesT ReduceM Term
     -> NamesT ReduceM Term
     -> NamesT ReduceM Term)
    -> NamesT ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term)
forall a b. (a -> b) -> a -> b
$ \ (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
trA -> Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term)
-> NamesT ReduceM Term -> NamesT ReduceM (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
      [NamesT ReduceM Term
phi, NamesT ReduceM Term
u0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Args -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
phi, Arg Term
u0]
      Maybe (NamesT ReduceM Term)
u <- (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Maybe Term -> NamesT ReduceM (Maybe (NamesT ReduceM Term))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Maybe (Arg Term) -> Maybe Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Arg Term)
u)

      ArgInfo
-> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
ArgInfo
-> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
glam (Dom Type -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo ((Dom Type, Abs Type) -> Dom Type
forall a b. (a, b) -> a
fst ((Dom Type, Abs Type) -> Dom Type)
-> (Dom Type, Abs Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom Type, Abs Type) -> (Dom Type, Abs Type)
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Dom Type, Abs Type)
ab)) (Abs Type -> [Char]
forall a. Abs a -> [Char]
absName (Abs Type -> [Char]) -> Abs Type -> [Char]
forall a b. (a -> b) -> a -> b
$ (Dom Type, Abs Type) -> Abs Type
forall a b. (a, b) -> b
snd ((Dom Type, Abs Type) -> Abs Type)
-> (Dom Type, Abs Type) -> Abs Type
forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom Type, Abs Type) -> (Dom Type, Abs Type)
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Dom Type, Abs Type)
ab) ((NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
u1 -> do
        case (TranspOrHComp
cmd, FamilyOrNot (Dom Type, Abs Type)
ab, Maybe (NamesT ReduceM Term)
u) of
          (TranspOrHComp
DoHComp, IsNot (Dom Type
a , Abs Type
b), Just NamesT ReduceM Term
u) -> do
            Type
bT <- (Int -> Abs Type -> Abs Type
forall a. Subst a => Int -> a -> a
raise Int
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
            let v :: NamesT ReduceM Term
v = NamesT ReduceM Term
u1
            Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Level' Term -> Term
Level (Level' Term -> Term)
-> NamesT ReduceM (Level' Term) -> NamesT ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> NamesT ReduceM (Level' Term)
forall {f :: * -> *} {a}.
(MonadReduce f, LensSort a) =>
a -> f (Level' Term)
toLevel Type
bT)
                        NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Term
forall t a. Type'' t a -> a
unEl                      (Type -> Term) -> Type -> Term
forall a b. (a -> b) -> a -> b
$ Type
bT)
                        NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
phi
                        NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT ReduceM Term
i -> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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 Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom 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
v)
                        NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Hiding
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (Dom Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom Type
a) NamesT ReduceM Term
u0 NamesT ReduceM Term
v)
          (TranspOrHComp
DoTransp, IsFam (Dom Type
a , Abs Type
b), Maybe (NamesT ReduceM Term)
Nothing) -> do
            let v :: NamesT ReduceM Term -> NamesT ReduceM Term
v NamesT ReduceM Term
i = do
                       let
                         iOrNot :: NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
j = Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax 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
<@> (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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
-> NamesT ReduceM Term
-> NamesT ReduceM Term
trA NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax 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
i)
                                  NamesT ReduceM Term
u1
                -- Γ , u1 : A[i1] , i : I
                bB :: Term -> Type
bB Term
v = Term -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
v (Int -> Substitution' Term -> Substitution' Term
forall a. Int -> Substitution' a -> Substitution' a
liftS Int
1 (Substitution' Term -> Substitution' Term)
-> Substitution' Term -> Substitution' Term
forall a b. (a -> b) -> a -> b
$ Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS Int
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] -})
                tLam :: Abs Term -> Term
tLam = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo
            Abs Type
bT <- [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Type)
-> NamesT ReduceM (Abs Type)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
[Char] -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind [Char]
"i" ((NamesT ReduceM Term -> NamesT ReduceM Type)
 -> NamesT ReduceM (Abs Type))
-> (NamesT ReduceM Term -> NamesT ReduceM Type)
-> NamesT ReduceM (Abs Type)
forall a b. (a -> b) -> a -> b
$ (Term -> Type) -> NamesT ReduceM Term -> NamesT ReduceM Type
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
            -- Γ , u1 : A[i1]
            (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Abs Term -> Term
tLam (Abs Term -> Term)
-> NamesT ReduceM (Abs Term) -> NamesT ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> NamesT ReduceM Term)
-> Abs Type -> NamesT ReduceM (Abs Term)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Level' Term -> Term)
-> NamesT ReduceM (Level' Term) -> NamesT ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Level' Term -> Term
Level (NamesT ReduceM (Level' Term) -> NamesT ReduceM Term)
-> (Type -> NamesT ReduceM (Level' Term))
-> Type
-> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> NamesT ReduceM (Level' Term)
forall {f :: * -> *} {a}.
(MonadReduce f, LensSort a) =>
a -> f (Level' Term)
toLevel) Abs Type
bT)
                         NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT ReduceM Term)
-> (Abs Term -> Term) -> Abs Term -> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Term -> Term
tLam (Abs Term -> NamesT ReduceM Term)
-> Abs Term -> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ Type -> Term
forall t a. Type'' t a -> a
unEl                      (Type -> Term) -> Abs Type -> Abs Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs Type
bT)
                         NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi
                         NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Hiding
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (Dom Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom Type
a) NamesT ReduceM Term
u0 (NamesT ReduceM Term -> NamesT ReduceM Term
v (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz)))
          (TranspOrHComp
_,FamilyOrNot (Dom Type, Abs Type)
_,Maybe (NamesT ReduceM Term)
_) -> NamesT ReduceM Term
forall a. HasCallStack => a
__IMPOSSIBLE__
    compPathP :: TranspOrHComp
-> Blocked' t (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Reduced a' Term)
compPathP cmd :: TranspOrHComp
cmd@TranspOrHComp
DoHComp Blocked' t (Arg Term)
sphi (Just Arg Term
u) Arg Term
u0 (IsNot Arg Term
l) (IsNot (Arg Term
bA,Arg Term
x,Arg Term
y)) = do
      let getTermLocal :: [Char] -> ReduceM Term
getTermLocal = [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm ([Char] -> [Char] -> ReduceM Term)
-> [Char] -> [Char] -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for path types"
      Term
tHComp <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinHComp
      Term
tINeg <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinINeg
      Term
tIMax <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIMax
      Term
tOr   <- [Char] -> ReduceM Term
getTermLocal [Char]
"primPOr"
      let
        ineg :: NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
j = Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
j
        imax :: NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
imax NamesT Fail Term
i NamesT Fail Term
j = Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
j

      Term -> ReduceM (Reduced a' Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced a' Term))
-> (NamesT Fail Term -> Term)
-> NamesT Fail Term
-> ReduceM (Reduced a' 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 -> ReduceM (Reduced a' Term))
-> NamesT Fail Term -> ReduceM (Reduced a' Term)
forall a b. (a -> b) -> a -> b
$ do
         [NamesT Fail Term
l,NamesT Fail Term
u,NamesT Fail Term
u0] <- (Arg Term -> NamesT Fail (NamesT Fail Term))
-> Args -> NamesT Fail [NamesT Fail Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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,Arg Term
u,Arg Term
u0]
         NamesT Fail Term
phi      <- 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))
-> (Blocked' t (Arg Term) -> Term)
-> Blocked' t (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 -> Term)
-> (Blocked' t (Arg Term) -> Arg Term)
-> Blocked' t (Arg Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked' t (Arg Term) -> NamesT Fail (NamesT Fail Term))
-> Blocked' t (Arg Term) -> NamesT Fail (NamesT Fail Term)
forall a b. (a -> b) -> a -> b
$ Blocked' t (Arg Term)
sphi
         [NamesT Fail Term
bA, NamesT Fail Term
x, NamesT Fail Term
y] <- (Arg Term -> NamesT Fail (NamesT Fail Term))
-> Args -> NamesT Fail [NamesT Fail Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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
bA, Arg Term
x, Arg Term
y]
         [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" ((NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term)
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
j ->
           Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp 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
<#> (NamesT Fail Term
bA NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
j)
                       NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Fail Term
phi NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
`imax` (NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
j NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
`imax` NamesT Fail Term
j))
                       NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i'" (\ NamesT Fail Term
i ->
                            let or :: NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
or NamesT Fail Term
f1 NamesT Fail Term
f2 = Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tOr 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
<@> NamesT Fail Term
f1 NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
f2 NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" (\ NamesT Fail Term
_ -> NamesT Fail Term
bA NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i)
                            in NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
or NamesT Fail Term
phi (NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
j NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
`imax` NamesT Fail Term
j)
                                          NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT Fail Term
o -> NamesT Fail Term
u NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT Fail Term
o NamesT Fail Term
-> (NamesT Fail Term, NamesT Fail Term, NamesT Fail Term)
-> NamesT Fail Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT Fail Term
x, NamesT Fail Term
y, NamesT Fail Term
j)) -- a0 <@@> (x <@> i, y <@> i, j)
                                          NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
or (NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
j) NamesT Fail Term
j NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const NamesT Fail Term
x)
                                                                  NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const NamesT Fail Term
y)))
                       NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Fail Term
u0 NamesT Fail Term
-> (NamesT Fail Term, NamesT Fail Term, NamesT Fail Term)
-> NamesT Fail Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT Fail Term
x, NamesT Fail Term
y, NamesT Fail Term
j))
    compPathP cmd :: TranspOrHComp
cmd@TranspOrHComp
DoTransp Blocked' t (Arg Term)
sphi Maybe (Arg Term)
Nothing Arg Term
u0 (IsFam Arg Term
l) (IsFam (Arg Term
bA,Arg Term
x,Arg Term
y)) = do
      -- Γ    ⊢ l
      -- Γ, i ⊢ bA, x, y
      let getTermLocal :: [Char] -> ReduceM Term
getTermLocal = [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm ([Char] -> [Char] -> ReduceM Term)
-> [Char] -> [Char] -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for path types"
      Term
tINeg <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinINeg
      Term
tIMax <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIMax
      Term
tOr   <- [Char] -> ReduceM Term
getTermLocal [Char]
"primPOr"
      Term
iz <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIZero
      Term
io <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIOne
      let
        ineg :: NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
j = Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
j
        imax :: NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
imax NamesT Fail Term
i NamesT Fail Term
j = Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
j
      NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
comp <- do
        Term
tHComp <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinHComp
        Term
tTrans <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinTrans
        let forward :: NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
forward NamesT Fail Term
la NamesT Fail Term
bA NamesT Fail Term
r NamesT Fail Term
u = Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Fail Term
i -> NamesT Fail Term
la NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Fail Term
i NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
`imax` NamesT Fail Term
r))
                                            NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Fail Term
i -> NamesT Fail Term
bA NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Fail Term
i NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
`imax` NamesT Fail Term
r))
                                            NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
r
                                            NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
u
        (NamesT Fail Term
 -> NamesT Fail Term
 -> NamesT Fail Term
 -> NamesT Fail Term
 -> NamesT Fail Term
 -> NamesT Fail Term)
-> ReduceM
     (NamesT Fail Term
      -> NamesT Fail Term
      -> NamesT Fail Term
      -> NamesT Fail Term
      -> NamesT Fail Term
      -> NamesT Fail Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT Fail Term
  -> NamesT Fail Term
  -> NamesT Fail Term
  -> NamesT Fail Term
  -> NamesT Fail Term
  -> NamesT Fail Term)
 -> ReduceM
      (NamesT Fail Term
       -> NamesT Fail Term
       -> NamesT Fail Term
       -> NamesT Fail Term
       -> NamesT Fail Term
       -> NamesT Fail Term))
-> (NamesT Fail Term
    -> NamesT Fail Term
    -> NamesT Fail Term
    -> NamesT Fail Term
    -> NamesT Fail Term
    -> NamesT Fail Term)
-> ReduceM
     (NamesT Fail Term
      -> NamesT Fail Term
      -> NamesT Fail Term
      -> NamesT Fail Term
      -> NamesT Fail Term
      -> NamesT Fail Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
la NamesT Fail Term
bA NamesT Fail Term
phi NamesT Fail Term
u NamesT Fail Term
u0 ->
          Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Fail Term
la NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
                      NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Fail Term
bA NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
                      NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
phi
                      NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Fail Term
i -> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" ((NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term)
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
o ->
                              NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
forward NamesT Fail Term
la NamesT Fail Term
bA NamesT Fail Term
i (NamesT Fail Term
u NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT Fail Term
o))
                      NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
forward NamesT Fail Term
la NamesT Fail Term
bA (Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT Fail Term
u0
      Term -> ReduceM (Reduced a' Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced a' Term))
-> (NamesT Fail Term -> Term)
-> NamesT Fail Term
-> ReduceM (Reduced a' 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 -> ReduceM (Reduced a' Term))
-> NamesT Fail Term -> ReduceM (Reduced a' Term)
forall a b. (a -> b) -> a -> b
$ do
        [NamesT Fail Term
l,NamesT Fail Term
u0] <- (Arg Term -> NamesT Fail (NamesT Fail Term))
-> Args -> NamesT Fail [NamesT Fail Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t 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,Arg Term
u0]
        NamesT Fail Term
phi      <- 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))
-> (Blocked' t (Arg Term) -> Term)
-> Blocked' t (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 -> Term)
-> (Blocked' t (Arg Term) -> Arg Term)
-> Blocked' t (Arg Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked' t (Arg Term) -> NamesT Fail (NamesT Fail Term))
-> Blocked' t (Arg Term) -> NamesT Fail (NamesT Fail Term)
forall a b. (a -> b) -> a -> b
$ Blocked' t (Arg Term)
sphi
        [NamesT Fail Term
bA, NamesT Fail Term
x, NamesT Fail Term
y] <- (Arg Term -> NamesT Fail (NamesT Fail Term))
-> Args -> NamesT Fail [NamesT Fail Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> 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))
-> (NamesT Fail Term -> Term)
-> NamesT Fail Term
-> NamesT Fail (NamesT Fail 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 Fail (NamesT Fail Term))
-> NamesT Fail Term -> NamesT Fail (NamesT Fail Term)
forall a b. (a -> b) -> a -> b
$ [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT Fail Term) -> Term -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a))) [Arg Term
bA, Arg Term
x, Arg Term
y]
        [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" ((NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term)
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
j ->
          NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
-> NamesT Fail Term
comp NamesT Fail Term
l ([Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" ((NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term)
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
i -> NamesT Fail Term
bA NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
j) (NamesT Fail Term
phi NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
`imax` (NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
j NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
`imax` NamesT Fail Term
j))
                      ([Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i'" ((NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term)
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
i ->
                            let or :: NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
or NamesT Fail Term
f1 NamesT Fail Term
f2 = Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tOr 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
<@> NamesT Fail Term
f1 NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
f2 NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" (\ NamesT Fail Term
_ -> NamesT Fail Term
bA NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
j) in
                                       NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
or NamesT Fail Term
phi (NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
j NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
`imax` NamesT Fail Term
j)
                                          NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT Fail Term
o -> NamesT Fail Term
u0 NamesT Fail Term
-> (NamesT Fail Term, NamesT Fail Term, NamesT Fail Term)
-> NamesT Fail Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT Fail Term
x NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT Fail Term
y NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT Fail Term
j))
                                          NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
or (NamesT Fail Term -> NamesT Fail Term
ineg NamesT Fail Term
j) NamesT Fail Term
j NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (NamesT Fail Term
x NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i))
                                                                  NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (NamesT Fail Term
y NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i))))
                      (NamesT Fail Term
u0 NamesT Fail Term
-> (NamesT Fail Term, NamesT Fail Term, NamesT Fail Term)
-> NamesT Fail Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT Fail Term
x NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT Fail Term
y NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT Fail Term
j))
    compPathP TranspOrHComp
_ Blocked' t (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
a0 FamilyOrNot (Arg Term)
_ FamilyOrNot (Arg Term, Arg Term, Arg Term)
_ = ReduceM (Reduced a' Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
    compId :: TranspOrHComp
-> Blocked' t (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Maybe (Reduced a' Term))
compId TranspOrHComp
cmd Blocked' t (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
a0 FamilyOrNot (Arg Term)
l FamilyOrNot (Arg Term, Arg Term, Arg Term)
bA_x_y = do
      let getTermLocal :: [Char] -> ReduceM Term
getTermLocal = [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm ([Char] -> [Char] -> ReduceM Term)
-> [Char] -> [Char] -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
builtinId
      IntervalView -> Term
unview <- ReduceM (IntervalView -> Term)
forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
      Maybe QName
mConId <- [Char] -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getBuiltinName' [Char]
builtinConId
      let isConId :: Term -> Bool
isConId (Def QName
q [Elim]
_) = 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
mConId
          isConId Term
_         = Bool
False
      Blocked (Arg Term)
sa0 <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
a0
      -- wasteful to compute b even when cheaper checks might fail
      Bool
b <- case Maybe (Arg Term)
u of
             Maybe (Arg Term)
Nothing -> Bool -> ReduceM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
             Just Arg Term
u  -> (IntervalView -> Term)
-> Term -> Term -> (Term -> Bool) -> ReduceM Bool
allComponents IntervalView -> Term
unview (Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term)
-> (Blocked' t (Arg Term) -> Arg Term)
-> Blocked' t (Arg Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked' t (Arg Term) -> Term) -> Blocked' t (Arg Term) -> Term
forall a b. (a -> b) -> a -> b
$ Blocked' t (Arg Term)
sphi) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u) Term -> Bool
isConId
      case Maybe QName
mConId of
        Just QName
conid | Term -> Bool
isConId (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)
sa0) , Bool
b -> (Reduced a' Term -> Maybe (Reduced a' Term)
forall a. a -> Maybe a
Just (Reduced a' Term -> Maybe (Reduced a' Term))
-> ReduceM (Reduced a' Term) -> ReduceM (Maybe (Reduced a' Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (ReduceM (Reduced a' Term) -> ReduceM (Maybe (Reduced a' Term)))
-> (ReduceM Term -> ReduceM (Reduced a' Term))
-> ReduceM Term
-> ReduceM (Maybe (Reduced a' Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> ReduceM (Reduced a' Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced a' Term))
-> ReduceM Term -> ReduceM (Reduced a' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (ReduceM Term -> ReduceM (Maybe (Reduced a' Term)))
-> ReduceM Term -> ReduceM (Maybe (Reduced a' Term))
forall a b. (a -> b) -> a -> b
$ do
          Term
tHComp <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinHComp
          Term
tTrans <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinTrans
          Term
tIMin <- [Char] -> ReduceM Term
getTermLocal [Char]
"primDepIMin"
          Term
tFace <- [Char] -> ReduceM Term
getTermLocal [Char]
"primIdFace"
          Term
tPath <- [Char] -> ReduceM Term
getTermLocal [Char]
"primIdPath"
          Term
tPathType <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinPath
          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
            let io :: NamesT ReduceM Term
io = Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT ReduceM Term) -> Term -> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ IntervalView -> Term
unview IntervalView
IOne
                iz :: NamesT ReduceM Term
iz = Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT ReduceM Term) -> Term -> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ IntervalView -> Term
unview IntervalView
IZero
                conId :: NamesT ReduceM Term
conId = Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT ReduceM Term) -> Term -> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
conid []
            NamesT ReduceM Term
l <- case FamilyOrNot (Arg Term)
l of
                   IsFam Arg Term
l -> Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Arg Term -> NamesT ReduceM (NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ Arg Term
l
                   IsNot Arg Term
l -> do
                     Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
NoAbs [Char]
"_" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
l)
            [NamesT ReduceM Term
p0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Args -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
a0]
            NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
p <- case Maybe (Arg Term)
u of
                   Just Arg Term
u -> do
                     NamesT ReduceM Term
u <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Arg Term -> NamesT ReduceM (NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ Arg Term
u
                     (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT ReduceM Term
  -> NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT
      ReduceM
      (NamesT ReduceM Term
       -> NamesT ReduceM Term -> NamesT ReduceM Term))
-> (NamesT ReduceM Term
    -> NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i 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
                   Maybe (Arg Term)
Nothing -> do
                     (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT ReduceM Term
  -> NamesT ReduceM Term -> NamesT ReduceM Term)
 -> NamesT
      ReduceM
      (NamesT ReduceM Term
       -> NamesT ReduceM Term -> NamesT ReduceM Term))
-> (NamesT ReduceM Term
    -> NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i NamesT ReduceM Term
o -> NamesT ReduceM Term
p0
            NamesT ReduceM Term
phi      <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Blocked' t (Arg Term) -> Term)
-> Blocked' t (Arg Term)
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term)
-> (Blocked' t (Arg Term) -> Arg Term)
-> Blocked' t (Arg Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked' t (Arg Term) -> NamesT ReduceM (NamesT ReduceM Term))
-> Blocked' t (Arg Term) -> NamesT ReduceM (NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ Blocked' t (Arg Term)
sphi
            [NamesT ReduceM Term
bA, NamesT ReduceM Term
x, NamesT ReduceM Term
y] <-
              case FamilyOrNot (Arg Term, Arg Term, Arg Term)
bA_x_y of
                IsFam (Arg Term
bA,Arg Term
x,Arg Term
y) -> (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Args -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (NamesT Fail Term -> Term)
-> NamesT Fail Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> NamesT Fail Term -> Term
forall a. Names -> NamesT Fail a -> a
runNames [] (NamesT Fail Term -> NamesT ReduceM (NamesT ReduceM Term))
-> NamesT Fail Term -> NamesT ReduceM (NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ [Char]
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT Fail Term) -> Term -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a))) [Arg Term
bA, Arg Term
x, Arg Term
y]
                IsNot (Arg Term
bA,Arg Term
x,Arg Term
y) -> Args
-> (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Arg Term
bA,Arg Term
x,Arg Term
y] ((Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
 -> NamesT ReduceM [NamesT ReduceM Term])
-> (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> NamesT ReduceM [NamesT ReduceM Term]
forall a b. (a -> b) -> a -> b
$ \ Arg Term
a -> Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
NoAbs [Char]
"_" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a)
            let
              eval :: TranspOrHComp
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
eval TranspOrHComp
DoTransp NamesT ReduceM Term
l NamesT ReduceM Term
bA NamesT ReduceM Term
phi NamesT ReduceM Term
_ NamesT ReduceM Term
u0 = Term -> NamesT ReduceM Term
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
<#> 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
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u0
              eval TranspOrHComp
DoHComp NamesT ReduceM Term
l NamesT ReduceM Term
bA NamesT ReduceM Term
phi NamesT ReduceM Term
u NamesT ReduceM Term
u0 = Term -> NamesT ReduceM Term
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
io) 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
io) 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
u0
            NamesT ReduceM Term
conId 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
io) 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
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => 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
<@> NamesT ReduceM Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (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
io)
                  NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin 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
<@> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT ReduceM Term
o -> Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tFace 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
io) 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
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => 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
<@> NamesT ReduceM Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (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
io)
                                                                   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
p NamesT ReduceM Term
io NamesT ReduceM Term
o)))
                  NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (TranspOrHComp
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
eval TranspOrHComp
cmd NamesT ReduceM Term
l
                                ([Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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 -> Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPathType 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
i) 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
i) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => 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
<@> 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
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
phi
                                ([Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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 -> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPath 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
i) 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
i)
                                                                                    NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => 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
<@> 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
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 -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
p NamesT ReduceM Term
i NamesT ReduceM Term
o)
                                      )
                                (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPath 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
iz) 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
iz) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => 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
<@> NamesT ReduceM Term
iz) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (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
iz)
                                                  NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
p0)
                      )
        Maybe QName
_ -> Maybe (Reduced a' Term) -> ReduceM (Maybe (Reduced a' Term))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Reduced a' Term) -> ReduceM (Maybe (Reduced a' Term)))
-> Maybe (Reduced a' Term) -> ReduceM (Maybe (Reduced a' Term))
forall a b. (a -> b) -> a -> b
$ Maybe (Reduced a' Term)
forall a. Maybe a
Nothing
    allComponents :: (IntervalView -> Term)
-> Term -> Term -> (Term -> Bool) -> ReduceM Bool
allComponents IntervalView -> Term
unview Term
phi Term
u Term -> Bool
p = do
            let
              boolToI :: Bool -> Term
boolToI Bool
b = if Bool
b then IntervalView -> Term
unview IntervalView
IOne else IntervalView -> Term
unview IntervalView
IZero
            [(Map Int Bool, [Term])]
as <- Term -> ReduceM [(Map Int Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Int Bool, [Term])]
decomposeInterval Term
phi
            [ReduceM Bool] -> ReduceM Bool
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Monad m) =>
f (m Bool) -> m Bool
andM ([ReduceM Bool] -> ReduceM Bool)
-> (((Map Int Bool, [Term]) -> ReduceM Bool) -> [ReduceM Bool])
-> ((Map Int Bool, [Term]) -> ReduceM Bool)
-> ReduceM Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Map Int Bool, [Term])]
-> ((Map Int Bool, [Term]) -> ReduceM Bool) -> [ReduceM Bool]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [(Map Int Bool, [Term])]
as (((Map Int Bool, [Term]) -> ReduceM Bool) -> ReduceM Bool)
-> ((Map Int Bool, [Term]) -> ReduceM Bool) -> ReduceM Bool
forall a b. (a -> b) -> a -> b
$ \ (Map Int Bool
bs,[Term]
ts) -> do
                 let u' :: Term
u' = [(Int, Term)] -> Substitution' Term
forall a. EndoSubst a => [(Int, a)] -> Substitution' a
listS (Map Int Term -> [(Int, Term)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map Int Term -> [(Int, Term)]) -> Map Int Term -> [(Int, Term)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Term) -> Map Int Bool -> Map Int Term
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Bool -> Term
boolToI Map Int Bool
bs) Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u
                 Blocked' Term Term
t <- Term -> ReduceM (Blocked' Term Term)
reduce2Lam Term
u'
                 Bool -> ReduceM Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> ReduceM Bool) -> Bool -> ReduceM Bool
forall a b. (a -> b) -> a -> b
$! Term -> Bool
p (Term -> Bool) -> Term -> Bool
forall a b. (a -> b) -> a -> b
$ Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term Term
t
    reduce2Lam :: Term -> ReduceM (Blocked' Term Term)
reduce2Lam Term
t = do
          Term
t <- Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
t
          case Term -> Abs Term
lam2Abs Term
t of
            Abs Term
t -> Abs Term
-> (Term -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term)
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs Term
t ((Term -> ReduceM (Blocked' Term Term))
 -> ReduceM (Blocked' Term Term))
-> (Term -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$ \ Term
t -> do
               Term
t <- Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
t
               case Term -> Abs Term
lam2Abs Term
t of
                 Abs Term
t -> Abs Term
-> (Term -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term)
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs Term
t Term -> ReduceM (Blocked' Term Term)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB'
         where
           lam2Abs :: Term -> Abs Term
lam2Abs (Lam ArgInfo
_ Abs Term
t) = Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
t Term -> Abs Term -> Abs Term
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Abs Term
t
           lam2Abs Term
t         = [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"y" (Int -> Term -> Term
forall a. Subst a => Int -> a -> a
raise Int
1 Term
t Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Int -> Term
var Int
0])
    allComponentsBack :: (IntervalView -> Term)
-> Term
-> Term
-> (Term -> a)
-> ReduceM ([a], [Maybe (Blocked' Term Term, Map Int 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 ([Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"i" (ArgInfo -> Abs Term -> Term
Lam (Relevance -> ArgInfo -> ArgInfo
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant ArgInfo
defaultArgInfo) ([Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"o" Term
t)))
            [(Map Int Bool, [Term])]
as <- Term -> ReduceM [(Map Int Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Int Bool, [Term])]
decomposeInterval Term
phi
            ([a]
flags,[Maybe (Blocked' Term Term, Map Int Bool)]
t_alphas) <- ([(a, Maybe (Blocked' Term Term, Map Int Bool))]
 -> ([a], [Maybe (Blocked' Term Term, Map Int Bool)]))
-> ReduceM [(a, Maybe (Blocked' Term Term, Map Int Bool))]
-> ReduceM ([a], [Maybe (Blocked' Term Term, Map Int Bool)])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, Maybe (Blocked' Term Term, Map Int Bool))]
-> ([a], [Maybe (Blocked' Term Term, Map Int Bool)])
forall a b. [(a, b)] -> ([a], [b])
unzip (ReduceM [(a, Maybe (Blocked' Term Term, Map Int Bool))]
 -> ReduceM ([a], [Maybe (Blocked' Term Term, Map Int Bool)]))
-> (((Map Int Bool, [Term])
     -> ReduceM (a, Maybe (Blocked' Term Term, Map Int Bool)))
    -> ReduceM [(a, Maybe (Blocked' Term Term, Map Int Bool))])
-> ((Map Int Bool, [Term])
    -> ReduceM (a, Maybe (Blocked' Term Term, Map Int Bool)))
-> ReduceM ([a], [Maybe (Blocked' Term Term, Map Int Bool)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(Map Int Bool, [Term])]
-> ((Map Int Bool, [Term])
    -> ReduceM (a, Maybe (Blocked' Term Term, Map Int Bool)))
-> ReduceM [(a, Maybe (Blocked' Term Term, Map Int Bool))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Map Int Bool, [Term])]
as (((Map Int Bool, [Term])
  -> ReduceM (a, Maybe (Blocked' Term Term, Map Int Bool)))
 -> ReduceM ([a], [Maybe (Blocked' Term Term, Map Int Bool)]))
-> ((Map Int Bool, [Term])
    -> ReduceM (a, Maybe (Blocked' Term Term, Map Int Bool)))
-> ReduceM ([a], [Maybe (Blocked' Term Term, Map Int Bool)])
forall a b. (a -> b) -> a -> b
$ \ (Map Int Bool
bs,[Term]
ts) -> do
                 let u' :: Term
u' = [(Int, Term)] -> Substitution' Term
forall a. EndoSubst a => [(Int, a)] -> Substitution' a
listS [(Int, Term)]
bs' Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u
                     bs' :: [(Int, Term)]
bs' = (Map Int Term -> [(Int, Term)]
forall k a. Map k a -> [(k, a)]
Map.toAscList (Map Int Term -> [(Int, Term)]) -> Map Int Term -> [(Int, Term)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Term) -> Map Int Bool -> Map Int Term
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Bool -> Term
boolToI Map Int Bool
bs)
                     -- Γ₁, i : I, Γ₂, j : I, Γ₃  ⊢ weaken : Γ₁, Γ₂, Γ₃   for bs' = [(j,_),(i,_)]
                     -- ordering of "j,i,.." matters.
                 let weaken :: Substitution' Term
weaken = (Int -> Substitution' Term -> Substitution' Term)
-> Substitution' Term -> [Int] -> Substitution' Term
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Int
j Substitution' Term
s -> Substitution' Term
s Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Int -> Int -> Substitution' Term
forall a. Int -> Int -> Substitution' a
raiseFromS Int
j Int
1) Substitution' Term
forall a. Substitution' a
idS (((Int, Term) -> Int) -> [(Int, Term)] -> [Int]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Term) -> Int
forall a b. (a, b) -> a
fst [(Int, Term)]
bs')
                 Blocked' Term Term
t <- Term -> ReduceM (Blocked' Term Term)
reduce2Lam Term
u'
                 (a, Maybe (Blocked' Term Term, Map Int Bool))
-> ReduceM (a, Maybe (Blocked' Term Term, Map Int Bool))
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Maybe (Blocked' Term Term, Map Int Bool))
 -> ReduceM (a, Maybe (Blocked' Term Term, Map Int Bool)))
-> (a, Maybe (Blocked' Term Term, Map Int Bool))
-> ReduceM (a, Maybe (Blocked' Term Term, Map Int Bool))
forall a b. (a -> b) -> a -> b
$ (Term -> a
p (Term -> a) -> Term -> a
forall a b. (a -> b) -> a -> b
$ Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term Term
t, [(Blocked' Term Term, Map Int Bool)]
-> Maybe (Blocked' Term Term, Map Int Bool)
forall a. [a] -> Maybe a
listToMaybe [ (Substitution' Term
Substitution' (SubstArg (Blocked' Term Term))
weaken Substitution' (SubstArg (Blocked' Term Term))
-> Blocked' Term Term -> Blocked' Term Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` (Term -> Term
lamlam (Term -> Term) -> Blocked' Term Term -> Blocked' Term Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked' Term Term
t),Map Int Bool
bs) | [Term] -> Bool
forall a. Null a => a -> Bool
null [Term]
ts ])
            ([a], [Maybe (Blocked' Term Term, Map Int Bool)])
-> ReduceM ([a], [Maybe (Blocked' Term Term, Map Int Bool)])
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], [Maybe (Blocked' Term Term, Map Int Bool)])
 -> ReduceM ([a], [Maybe (Blocked' Term Term, Map Int Bool)]))
-> ([a], [Maybe (Blocked' Term Term, Map Int Bool)])
-> ReduceM ([a], [Maybe (Blocked' Term Term, Map Int Bool)])
forall a b. (a -> b) -> a -> b
$ ([a]
flags,[Maybe (Blocked' Term Term, Map Int Bool)]
t_alphas)
    compData :: Bool
-> p
-> TranspOrHComp
-> FamilyOrNot (Arg Term)
-> FamilyOrNot Args
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
compData Bool
False p
_ cmd :: TranspOrHComp
cmd@TranspOrHComp
DoHComp (IsNot Arg Term
l) (IsNot Args
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi (Just Arg Term
u) Arg Term
a0 = do
      let getTermLocal :: [Char] -> ReduceM Term
getTermLocal = [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm ([Char] -> [Char] -> ReduceM Term)
-> [Char] -> [Char] -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for data types"

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

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

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

      Maybe Term
-> Maybe ConHead
-> Blocked (Arg Term)
-> (ConHead
    -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
sameConHeadBack (Term -> Maybe Term
isLit Term
a0) (Term -> Maybe ConHead
isCon Term
a0) Blocked (Arg Term)
su ((ConHead
  -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> (ConHead
    -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ \ ConHead
h Blocked (Arg Term)
su -> do
            let u :: Term
u = Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term)
-> (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Term) -> Blocked (Arg Term) -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
su
            Constructor{ conComp :: Defn -> CompKit
conComp = CompKit
cm } <- Definition -> Defn
theDef (Definition -> Defn) -> ReduceM Definition -> ReduceM Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
h)
            case CompKit -> Maybe QName
nameOfHComp CompKit
cm of
              Just QName
hcompD -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
hcompD [] Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply`
                                          (Args
ps Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> Args
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 Bool
_     p
0 TranspOrHComp
DoTransp (IsFam Arg Term
l) (IsFam Args
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 Bool
isHIT p
_ cmd :: TranspOrHComp
cmd@TranspOrHComp
DoTransp (IsFam Arg Term
l) (IsFam Args
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi Maybe (Arg Term)
Nothing Arg Term
a0 = do
      let getTermLocal :: [Char] -> ReduceM Term
getTermLocal = [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm ([Char] -> [Char] -> ReduceM Term)
-> [Char] -> [Char] -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" for data types"
      let sc :: Blocked (Arg Term)
sc = FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
fsc
      Maybe QName
mhcompName <- [Char] -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getName' [Char]
builtinHComp
      Term -> Term
constrForm <- do
        Maybe Term
mz <- [Char] -> ReduceM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe Term)
getTerm' [Char]
builtinZero
        Maybe Term
ms <- [Char] -> ReduceM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe Term)
getTerm' [Char]
builtinSuc
        (Term -> Term) -> ReduceM (Term -> Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Term) -> ReduceM (Term -> Term))
-> (Term -> Term) -> ReduceM (Term -> Term)
forall a b. (a -> b) -> a -> b
$ \ Term
t -> Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
t (Maybe Term -> Maybe Term -> Term -> Maybe Term
forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> Term -> m Term
constructorForm' Maybe Term
mz Maybe Term
ms Term
t)
      Blocked (Arg Term)
sa0 <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
a0
      let f :: Blocked' t (Arg c) -> c
f = Arg c -> c
forall e. Arg e -> e
unArg (Arg c -> c)
-> (Blocked' t (Arg c) -> Arg c) -> Blocked' t (Arg c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg c) -> Arg c
forall t a. Blocked' t a -> a
ignoreBlocking
          phi :: Term
phi = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sphi
          a0 :: Term
a0 = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sa0
          noRed :: ReduceM (Reduced MaybeReducedArgs Term)
noRed = Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
 -> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
l,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sc, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sa0]
      let lam_i :: Term -> Term
lam_i = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Term -> Abs Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"i"
      case Term -> Term
constrForm Term
a0 of
        Con ConHead
h ConInfo
_ [Elim]
args -> do
          Constructor{ conComp :: Defn -> CompKit
conComp = CompKit
cm } <- Definition -> Defn
theDef (Definition -> Defn) -> ReduceM Definition -> ReduceM Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
h)
          case CompKit -> Maybe QName
nameOfTransp CompKit
cm of
              Just QName
transpD -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
transpD [] Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply`
                                          ((Arg Term -> Arg Term) -> Args -> Args
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> Arg Term -> Arg Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) Args
ps Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> Args
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 Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es -> do
           let bC :: Arg Term
bC = Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc
           Term
hcomp <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinHComp
           Term
transp <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinTrans
           Term
io <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIOne
           Term
iz <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIZero
           Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
             [NamesT ReduceM Term
l,NamesT ReduceM Term
bC,NamesT ReduceM Term
phi,NamesT ReduceM Term
psi,NamesT ReduceM Term
u,NamesT ReduceM Term
u0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Args -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
bC,Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi,Arg Term
psi,Arg Term
u,Arg Term
u0]
             -- hcomp (sc 1) [psi |-> transp sc phi u] (transp sc phi u0)
             Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
hcomp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bC NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
psi
                   NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT ReduceM Term
j -> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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 (f :: * -> *) a. Applicative f => a -> f a
pure Term
transp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
bC NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o))
                   NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
transp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
bC NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u0)
        Term
_ -> ReduceM (Reduced MaybeReducedArgs Term)
noRed
    compData Bool
_ p
_ TranspOrHComp
_ FamilyOrNot (Arg Term)
_ FamilyOrNot Args
_ Blocked (FamilyOrNot (Arg Term))
_ Blocked (Arg Term)
_ Maybe (Arg Term)
_ Arg Term
_ = ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

primComp :: TCM PrimitiveImpl
primComp :: TCM PrimitiveImpl
primComp = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t    <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"A" ([Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM 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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i))) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
          [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT TCM Term
i -> [Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
phi ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i) (NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i)) NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
          (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT TCM 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 TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT TCM 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 TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT TCM 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 TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT TCM Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne))
  Term
one <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
  Term
io  <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 ((Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term))
 -> PrimFun)
-> (Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ Args
ts Int
nelims -> do
    case Args
ts of
      [Arg Term
l,Arg Term
c,Arg Term
phi,Arg Term
u,Arg Term
a0] -> do
        Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
        IntervalView
vphi <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi
        case IntervalView
vphi of
          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 -> Args -> Term
forall t. Apply t => t -> Args -> 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
            let getTermLocal :: [Char] -> ReduceM Term
getTermLocal = [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm ([Char] -> [Char] -> ReduceM Term)
-> [Char] -> [Char] -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ [Char]
builtinComp
            Term
tIMax <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIMax
            Term
tINeg <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinINeg
            Term
tHComp <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinHComp
            Term
tTrans <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinTrans
            Term
iz      <- [Char] -> ReduceM Term
getTermLocal [Char]
builtinIZero
            Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
              NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp <- do
                let imax :: NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
imax NamesT ReduceM Term
i NamesT ReduceM Term
j = Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax 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
                    forward :: NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forward NamesT ReduceM Term
la NamesT ReduceM Term
bA NamesT ReduceM Term
r NamesT ReduceM Term
u = Term -> NamesT ReduceM Term
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
<#> ([Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
la 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
`imax` NamesT ReduceM Term
r))
                                                    NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> ([Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"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
`imax` NamesT ReduceM Term
r))
                                                    NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
r
                                                    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
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term
 -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT ReduceM Term
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term
  -> NamesT ReduceM Term)
 -> NamesT
      ReduceM
      (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
    -> NamesT ReduceM Term
    -> NamesT ReduceM Term)
-> NamesT
     ReduceM
     (NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term
      -> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
la NamesT ReduceM Term
bA NamesT ReduceM Term
phi NamesT ReduceM Term
u NamesT ReduceM Term
u0 ->
                  Term -> NamesT ReduceM Term
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
la NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
phi
                              NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT ReduceM Term
i -> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"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 ->
                                      NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forward NamesT ReduceM Term
la NamesT ReduceM Term
bA NamesT ReduceM Term
i (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
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
forward NamesT ReduceM Term
la NamesT ReduceM Term
bA (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT ReduceM Term
u0

              [NamesT ReduceM Term
l,NamesT ReduceM Term
c,NamesT ReduceM Term
phi,NamesT ReduceM Term
u,NamesT ReduceM Term
a0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Args -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
c,Arg Term
phi,Arg Term
u,Arg Term
a0]
              NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp NamesT ReduceM Term
l NamesT ReduceM Term
c NamesT ReduceM Term
phi NamesT ReduceM Term
u NamesT ReduceM Term
a0

      Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__


prim_glueU' :: TCM PrimitiveImpl
prim_glueU' :: TCM PrimitiveImpl
prim_glueU' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term
la ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"T" ([Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> [Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> 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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"A" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
φ NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a -> do
       let bA :: NamesT TCM Term
bA = (TCMT IO Term -> NamesT TCM 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
primSubOut NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a)
       [Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ (\ NamesT TCM Term
o -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la (NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT TCM Term
o))
         NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la NamesT TCM Term
bA)
         NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la (TCMT IO Term -> NamesT TCM 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
primHComp NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA))
  Term -> IntervalView
view <- TCMT IO (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
  Term
one <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
6 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \Args
ts ->
    case Args
ts of
      [Arg Term
la,Arg Term
phi,Arg Term
bT,Arg Term
bA,Arg Term
t,Arg Term
a] -> do
       Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
       case Term -> IntervalView
view (Term -> IntervalView) -> Term -> IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
         IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
t Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
one]
         IntervalView
_    -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
la] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ (Arg Term -> MaybeReduced (Arg Term)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
bA,Arg Term
t,Arg Term
a])
      Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

prim_unglueU' :: TCM PrimitiveImpl
prim_unglueU' :: TCM PrimitiveImpl
prim_unglueU' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term
la ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"T" ([Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> [Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> 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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"A" (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
φ NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a -> do
       let bA :: NamesT TCM Term
bA = (TCMT IO Term -> NamesT TCM 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
primSubOut NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a)
       NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la (TCMT IO Term -> NamesT TCM 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
primHComp NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA)
         NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la NamesT TCM Term
bA)
  Term -> IntervalView
view <- TCMT IO (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
  Term
one <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
  Maybe QName
mglueU <- [Char] -> TCMT IO (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtin_glueU
  Maybe QName
mtransp <- [Char] -> TCMT IO (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinTrans
  Maybe QName
mHCompU <- [Char] -> TCMT IO (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinHComp
  let mhcomp :: Maybe QName
mhcomp = Maybe QName
mHCompU
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \Args
ts ->
    case Args
ts of
      [Arg Term
la,Arg Term
phi,Arg Term
bT,Arg Term
bA,Arg Term
b] -> do
       Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
       case Term -> IntervalView
view (Term -> IntervalView) -> Term -> IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
         IntervalView
IOne -> do
           Term
tTransp <- [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtin_unglueU [Char]
builtinTrans
           Term
iNeg    <- [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtin_unglueU [Char]
builtinINeg
           Term
iZ      <- [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtin_unglueU [Char]
builtinIZero
           Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
             [NamesT ReduceM Term
la,NamesT ReduceM Term
bT,NamesT ReduceM Term
b] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Args -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
la,Arg Term
bT,Arg Term
b]
             Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT ReduceM Term
_ -> NamesT ReduceM Term
la)
                          NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT ReduceM Term
i -> NamesT ReduceM Term
bT NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iNeg 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
<..> Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
one)
                          NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iZ
                          NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
b
         IntervalView
_    -> do
            Blocked (Arg Term)
sb <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
b
            let fallback :: Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback Blocked (Arg Term)
sbA = Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
la] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ (Arg Term -> MaybeReduced (Arg Term)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
bA] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sb])
            case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sb of
               Def QName
q [Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
a]
                     | 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
mglueU -> 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
a
               Def QName
q [Apply Arg Term
l,Apply Arg Term
bA,Apply Arg Term
r,Apply Arg Term
u0]
                     | 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
mtransp -> do
                     Blocked (Arg Term)
sbA <- Arg Term -> ReduceM (Blocked (Arg Term))
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Arg Term
bA
                     case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sbA of
                       Lam ArgInfo
_ Abs Term
t -> do
                         Blocked' Term Term
st <- 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)
                         case Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term Term
st of
                           Def QName
h [Elim]
es | Just [Arg Term
la,Arg Term
_,Arg Term
phi,Arg Term
bT,Arg Term
bA] <- [Elim] -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, QName -> Maybe QName
forall a. a -> Maybe a
Just QName
h Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mHCompU -> do
                             Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (Maybe Term -> Term)
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (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
=<< TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
compHCompU TranspOrHComp
DoTransp Arg Term
r Maybe (Arg Term)
forall a. Maybe a
Nothing Arg Term
u0 ((Arg Term, Arg Term, Arg Term, Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
forall a. a -> FamilyOrNot a
IsFam (Arg Term
la,Arg Term
phi,Arg Term
bT,Arg Term
bA)) TermPosition
Eliminated
                           Term
_ -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback (Blocked' Term Term
st Blocked' Term Term -> Blocked (Arg Term) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Blocked (Arg Term)
sbA)
                       Term
_  -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback Blocked (Arg Term)
sbA
               Def QName
q [Apply Arg Term
l,Apply Arg Term
bA,Apply Arg Term
r,Apply Arg Term
u,Apply Arg Term
u0]
                     | 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 -> do
                     Blocked (Arg Term)
sbA <- Arg Term -> ReduceM (Blocked (Arg Term))
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Arg Term
bA
                     case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sbA of
                       Def QName
h [Elim]
es | Just [Arg Term
la,Arg Term
_,Arg Term
phi,Arg Term
bT,Arg Term
bA] <- [Elim] -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, QName -> Maybe QName
forall a. a -> Maybe a
Just QName
h Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mHCompU -> do
                         Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (Maybe Term -> Term)
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (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
=<< TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
compHCompU TranspOrHComp
DoHComp Arg Term
r (Arg Term -> Maybe (Arg Term)
forall a. a -> Maybe a
Just Arg Term
u) Arg Term
u0 ((Arg Term, Arg Term, Arg Term, Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
forall a. a -> FamilyOrNot a
IsNot (Arg Term
la,Arg Term
phi,Arg Term
bT,Arg Term
bA)) TermPosition
Eliminated
                       Term
_ -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback Blocked (Arg Term)
sbA
               Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
la] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ (Arg Term -> MaybeReduced (Arg Term)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
bA] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sb])
      Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__


primGlue' :: TCM PrimitiveImpl
primGlue' :: TCM PrimitiveImpl
primGlue' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CFull [Char]
""
  -- Glue' : ∀ {l} (A : Set l) → ∀ φ → (T : Partial (Set a) φ) (f : (PartialP φ \ o → (T o) -> A))
  --            ([f] : PartialP φ \ o → isEquiv (T o) A (f o)) → Set l
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term
la ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"lb" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
lb ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"T" ([Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) (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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
lb)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
       [Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ (\ NamesT TCM Term
o -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT TCM 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
primLevelMax NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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
primEquiv NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
o) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a)
       NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
lb))
  Term -> IntervalView
view <- TCMT IO (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
  Term
one <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
6 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \Args
ts ->
    case Args
ts of
     [Arg Term
la,Arg Term
lb,Arg Term
a,Arg Term
phi,Arg Term
t,Arg Term
e] -> do
       Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
       case Term -> IntervalView
view (Term -> IntervalView) -> Term -> IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
         IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
t Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
one]
         IntervalView
_    -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
la,Arg Term
lb,Arg Term
a] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ (Arg Term -> MaybeReduced (Arg Term)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
t,Arg Term
e])
     Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

prim_glue' :: TCM PrimitiveImpl
prim_glue' :: TCM PrimitiveImpl
prim_glue' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CFull [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term
la ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"lb" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
lb ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"T" ([Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o ->  NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) (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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
lb)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"e" ([Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT TCM 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
primLevelMax NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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
primEquiv NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
o) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
e ->
       [Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ (\ NamesT TCM Term
o -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
lb (NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
o)) NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la NamesT TCM Term
a NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
lb (TCMT IO Term -> NamesT TCM 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
primGlue NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
e)))
  Term -> IntervalView
view <- TCMT IO (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
  Term
one <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
8 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \Args
ts ->
    case Args
ts of
      [Arg Term
la,Arg Term
lb,Arg Term
bA,Arg Term
phi,Arg Term
bT,Arg Term
e,Arg Term
t,Arg Term
a] -> do
       Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
       case Term -> IntervalView
view (Term -> IntervalView) -> Term -> IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
         IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
t Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
one]
         IntervalView
_    -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
la,Arg Term
lb,Arg Term
bA] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ (Arg Term -> MaybeReduced (Arg Term)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
e,Arg Term
t,Arg Term
a])
      Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

prim_unglue' :: TCM PrimitiveImpl
prim_unglue' :: TCM PrimitiveImpl
prim_unglue' = do
  Cubical -> [Char] -> TCM ()
requireCubical Cubical
CFull [Char]
""
  Type
t <- Names -> NamesT TCM Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM Type -> TCMT IO Type)
-> NamesT TCM Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term
la ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"lb" (NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Functor m => m Term -> m Type
el (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
lb ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"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 TCM Term -> NamesT TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" NamesT TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"T" ([Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o ->  NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT TCM 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 TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) (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 TCM Term -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
lb)) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
       [Char]
-> NamesT TCM Type
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"e" ([Char]
-> NamesT TCM Term
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" NamesT TCM Term
φ ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT TCM 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
primLevelMax NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT TCM 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
primEquiv NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
o) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a) ((NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type)
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
e ->
       (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
lb (TCMT IO Term -> NamesT TCM 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
primGlue NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
t NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
e)) NamesT TCM Type -> NamesT TCM Type -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la NamesT TCM Term
a)
  Term -> IntervalView
view <- TCMT IO (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
  Term
one <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
  Maybe QName
mGlue <- [Char] -> TCMT IO (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinGlue
  Maybe QName
mglue <- [Char] -> TCMT IO (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtin_glue
  Maybe QName
mtransp <- [Char] -> TCMT IO (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinTrans
  Maybe QName
mhcomp <- [Char] -> TCMT IO (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinHComp
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
7 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \Args
ts ->
    case Args
ts of
      [Arg Term
la,Arg Term
lb,Arg Term
bA,Arg Term
phi,Arg Term
bT,Arg Term
e,Arg Term
b] -> do
       Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
       case Term -> IntervalView
view (Term -> IntervalView) -> Term -> IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
         IntervalView
IOne -> do
           let argOne :: Arg Term
argOne = Relevance -> Arg Term -> Arg Term
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant (Arg Term -> Arg Term) -> Arg Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Term -> Arg Term
forall e. e -> Arg e
argN Term
one
           Term
tEFun <- [Char] -> [Char] -> ReduceM Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtin_unglue [Char]
builtinEquivFun
           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
$ Term
tEFun Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Arg Term
lb,Arg Term
la,Term -> Arg Term
forall e. e -> Arg e
argH (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
bT Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Arg Term
argOne],Arg Term
bA, Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
e Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Arg Term
argOne],Arg Term
b]
         IntervalView
_    -> do
            Blocked (Arg Term)
sb <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
b
            let fallback :: Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback Blocked (Arg Term)
sbA = Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
la,Arg Term
lb] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ (Blocked (Arg Term) -> MaybeReduced (Arg Term))
-> [Blocked (Arg Term)] -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced [Blocked (Arg Term)
sbA, Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ (Arg Term -> MaybeReduced (Arg Term)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
e] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sb])
            case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sb of
               Def QName
q [Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
_,Apply Arg Term
a]
                     | 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 -> 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
a
               Def QName
q [Apply Arg Term
l,Apply Arg Term
bA,Apply Arg Term
r,Apply Arg Term
u0]
                     | 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
mtransp -> do
                 Blocked (Arg Term)
sbA <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
bA
                 case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sbA of
                   Lam ArgInfo
_ Abs Term
t -> do
                     Blocked' Term Term
st <- 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)
                     case Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term Term
st of
                       Def QName
g [Elim]
es | Just [Arg Term
la',Arg Term
lb',Arg Term
bA',Arg Term
phi',Arg Term
bT',Arg Term
e'] <- [Elim] -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, QName -> Maybe QName
forall a. a -> Maybe a
Just QName
g Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mGlue -> do
                           Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (Maybe Term -> Term)
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (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
=<< TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
compGlue TranspOrHComp
DoTransp Arg Term
r Maybe (Arg Term)
forall a. Maybe a
Nothing Arg Term
u0 ((Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
forall a. a -> FamilyOrNot a
IsFam (Arg Term
la',Arg Term
lb',Arg Term
bA',Arg Term
phi',Arg Term
bT',Arg Term
e')) TermPosition
Eliminated
                       Term
_ -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback (Blocked' Term Term
st Blocked' Term Term -> Blocked (Arg Term) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Blocked (Arg Term)
sbA)
                   Term
_ -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback Blocked (Arg Term)
sbA
               Def QName
q [Apply Arg Term
l,Apply Arg Term
bA,Apply Arg Term
r,Apply Arg Term
u,Apply Arg Term
u0]
                     | 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 -> do
                 Blocked (Arg Term)
sbA <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
bA
                 case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sbA of
                   Def QName
g [Elim]
es | Just [Arg Term
la',Arg Term
lb',Arg Term
bA',Arg Term
phi',Arg Term
bT',Arg Term
e'] <- [Elim] -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, QName -> Maybe QName
forall a. a -> Maybe a
Just QName
g Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mGlue -> do
                       Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (Maybe Term -> Term)
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (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
=<< TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
TranspOrHComp
-> Arg Term
-> Maybe (Arg Term)
-> Arg Term
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
compGlue TranspOrHComp
DoHComp Arg Term
r (Arg Term -> Maybe (Arg Term)
forall a. a -> Maybe a
Just Arg Term
u) Arg Term
u0 ((Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> FamilyOrNot
     (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
forall a. a -> FamilyOrNot a
IsNot (Arg Term
la',Arg Term
lb',Arg Term
bA',Arg Term
phi',Arg Term
bT',Arg Term
e')) TermPosition
Eliminated
                   Term
_ -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback Blocked (Arg Term)
sbA
               Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (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)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
la,Arg Term
lb,Arg Term
bA] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ (Arg Term -> MaybeReduced (Arg Term)) -> Args -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
e] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sb])
      Args
_ -> 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 -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
  Type
t <- (TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType TCMT IO Type -> TCMT IO Type -> TCMT IO Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType) TCMT IO Type -> TCMT IO Type -> TCMT IO Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
  PrimitiveImpl -> TCM PrimitiveImpl
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Int
1 ((Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun)
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term)) -> PrimFun
forall a b. (a -> b) -> a -> b
$ \Args
ts -> case Args
ts of
    [Arg Term
phi] -> do
      Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
      case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
        Lam ArgInfo
_ Abs Term
t -> do
          Abs Term
t <- Abs Term -> ReduceM (Abs Term)
forall t. Reduce t => t -> ReduceM t
reduce' Abs Term
t
          case Abs Term
t of
            NoAbs [Char]
_ Term
t -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
t
            Abs [Char]
_ 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 (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 (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])
    Args
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
  where
    toFaceMapsPrim :: Term -> m (Maybe Term)
toFaceMapsPrim Term
t = do
      Term -> IntervalView
view <- m (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
      IntervalView -> Term
unview <- m (IntervalView -> Term)
forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
      [(Map Int Bool, [Term])]
us' <- Term -> m [(Map Int Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Int Bool, [Term])]
decomposeInterval Term
t
      Term
fr <- [Char] -> [Char] -> m Term
forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtinFaceForall [Char]
builtinFaceForall
      let v :: IntervalView
v = Term -> IntervalView
view Term
t
          us :: [[Either (Int, Bool) Term]]
us =
            [ ((Int, Bool) -> Either (Int, Bool) Term)
-> [(Int, Bool)] -> [Either (Int, Bool) Term]
forall a b. (a -> b) -> [a] -> [b]
map (Int, Bool) -> Either (Int, Bool) Term
forall a b. a -> Either a b
Left (Map Int Bool -> [(Int, Bool)]
forall k a. Map k a -> [(k, a)]
Map.toList Map Int Bool
bsm) [Either (Int, Bool) Term]
-> [Either (Int, Bool) Term] -> [Either (Int, Bool) Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Either (Int, Bool) Term)
-> [Term] -> [Either (Int, Bool) Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Either (Int, Bool) Term
forall a b. b -> Either a b
Right [Term]
ts
              | (Map Int Bool
bsm, [Term]
ts) <- [(Map Int Bool, [Term])]
us',
                Int
0 Int -> Map Int Bool -> Bool
forall k a. Ord k => k -> Map k a -> Bool
`Map.notMember` Map Int Bool
bsm
            ]
          fm :: (Int, Bool) -> Term
fm (Int
i, Bool
b) = if Bool
b then Int -> Term
var (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1) else IntervalView -> Term
unview (Arg Term -> IntervalView
INeg (Term -> Arg Term
forall e. e -> Arg e
argN (Int -> Term
var (Int -> Term) -> Int -> Term
forall a b. (a -> b) -> a -> b
$ Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)))
          ffr :: Term -> Term
ffr Term
t = Term
fr Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"i" Term
t]
          r :: Maybe Term
r =
            Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> Term -> Maybe Term
forall a b. (a -> b) -> a -> b
$
              ([Either (Int, Bool) Term] -> Term -> Term)
-> Term -> [[Either (Int, Bool) Term]] -> Term
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                ( (\Term
x Term
r -> IntervalView -> Term
unview (Arg Term -> Arg Term -> IntervalView
IMax (Term -> Arg Term
forall e. e -> Arg e
argN Term
x) (Term -> Arg Term
forall e. e -> Arg e
argN Term
r)))
                    (Term -> Term -> Term)
-> ([Either (Int, Bool) Term] -> Term)
-> [Either (Int, Bool) Term]
-> Term
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Either (Int, Bool) Term -> Term -> Term)
-> Term -> [Either (Int, Bool) Term] -> Term
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
                      (\Either (Int, Bool) Term
x Term
r -> IntervalView -> Term
unview (Arg Term -> Arg Term -> IntervalView
IMin (Term -> Arg Term
forall e. e -> Arg e
argN (((Int, Bool) -> Term)
-> (Term -> Term) -> Either (Int, Bool) Term -> Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Int, Bool) -> Term
fm Term -> Term
ffr Either (Int, Bool) Term
x)) (Term -> Arg Term
forall e. e -> Arg e
argN Term
r)))
                      (IntervalView -> Term
unview IntervalView
IOne)
                )
                (IntervalView -> Term
unview IntervalView
IZero)
                [[Either (Int, Bool) Term]]
us
      --   traceSLn "cube.forall" 20 (unlines [show v, show us', show us, show r]) $
      Maybe Term -> m (Maybe Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Term -> m (Maybe Term)) -> Maybe Term -> m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ case [(Map Int Bool, [Term])]
us' of
        [(Map Int Bool
m, [Term
_])] | Map Int Bool -> Bool
forall k a. Map k a -> Bool
Map.null Map Int Bool
m -> Maybe Term
forall a. Maybe a
Nothing
        [(Map Int Bool, [Term])]
v -> Maybe Term
r

decomposeInterval :: HasBuiltins m => Term -> m [(Map Int Bool,[Term])]
decomposeInterval :: forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Int Bool, [Term])]
decomposeInterval Term
t = do
  [(Map Int (Set Bool), [Term])]
xs <- Term -> m [(Map Int (Set Bool), [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Int (Set Bool), [Term])]
decomposeInterval' Term
t
  let isConsistent :: Map k (Set a) -> Bool
isConsistent Map k (Set a)
xs = (Set a -> Bool) -> [Set a] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ Set a
xs -> Set a -> Int
forall a. Set a -> Int
Set.size Set a
xs Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1) ([Set a] -> Bool)
-> (Map k (Set a) -> [Set a]) -> Map k (Set a) -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Map k (Set a) -> [Set a]
forall k a. Map k a -> [a]
Map.elems (Map k (Set a) -> Bool) -> Map k (Set a) -> Bool
forall a b. (a -> b) -> a -> b
$ Map k (Set a)
xs  -- optimize by not doing generate + filter
  [(Map Int Bool, [Term])] -> m [(Map Int Bool, [Term])]
forall (m :: * -> *) a. Monad m => a -> m a
return [ ((Set Bool -> Bool) -> Map Int (Set Bool) -> Map Int Bool
forall a b k. (a -> b) -> Map k a -> Map k b
Map.map ([Bool] -> Bool
forall a. [a] -> a
head ([Bool] -> Bool) -> (Set Bool -> [Bool]) -> Set Bool -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Set Bool -> [Bool]
forall a. Set a -> [a]
Set.toList) Map Int (Set Bool)
bsm,[Term]
ts)
            | (Map Int (Set Bool)
bsm,[Term]
ts) <- [(Map Int (Set Bool), [Term])]
xs
            , Map Int (Set Bool) -> Bool
forall {k} {a}. Map k (Set a) -> Bool
isConsistent Map Int (Set Bool)
bsm
            ]

decomposeInterval' :: HasBuiltins m => Term -> m [(Map Int (Set Bool),[Term])]
decomposeInterval' :: forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Int (Set Bool), [Term])]
decomposeInterval' Term
t = do
     Term -> IntervalView
view   <- m (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
     IntervalView -> Term
unview <- m (IntervalView -> Term)
forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
     let f :: IntervalView -> [[Either (Int,Bool) Term]]
         -- TODO handle primIMinDep
         -- TODO? handle forall
         f :: IntervalView -> [[Either (Int, Bool) Term]]
f IntervalView
IZero = [[Either (Int, Bool) Term]]
forall (m :: * -> *) a. MonadPlus m => m a
mzero
         f IntervalView
IOne  = [Either (Int, Bool) Term] -> [[Either (Int, Bool) Term]]
forall (m :: * -> *) a. Monad m => a -> m a
return []
         f (IMin Arg Term
x Arg Term
y) = do [Either (Int, Bool) Term]
xs <- (IntervalView -> [[Either (Int, Bool) Term]]
f (IntervalView -> [[Either (Int, Bool) Term]])
-> (Arg Term -> IntervalView)
-> Arg Term
-> [[Either (Int, Bool) Term]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> IntervalView
view (Term -> IntervalView)
-> (Arg Term -> Term) -> Arg Term -> IntervalView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) Arg Term
x; [Either (Int, Bool) Term]
ys <- (IntervalView -> [[Either (Int, Bool) Term]]
f (IntervalView -> [[Either (Int, Bool) Term]])
-> (Arg Term -> IntervalView)
-> Arg Term
-> [[Either (Int, Bool) Term]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> IntervalView
view (Term -> IntervalView)
-> (Arg Term -> Term) -> Arg Term -> IntervalView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) Arg Term
y; [Either (Int, Bool) Term] -> [[Either (Int, Bool) Term]]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Either (Int, Bool) Term]
xs [Either (Int, Bool) Term]
-> [Either (Int, Bool) Term] -> [Either (Int, Bool) Term]
forall a. [a] -> [a] -> [a]
++ [Either (Int, Bool) Term]
ys)
         f (IMax Arg Term
x Arg Term
y) = [[[Either (Int, Bool) Term]]] -> [[Either (Int, Bool) Term]]
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum ([[[Either (Int, Bool) Term]]] -> [[Either (Int, Bool) Term]])
-> [[[Either (Int, Bool) Term]]] -> [[Either (Int, Bool) Term]]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> [[Either (Int, Bool) Term]])
-> Args -> [[[Either (Int, Bool) Term]]]
forall a b. (a -> b) -> [a] -> [b]
map (IntervalView -> [[Either (Int, Bool) Term]]
f (IntervalView -> [[Either (Int, Bool) Term]])
-> (Arg Term -> IntervalView)
-> Arg Term
-> [[Either (Int, Bool) Term]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> IntervalView
view (Term -> IntervalView)
-> (Arg Term -> Term) -> Arg Term -> IntervalView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
x,Arg Term
y]
         f (INeg Arg Term
x)   = (Either (Int, Bool) Term -> Either (Int, Bool) Term)
-> [Either (Int, Bool) Term] -> [Either (Int, Bool) Term]
forall a b. (a -> b) -> [a] -> [b]
map (((Int, Bool) -> Either (Int, Bool) Term)
-> (Term -> Either (Int, Bool) Term)
-> Either (Int, Bool) Term
-> Either (Int, Bool) Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ (Int
x,Bool
y) -> (Int, Bool) -> Either (Int, Bool) Term
forall a b. a -> Either a b
Left (Int
x,Bool -> Bool
not Bool
y)) (Term -> Either (Int, Bool) Term
forall a b. b -> Either a b
Right (Term -> Either (Int, Bool) Term)
-> (Term -> Term) -> Term -> Either (Int, Bool) Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntervalView -> Term
unview (IntervalView -> Term) -> (Term -> IntervalView) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> IntervalView
INeg (Arg Term -> IntervalView)
-> (Term -> Arg Term) -> Term -> IntervalView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argN)) ([Either (Int, Bool) Term] -> [Either (Int, Bool) Term])
-> [[Either (Int, Bool) Term]] -> [[Either (Int, Bool) Term]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IntervalView -> [[Either (Int, Bool) Term]]
f (IntervalView -> [[Either (Int, Bool) Term]])
-> (Arg Term -> IntervalView)
-> Arg Term
-> [[Either (Int, Bool) Term]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> IntervalView
view (Term -> IntervalView)
-> (Arg Term -> Term) -> Arg Term -> IntervalView
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) Arg Term
x
         f (OTerm (Var Int
i [])) = [Either (Int, Bool) Term] -> [[Either (Int, Bool) Term]]
forall (m :: * -> *) a. Monad m => a -> m a
return [(Int, Bool) -> Either (Int, Bool) Term
forall a b. a -> Either a b
Left (Int
i,Bool
True)]
         f (OTerm Term
t)          = [Either (Int, Bool) Term] -> [[Either (Int, Bool) Term]]
forall (m :: * -> *) a. Monad m => a -> m a
return [Term -> Either (Int, Bool) Term
forall a b. b -> Either a b
Right Term
t]
         v :: IntervalView
v = Term -> IntervalView
view Term
t
     [(Map Int (Set Bool), [Term])] -> m [(Map Int (Set Bool), [Term])]
forall (m :: * -> *) a. Monad m => a -> m a
return [ (Map Int (Set Bool)
bsm,[Term]
ts)
            | [Either (Int, Bool) Term]
xs <- IntervalView -> [[Either (Int, Bool) Term]]
f IntervalView
v
            , let ([(Int, Bool)]
bs,[Term]
ts) = [Either (Int, Bool) Term] -> ([(Int, Bool)], [Term])
forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (Int, Bool) Term]
xs
            , let bsm :: Map Int (Set Bool)
bsm     = ((Set Bool -> Set Bool -> Set Bool)
-> [(Int, Set Bool)] -> Map Int (Set Bool)
forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith Set Bool -> Set Bool -> Set Bool
forall a. Ord a => Set a -> Set a -> Set a
Set.union ([(Int, Set Bool)] -> Map Int (Set Bool))
-> ([(Int, Bool)] -> [(Int, Set Bool)])
-> [(Int, Bool)]
-> Map Int (Set Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Int, Bool) -> (Int, Set Bool))
-> [(Int, Bool)] -> [(Int, Set Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> Int
forall a. a -> a
id (Int -> Int)
-> (Bool -> Set Bool) -> (Int, Bool) -> (Int, Set Bool)
forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
-*- Bool -> Set Bool
forall a. a -> Set a
Set.singleton)) [(Int, Bool)]
bs
            ]


-- | 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 -> Args -> ExceptT (Closure (Abs Type)) TCM Args
transpTel Abs Telescope
delta Term
phi Args
args = do
  Term
tTransp <- TCMT IO Term -> ExceptT (Closure (Abs Type)) TCM Term
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primTrans
  Term
imin <- TCMT IO Term -> ExceptT (Closure (Abs Type)) TCM Term
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin
  Term
imax <- TCMT IO Term -> ExceptT (Closure (Abs Type)) TCM Term
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax
  Term
ineg <- TCMT IO Term -> ExceptT (Closure (Abs Type)) TCM Term
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
  let
    noTranspError :: a -> t m b
noTranspError a
t = m b -> t m b
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> t m b) -> (Closure a -> m b) -> Closure a -> t m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure a -> m b
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Closure a -> t m b) -> t m (Closure a) -> t m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCM (Closure a) -> t m (Closure a)
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (a -> TCM (Closure a)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure a
t)
    bapp :: (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a
    bapp :: forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
bapp m (Abs a)
t m (SubstArg a)
u = Abs a -> SubstArg a -> a
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs a -> SubstArg a -> a) -> m (Abs a) -> m (SubstArg a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Abs a)
t m (SubstArg a -> a) -> m (SubstArg a) -> m a
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (SubstArg a)
u
    gTransp :: Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
gTransp (Just NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l) NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi NamesT (ExceptT (Closure (Abs Type)) TCM) Term
a = Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) 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 (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)) TCM) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t) NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
a
    gTransp Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
Nothing  NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi NamesT (ExceptT (Closure (Abs Type)) TCM) Term
a = do
      -- Γ ⊢ i.Ξ
      NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
xi <- (Abs Telescope
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Telescope
 -> NamesT
      (ExceptT (Closure (Abs Type)) TCM)
      (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)))
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
 -> NamesT
      (ExceptT (Closure (Abs Type)) TCM)
      (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)))
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope))
forall a b. (a -> b) -> a -> b
$ do
        [Char]
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
[Char] -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind [Char]
"i" ((NamesT (ExceptT (Closure (Abs Type)) TCM) Term
  -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope)
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope))
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i -> do
          TelV Telescope
xi Type
_ <- (TCM (TelV Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (TelV Type)
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (TelV Type)
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) (TelV Type))
-> (Type -> TCM (TelV Type))
-> Type
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (TelV Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TCM (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView (Type -> NamesT (ExceptT (Closure (Abs Type)) TCM) (TelV Type))
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Type
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (TelV Type)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (ExceptT (Closure (Abs Type)) TCM) Type
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) (TelV Type))
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Type
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (TelV Type)
forall a b. (a -> b) -> a -> b
$ NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) TCM) Term
NamesT (ExceptT (Closure (Abs Type)) TCM) (SubstArg Type)
i
          Telescope -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope
forall (m :: * -> *) a. Monad m => a -> m a
return Telescope
xi
      [Arg [Char]]
argnames <- do
        Telescope -> [Arg [Char]]
teleArgNames (Telescope -> [Arg [Char]])
-> (Abs Telescope -> Telescope) -> Abs Telescope -> [Arg [Char]]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Telescope -> Telescope
forall a. Abs a -> a
unAbs (Abs Telescope -> [Arg [Char]])
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) [Arg [Char]]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
xi
      [Arg [Char]]
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Args
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *).
(Functor m, MonadFail m) =>
[Arg [Char]] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term
glamN [Arg [Char]]
argnames ((NamesT (ExceptT (Closure (Abs Type)) TCM) Args
  -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Args
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Args
xi_args -> do
        Abs Type
b' <- [Char]
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
[Char] -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind [Char]
"i" ((NamesT (ExceptT (Closure (Abs Type)) TCM) Term
  -> NamesT (ExceptT (Closure (Abs Type)) TCM) Type)
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type))
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i -> do
          Type
ti <- NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) TCM) Term
NamesT (ExceptT (Closure (Abs Type)) TCM) (SubstArg Type)
i
          Abs Telescope
xin <- [Char]
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
[Char] -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind [Char]
"i" ((NamesT (ExceptT (Closure (Abs Type)) TCM) Term
  -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope)
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope))
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
xi NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (SubstArg Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i)
          Args
xi_args <- NamesT (ExceptT (Closure (Abs Type)) TCM) Args
xi_args
          Term
ni <- Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i
          Term
phi <- NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi
          ExceptT (Closure (Abs Type)) TCM Type
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) TCM Type
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) Type)
-> ExceptT (Closure (Abs Type)) TCM Type
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Type
forall a b. (a -> b) -> a -> b
$ Type -> Args -> ExceptT (Closure (Abs Type)) TCM Type
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
piApplyM Type
ti (Args -> ExceptT (Closure (Abs Type)) TCM Type)
-> ExceptT (Closure (Abs Type)) TCM Args
-> ExceptT (Closure (Abs Type)) TCM Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Abs Telescope
-> Term -> Args -> Term -> ExceptT (Closure (Abs Type)) TCM Args
trFillTel Abs Telescope
xin Term
phi Args
xi_args Term
ni
        Term
axi <- do
          Term
a <- NamesT (ExceptT (Closure (Abs Type)) TCM) Term
a
          Abs Telescope
xif <- [Char]
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
[Char] -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind [Char]
"i" ((NamesT (ExceptT (Closure (Abs Type)) TCM) Term
  -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope)
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope))
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
xi NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (SubstArg Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Telescope
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i)
          Term
phi <- NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi
          Args
xi_args <- NamesT (ExceptT (Closure (Abs Type)) TCM) Args
xi_args
          ExceptT (Closure (Abs Type)) TCM Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) TCM Term
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> ExceptT (Closure (Abs Type)) TCM Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall a b. (a -> b) -> a -> b
$ Term -> Args -> Term
forall t. Apply t => t -> Args -> t
apply Term
a (Args -> Term)
-> ExceptT (Closure (Abs Type)) TCM Args
-> ExceptT (Closure (Abs Type)) TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs Telescope
-> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args
transpTel Abs Telescope
xif Term
phi Args
xi_args
        Sort
s <- Sort -> NamesT (ExceptT (Closure (Abs Type)) TCM) Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> NamesT (ExceptT (Closure (Abs Type)) TCM) Sort)
-> Sort -> NamesT (ExceptT (Closure (Abs Type)) TCM) Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort (Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody Abs Type
b')
        case Sort
s of
          Type Level' Term
l -> do
            NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l <- Term
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term
 -> NamesT
      (ExceptT (Closure (Abs Type)) TCM)
      (NamesT (ExceptT (Closure (Abs Type)) TCM) Term))
-> Term
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall a b. (a -> b) -> a -> b
$ Term -> Term
lam_i (Level' Term -> Term
Level Level' Term
l)
            NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
b' <- Abs Type
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Abs Type
b'
            NamesT (ExceptT (Closure (Abs Type)) TCM) Term
axi <- Term
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
axi
            Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
gTransp (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall a. a -> Maybe a
Just NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l) NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
b' NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi NamesT (ExceptT (Closure (Abs Type)) TCM) Term
axi
          Inf IsFibrant
_ Integer
n  ->
            if Int
0 Int -> Type -> Bool
forall a. Free a => Int -> a -> Bool
`freeIn` (Int -> Abs Type -> Abs Type
forall a. Subst a => Int -> a -> a
raise Int
1 Abs Type
b' Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Int -> Term
var Int
0) then Abs Type -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadError (Closure a) m, MonadTCM (t m)) =>
a -> t m b
noTranspError Abs Type
b' else Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *) a. Monad m => a -> m a
return Term
axi
          SSet Level' Term
_  ->
            if Int
0 Int -> Type -> Bool
forall a. Free a => Int -> a -> Bool
`freeIn` (Int -> Abs Type -> Abs Type
forall a. Subst a => Int -> a -> a
raise Int
1 Abs Type
b' Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Int -> Term
var Int
0) then Abs Type -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadError (Closure a) m, MonadTCM (t m)) =>
a -> t m b
noTranspError Abs Type
b' else Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *) a. Monad m => a -> m a
return Term
axi
          Sort
_ -> Abs Type -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadError (Closure a) m, MonadTCM (t m)) =>
a -> t m b
noTranspError Abs Type
b'
    lam_i :: Term -> Term
lam_i = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Term -> Abs Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
Abs [Char]
"i"
    go :: Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args
    go :: Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args
go Telescope
EmptyTel            Term
_   []       = Args -> ExceptT (Closure (Abs Type)) TCM Args
forall (m :: * -> *) a. Monad m => a -> m a
return []
    go (ExtendTel Dom Type
t Abs Telescope
delta) Term
phi (Arg Term
a:Args
args) = do
      -- Γ,i ⊢ t
      -- Γ,i ⊢ (x : t). delta
      -- Γ ⊢ a : t[0]
      Sort
s <- Sort -> ExceptT (Closure (Abs Type)) TCM Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> ExceptT (Closure (Abs Type)) TCM Sort)
-> Sort -> ExceptT (Closure (Abs Type)) TCM Sort
forall a b. (a -> b) -> a -> b
$ Dom Type -> Sort
forall a. LensSort a => a -> Sort
getSort Dom Type
t
      -- Γ ⊢ b : t[1], Γ,i ⊢ b : t[i]
      (Term
b,Term
bf) <- Names
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Term, Term)
-> ExceptT (Closure (Abs Type)) TCM (Term, Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (ExceptT (Closure (Abs Type)) TCM) (Term, Term)
 -> ExceptT (Closure (Abs Type)) TCM (Term, Term))
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Term, Term)
-> ExceptT (Closure (Abs Type)) TCM (Term, Term)
forall a b. (a -> b) -> a -> b
$ do
        Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
l <- case Sort
s of
               SSet Level' Term
_ -> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall a. Maybe a
Nothing
               Inf IsFibrant
_ Integer
n -> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall a. Maybe a
Nothing
               Type Level' Term
l -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall a. a -> Maybe a
Just (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
 -> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term))
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) 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)) TCM)
     (Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term))
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadError (Closure a) m, MonadTCM (t m)) =>
a -> t m b
noTranspError ([Char] -> Type -> Abs Type
forall a. [Char] -> a -> Abs a
Abs [Char]
"i" (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t))
        NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t <- Abs Type
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Type
 -> NamesT
      (ExceptT (Closure (Abs Type)) TCM)
      (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)))
-> Abs Type
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type))
forall a b. (a -> b) -> a -> b
$ [Char] -> Type -> Abs Type
forall a. [Char] -> a -> Abs a
Abs [Char]
"i" (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)
        [NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi,NamesT (ExceptT (Closure (Abs Type)) TCM) Term
a] <- (Term
 -> NamesT
      (ExceptT (Closure (Abs Type)) TCM)
      (NamesT (ExceptT (Closure (Abs Type)) TCM) Term))
-> [Term]
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     [NamesT (ExceptT (Closure (Abs Type)) TCM) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Term
-> NamesT
     (ExceptT (Closure (Abs Type)) TCM)
     (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Term
phi, Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a]
        Term
b <- Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
gTransp Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
l NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi NamesT (ExceptT (Closure (Abs Type)) TCM) Term
a
        Abs Term
bf <- [Char]
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Term)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
[Char] -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind [Char]
"i" ((NamesT (ExceptT (Closure (Abs Type)) TCM) Term
  -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Term))
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i -> do
                            Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
gTransp (((NamesT (ExceptT (Closure (Abs Type)) TCM) Term
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
l) ((NamesT (ExceptT (Closure (Abs Type)) TCM) Term
  -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
 -> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term))
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l -> [Char]
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" ((NamesT (ExceptT (Closure (Abs Type)) TCM) Term
  -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
j -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imin NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
j))
                                    ([Char]
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
[Char] -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind [Char]
"j" ((NamesT (ExceptT (Closure (Abs Type)) TCM) Term
  -> NamesT (ExceptT (Closure (Abs Type)) TCM) Type)
 -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type))
-> (NamesT (ExceptT (Closure (Abs Type)) TCM) Term
    -> NamesT (ExceptT (Closure (Abs Type)) TCM) Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
j -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imin NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
j))
                                    (Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imax NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i) NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
-> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi)
                                    NamesT (ExceptT (Closure (Abs Type)) TCM) Term
a
        (Term, Term)
-> NamesT (ExceptT (Closure (Abs Type)) TCM) (Term, Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (Term
b, Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
bf)
      (:) (Term
b Term -> Arg Term -> Arg Term
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Term
a) (Args -> Args)
-> ExceptT (Closure (Abs Type)) TCM Args
-> ExceptT (Closure (Abs Type)) TCM Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args
go (Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp Abs Telescope
delta Term
SubstArg Telescope
bf) Term
phi Args
args
    go (ExtendTel Dom Type
t Abs Telescope
delta) Term
phi []    = ExceptT (Closure (Abs Type)) TCM Args
forall a. HasCallStack => a
__IMPOSSIBLE__
    go Telescope
EmptyTel            Term
_   (Arg Term
_:Args
_) = ExceptT (Closure (Abs Type)) TCM Args
forall a. HasCallStack => a
__IMPOSSIBLE__
  Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args
go (Abs Telescope -> Telescope
forall a. Subst a => Abs a -> a
absBody Abs Telescope
delta) Term
phi Args
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 -> Args -> Term -> ExceptT (Closure (Abs Type)) TCM Args
trFillTel Abs Telescope
delta Term
phi Args
args Term
r = do
  Term
imin <- TCMT IO Term -> ExceptT (Closure (Abs Type)) TCM Term
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin
  Term
imax <- TCMT IO Term -> ExceptT (Closure (Abs Type)) TCM Term
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax
  Term
ineg <- TCMT IO Term -> ExceptT (Closure (Abs Type)) TCM Term
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
  Abs Telescope
-> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args
transpTel ([Char] -> Telescope -> Abs Telescope
forall a. [Char] -> a -> Abs a
Abs [Char]
"j" (Telescope -> Abs Telescope) -> Telescope -> Abs Telescope
forall a b. (a -> b) -> a -> b
$ Int -> Abs Telescope -> Abs Telescope
forall a. Subst a => Int -> a -> a
raise Int
1 Abs Telescope
delta Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` (Term
imin Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` ((Term -> Arg Term) -> [Term] -> Args
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Int -> Term
var Int
0, Int -> Term -> Term
forall a. Subst a => Int -> a -> a
raise Int
1 Term
r])))
            (Term
imax Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Term
ineg Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
r], Term -> Arg Term
forall e. e -> Arg e
argN Term
phi])
            Args
args