{-# 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
requireCubical
:: Cubical
-> String -> TCM ()
requireCubical :: Cubical -> [Char] -> TCM ()
requireCubical Cubical
wanted [Char]
s = do
Maybe Cubical
cubical <- PragmaOptions -> Maybe Cubical
optCubical forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
Bool
inErasedContext <- forall a. LensQuantity a => a -> Bool
hasQuantity0 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCM TCEnv
getEnv
case Maybe Cubical
cubical of
Just Cubical
CFull -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Cubical
CErased | Cubical
wanted forall a. Eq a => a -> a -> Bool
== Cubical
CErased Bool -> Bool -> Bool
|| Bool
inErasedContext -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Cubical
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError forall a b. (a -> b) -> a -> b
$ [Char]
"Missing option " forall a. [a] -> [a] -> [a]
++ [Char]
opt 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 = forall t a. Sort' t -> a -> Type'' t a
El (forall t. Level' t -> Sort' t
SSet forall a b. (a -> b) -> a -> b
$ Integer -> Level
ClosedLevel Integer
0) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> 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 <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
1 forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
case Args
ts of
[Arg Term
x] -> do
IntervalView -> Term
unview <- forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
Term -> IntervalView
view <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
Blocked (Arg Term)
sx <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
IntervalView
ix <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sx)
let
ineg :: Arg Term -> Arg Term
ineg :: Arg Term -> Arg Term
ineg = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IntervalView -> Term
unview forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntervalView -> IntervalView
f 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 (forall e. Arg e -> e
unArg Arg Term
x)
OTerm Term
t -> Arg Term -> IntervalView
INeg (forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo Term
t)
case IntervalView
ix of
OTerm Term
t -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sx]
IntervalView
_ -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (IntervalView -> Term
unview forall a b. (a -> b) -> a -> b
$ IntervalView -> IntervalView
f IntervalView
ix)
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primDepIMin' :: TCM PrimitiveImpl
primDepIMin' :: TCM PrimitiveImpl
primDepIMin' = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
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 -> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
2 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
IntervalView
ix <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sx)
Term
itisone <- forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
"primDepIMin" [Char]
builtinItIsOne
case IntervalView
ix of
IntervalView
IZero -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
IZero
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall e. Arg e -> e
unArg Arg Term
y) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
itisone)
IntervalView
_ -> do
Blocked (Arg Term)
sy <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
y
IntervalView
iy <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall t. Reduce t => t -> ReduceM t
reduce' forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sy) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
itisone)
case IntervalView
iy of
IntervalView
IZero -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
IZero
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sx)
IntervalView
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
_ -> 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 <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
2 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
IntervalView
ix <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ 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 -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
absorber
IntervalView
ix | IntervalView
ix IntervalView -> IntervalView -> Bool
==% IntervalView
unit -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
YesSimplification (forall e. Arg e -> e
unArg Arg Term
y)
IntervalView
_ -> do
Blocked (Arg Term)
sy <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
y
IntervalView
iy <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ 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 -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
absorber
IntervalView
iy | IntervalView
iy IntervalView -> IntervalView -> Bool
==% IntervalView
unit -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
YesSimplification (forall e. Arg e -> e
unArg Arg Term
x)
IntervalView
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
_ -> 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
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview (Arg Term -> Arg Term -> IntervalView
IMax (forall e. e -> Arg e
argN Term
x') (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
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview (Arg Term -> Arg Term -> IntervalView
IMin (forall e. e -> Arg e
argN Term
x') (forall e. e -> Arg e
argN Term
y'))
primIdJ :: TCM PrimitiveImpl
primIdJ :: TCM PrimitiveImpl
primIdJ = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"c" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
c ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"x" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
x ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"C" (forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"y" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (Sort -> Type
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
c)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bC ->
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
c (NamesT TCM Term
bC forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@>
(forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primConId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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))) forall (m :: * -> *). Applicative m => m Type -> m Type -> m 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" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) (\ NamesT TCM Term
y ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"p" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
p ->
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
c forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
bC forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
p)
Maybe QName
conidn <- forall (m :: * -> *).
(HasBuiltins m, MonadReduce m) =>
[Char] -> m (Maybe QName)
getBuiltinName [Char]
builtinConId
Term
conid <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primConId
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
8 forall a b. (a -> b) -> a -> b
$ \ Args
ts -> do
IntervalView -> Term
unview <- 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Arg Term -> IntervalView
IMax (forall e. e -> Arg e
argN Term
x') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Arg e
argN 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Arg Term -> IntervalView
IMin (forall e. e -> Arg e
argN Term
x') forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Arg e
argN 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> IntervalView
INeg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Arg e
argN forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT Fail Term
x
Maybe Term
mcomp <- 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
eq
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking 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])
| forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
conidn, Just Term
comp <- Maybe Term
mcomp -> do
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ forall a. Names -> NamesT Fail a -> a
runNames [] 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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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] <- 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]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Term
p forall t. Apply t => t -> [Elim] -> t
`applyE` [forall a. a -> a -> a -> Elim' a
IApply Term
x Term
y Term
i]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
comp forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Fail Term -> NamesT Fail Term
w NamesT Fail Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
conid forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Fail Term -> NamesT Fail Term
w NamesT Fail Term
i)
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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 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)))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Fail Term
_ -> Term -> Term
nolam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT Fail Term
d)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
d
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
seq]
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primIdElim' :: TCM PrimitiveImpl
primIdElim' :: TCM PrimitiveImpl
primIdElim' = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"c" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
c ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"x" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
x ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"C" (forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"y" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (Sort -> Type
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
c)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bC ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT TCM Term
phi ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"y" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT TCM Term
a forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSub forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"o" (forall a b. a -> b -> a
const NamesT TCM Term
x)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
let pathxy :: NamesT TCM Term
pathxy = (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primPath forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
oucy)
oucy :: NamesT TCM Term
oucy = (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSubOut forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"o" (forall a b. a -> b -> a
const NamesT TCM Term
x) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y)
reflx :: NamesT TCM Term
reflx = (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> NamesT TCM Term
x)
in
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"w" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT TCM Term
a forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSub forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
pathxy forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
reflx) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
w ->
let oucw :: NamesT TCM Term
oucw = (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSubOut forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
pathxy forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
reflx forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
w) in
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
c forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
bC forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
oucy forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primConId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
oucy forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
oucw))
forall (m :: * -> *). Applicative m => m Type -> m Type -> m 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" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) (\ NamesT TCM Term
y ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"p" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
p ->
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
c forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
bC forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
p)
Term
conid <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primConId
Term
sin <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSubIn
Term
path <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primPath
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
8 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
p
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ 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 forall t. Apply t => t -> Args -> t
`apply` [Arg Term
a,Arg Term
bA ,Arg Term
phi,forall e. e -> Arg e
argN forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
y]
let w' :: Term
w' = Term
sin forall t. Apply t => t -> Args -> t
`apply` [Arg Term
a,forall e. e -> Arg e
argN forall a b. (a -> b) -> a -> b
$ Term
path forall t. Apply t => t -> Args -> t
`apply` [Arg Term
a,Arg Term
bA,Arg Term
x,Arg Term
y],Arg Term
phi,forall e. e -> Arg e
argN forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
w]
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
f forall t. Apply t => t -> Args -> t
`apply` [Arg Term
phi, forall e. e -> Arg e
defaultArg Term
y', forall e. e -> Arg e
defaultArg Term
w']
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map 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] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sp]
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primPOr :: TCM PrimitiveImpl
primPOr :: TCM PrimitiveImpl
primPOr = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
i ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"j" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
j ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"A" (forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
[Char]
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' [Char]
"o" (forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT TCM Term
i NamesT TCM Term
j) forall a b. (a -> b) -> a -> b
$ \NamesT TCM Term
o -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a) (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
((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 forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
i1 -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne1 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
j forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i1))) forall (m :: * -> *). Applicative m => m Type -> m Type -> m 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 forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
j1 -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne2 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
j forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
j1))) forall (m :: * -> *). Applicative m => m Type -> m Type -> m 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" (forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT TCM Term
i NamesT TCM Term
j) (\ NamesT TCM Term
o -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT TCM Term
o)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
6 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
i
IntervalView
vi <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
si
case IntervalView
vi of
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (forall e. Arg e -> e
unArg Arg Term
u)
IntervalView
IZero -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (forall e. Arg e -> e
unArg Arg Term
v)
IntervalView
_ -> do
Blocked (Arg Term)
sj <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
j
IntervalView
vj <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sj
case IntervalView
vj of
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (forall e. Arg e -> e
unArg Arg Term
v)
IntervalView
IZero -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (forall e. Arg e -> e
unArg Arg Term
u)
IntervalView
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction [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,forall a. a -> MaybeReduced a
notReduced Arg Term
a,forall a. a -> MaybeReduced a
notReduced Arg Term
u,forall a. a -> MaybeReduced a
notReduced Arg Term
v]
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primPartial' :: TCM PrimitiveImpl
primPartial' :: TCM PrimitiveImpl
primPartial' = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) (\ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
(Sort -> Type
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a))
Term
isOne <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
3 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)) <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
[NamesT ReduceM Term
l,NamesT ReduceM Term
a,NamesT ReduceM Term
phi] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
a,Arg Term
phi]
forall (m :: * -> *). Functor m => m Term -> m Type
elSSet (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
isOne forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT ReduceM Term
l NamesT ReduceM Term
a
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ Dom Type -> Abs Type -> Term
Pi (forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant forall a b. (a -> b) -> a -> b
$ Dom Type
d { domFinite :: Bool
domFinite = Bool
True }) Abs Type
b
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primPartialP' :: TCM PrimitiveImpl
primPartialP' :: TCM PrimitiveImpl
primPartialP' = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) (\ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"A" (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 forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a) (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
(Sort -> Type
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSSort 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 (forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant forall a b. (a -> b) -> a -> b
$ Dom Type
d { domFinite :: Bool
domFinite = Bool
True }) Abs Type
b
toFinitePi Type
_ = forall a. HasCallStack => a
__IMPOSSIBLE__
Term
v <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"a" forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
l ->
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"φ" forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"A" forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
Type -> Term
toFinitePi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"p" (forall (m :: * -> *). Functor m => m Term -> m Type
elSSet forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi) (\ NamesT TCM Term
p -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
l (NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
p))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
0 forall a b. (a -> b) -> a -> b
$ \ Args
_ -> 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 <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"A" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a) (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"u" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT TCM Term
a forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primPartial forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
u ->
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT TCM Term
a (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSub forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
u) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 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 <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
Blocked (Arg Term)
sphi <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
case Term -> IntervalView
view forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi of
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall (m :: * -> *) a. Monad m => a -> m a
return (forall e. Arg e -> e
unArg Arg Term
u) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> (forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtinSubOut [Char]
builtinItIsOne))
IntervalView
_ -> do
Blocked (Arg Term)
sx <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
Maybe QName
mSubIn <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getBuiltinName' [Char]
builtinSubIn
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sx of
Def QName
q [Elim
_,Elim
_,Elim
_, Apply Arg Term
t] | forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mSubIn -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (forall e. Arg e -> e
unArg Arg Term
t)
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
a,Arg Term
bA] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi, forall a. a -> MaybeReduced a
notReduced Arg Term
u, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sx]
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primIdFace' :: TCM PrimitiveImpl
primIdFace' :: TCM PrimitiveImpl
primIdFace' = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"x" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
x ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"y" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y)
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
t
Maybe QName
mConId <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getName' [Char]
builtinConId
case forall e. Arg e -> e
unArg (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
_] | forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mConId -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (forall e. Arg e -> e
unArg Arg Term
phi)
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
l,Arg Term
bA,Arg Term
x,Arg Term
y] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
st]
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primIdPath' :: TCM PrimitiveImpl
primIdPath' :: TCM PrimitiveImpl
primIdPath' = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"x" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
x ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"y" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
y ->
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y)
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primPath forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
y)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
t
Maybe QName
mConId <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getName' [Char]
builtinConId
case forall e. Arg e -> e
unArg (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] | forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mConId -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (forall e. Arg e -> e
unArg Arg Term
w)
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
l,Arg Term
bA,Arg Term
x,Arg Term
y] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
st]
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primTrans' :: TCM PrimitiveImpl
primTrans' :: TCM PrimitiveImpl
primTrans' = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Functor m => m Term -> m Type
el (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"A" (forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
i -> (Sort -> Type
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i))) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
(forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) (NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne) (NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne))
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
4 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 <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
a) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT TCM Term
i -> 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 forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
(forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
a NamesT TCM Term
bA)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 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
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 -> ShowS
[TranspOrHComp] -> ShowS
TranspOrHComp -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TranspOrHComp] -> ShowS
$cshowList :: [TranspOrHComp] -> ShowS
show :: TranspOrHComp -> [Char]
$cshow :: TranspOrHComp -> [Char]
showsPrec :: Int -> TranspOrHComp -> ShowS
$cshowsPrec :: Int -> TranspOrHComp -> ShowS
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
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 -> ShowS
forall a. Show a => Int -> FamilyOrNot a -> ShowS
forall a. Show a => [FamilyOrNot a] -> ShowS
forall a. Show a => FamilyOrNot a -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [FamilyOrNot a] -> ShowS
$cshowList :: forall a. Show a => [FamilyOrNot a] -> ShowS
show :: FamilyOrNot a -> [Char]
$cshow :: forall a. Show a => FamilyOrNot a -> [Char]
showsPrec :: Int -> FamilyOrNot a -> ShowS
$cshowsPrec :: forall a. Show a => Int -> FamilyOrNot a -> ShowS
Show,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 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
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 = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a. a -> a
id forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' FamilyOrNot a
x
reduce' :: FamilyOrNot a -> ReduceM (FamilyOrNot a)
reduce' FamilyOrNot a
x = forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall t. Reduce t => t -> ReduceM t
reduce' FamilyOrNot a
x
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 = 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
r
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u
forall (m :: * -> *) a. Monad m => a -> m a
return 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 ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT m Term
i ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term -> NamesT m Term
ineg NamesT m Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o))
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT m Term
u0))
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 (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
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 forall a. [a] -> [a] -> [a]
++ [Char]
" for " forall a. [a] -> [a] -> [a]
++ [Char]
builtinGlue
getTermLocal :: [Char] -> m Term
getTermLocal = 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 <- forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m) =>
m (Maybe SigmaKit)
getSigmaKit
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
let ineg :: NamesT m Term -> NamesT m Term
ineg NamesT m Term
j = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 <- 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 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 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)
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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
[NamesT m Term
psi,NamesT m Term
u0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
psi,Arg Term
u0]
NamesT m Term -> NamesT m Term -> NamesT m Term
glue1 <- do
NamesT m Term
g <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ (Term
tglue forall t. Apply t => t -> Args -> t
`apply`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Subst a => Int -> SubstArg a -> a -> a
subst Int
0 Term
io)) 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]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
t NamesT m Term
a -> NamesT m Term
g forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
t 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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Names -> NamesT Fail a -> a
runNames [] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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]
let unglue_u0 :: NamesT m Term -> NamesT m Term
unglue_u0 NamesT m Term
i =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
(<#>) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue) (forall a b. (a -> b) -> [a] -> [b]
map (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]) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
Term -> IntervalView
view <- 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 (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o
forallphi :: NamesT m Term
forallphi = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tForall forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi
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)
(forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
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 (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' = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
l 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConHead -> ConInfo -> [Elim] -> Term
Con (SigmaKit -> ConHead
sigmaCon SigmaKit
kit) ConInfo
ConOSystem []) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
x 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 =
(forall (f :: * -> *) a. Applicative f => a -> f a
pure (QName -> [Elim] -> Term
Def (SigmaKit -> QName
sigmaName SigmaKit
kit) []) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
lb
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
bA
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"a" (\ NamesT m Term
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPath forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bB forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
f forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
b))
pe :: NamesT m Term -> NamesT m Term
pe NamesT m Term
o =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term -> NamesT m Term -> NamesT m Term
max (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) (NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
(NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o) (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
(NamesT m Term -> NamesT m Term -> NamesT m Term
w (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o) NamesT m Term
a1)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
_ -> NamesT m Term
a1))
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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) (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
_ -> NamesT m Term
a1))
t1'alpha :: NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEProof forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1
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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term -> NamesT m Term
pe NamesT m Term
o
t1' :: NamesT m Term -> NamesT m Term
t1' NamesT m Term
o = NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (forall t. Apply t => t -> [Elim] -> t
`applyE` [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 forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (forall t. Apply t => t -> [Elim] -> t
`applyE` [forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (SigmaKit -> QName
sigmaSnd SigmaKit
kit)])
a1' :: NamesT m Term
a1' = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term -> NamesT m Term -> NamesT m Term
imax (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
psi)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT m Term -> NamesT m Term -> NamesT m Term
w (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1
NamesT m Term
a1'
unglueTranspGlue Arg Term
_ Arg Term
_ FamilyOrNot
(Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
_ = forall a. HasCallStack => a
__IMPOSSIBLE__
data TermPosition = Head | Eliminated deriving (TermPosition -> TermPosition -> Bool
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 -> ShowS
[TermPosition] -> ShowS
TermPosition -> [Char]
forall a.
(Int -> a -> ShowS) -> (a -> [Char]) -> ([a] -> ShowS) -> Show a
showList :: [TermPosition] -> ShowS
$cshowList :: [TermPosition] -> ShowS
show :: TermPosition -> [Char]
$cshow :: TermPosition -> [Char]
showsPrec :: Int -> TermPosition -> ShowS
$cshowsPrec :: Int -> TermPosition -> ShowS
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 <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< m Term
phi)
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ IntervalView -> Bool
isIOne IntervalView
phi
| Bool
otherwise = 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 = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm forall a b. (a -> b) -> a -> b
$ ([Char]
builtinHComp forall a. [a] -> [a] -> [a]
++ [Char]
" for " 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 <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
[NamesT m Term
psi, NamesT m Term
u, NamesT m Term
u0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi, Arg Term
bT, Arg Term
e]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *). PureTCM m => TermPosition -> m Term -> m Bool
headStop TermPosition
tpos NamesT m Term
phi) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bA
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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))
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 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
e forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
g
a1 :: NamesT m Term
a1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT m Term
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o) 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))
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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
case TermPosition
tpos of
TermPosition
Head -> NamesT m Term -> NamesT m Term
t1 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tItIsOne)
TermPosition
Eliminated -> NamesT m Term
a1
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 forall a. [a] -> [a] -> [a]
++ [Char]
" for " forall a. [a] -> [a] -> [a]
++ [Char]
builtinGlue
getTermLocal :: [Char] -> m Term
getTermLocal = 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 <- forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m) =>
m (Maybe SigmaKit)
getSigmaKit
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
let ineg :: NamesT m Term -> NamesT m Term
ineg NamesT m Term
j = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 <- 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 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 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)
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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
[NamesT m Term
psi,NamesT m Term
u0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
psi,Arg Term
u0]
NamesT m Term -> NamesT m Term -> NamesT m Term
glue1 <- do
NamesT m Term
g <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ (Term
tglue forall t. Apply t => t -> Args -> t
`apply`) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map ((forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a. Subst a => Int -> SubstArg a -> a -> a
subst Int
0 Term
io)) 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]
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
t NamesT m Term
a -> NamesT m Term
g forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
t 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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Names -> NamesT Fail a -> a
runNames [] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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]
let unglue_u0 :: NamesT m Term -> NamesT m Term
unglue_u0 NamesT m Term
i =
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
(<#>) (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue) (forall a b. (a -> b) -> [a] -> [b]
map (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]) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
Term -> IntervalView
view <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *). PureTCM m => TermPosition -> m Term -> m Bool
headStop TermPosition
tpos (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o
forallphi :: NamesT m Term
forallphi = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tForall forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi
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)
(forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT m Term
o -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
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 (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' = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
l 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure (ConHead -> ConInfo -> [Elim] -> Term
Con (SigmaKit -> ConHead
sigmaCon SigmaKit
kit) ConInfo
ConOSystem []) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
x 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEFun forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 =
(forall (f :: * -> *) a. Applicative f => a -> f a
pure (QName -> [Elim] -> Term
Def (SigmaKit -> QName
sigmaName SigmaKit
kit) []) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
lb
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
bA
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"a" (\ NamesT m Term
a -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPath forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bB forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
f forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
b))
pe :: NamesT m Term -> NamesT m Term
pe NamesT m Term
o =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term -> NamesT m Term -> NamesT m Term
max (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) (NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
(NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o) (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
(NamesT m Term -> NamesT m Term -> NamesT m Term
w (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o) NamesT m Term
a1)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
_ -> NamesT m Term
a1))
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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) (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
_ -> NamesT m Term
a1))
t1'alpha :: NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEProof forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
e forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1
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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term -> NamesT m Term
pe NamesT m Term
o
t1' :: NamesT m Term -> NamesT m Term
t1' NamesT m Term
o = NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (forall t. Apply t => t -> [Elim] -> t
`applyE` [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 forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (forall t. Apply t => t -> [Elim] -> t
`applyE` [forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (SigmaKit -> QName
sigmaSnd SigmaKit
kit)])
a1' :: NamesT m Term
a1' = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term -> NamesT m Term -> NamesT m Term
imax (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
psi)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT m Term -> NamesT m Term -> NamesT m Term
w (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1
case TermPosition
tpos of
TermPosition
Head -> NamesT m Term -> NamesT m Term
t1' (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
_ = 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 = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm forall a b. (a -> b) -> a -> b
$ ([Char]
builtinHComp forall a. [a] -> [a] -> [a]
++ [Char]
" for " forall a. [a] -> [a] -> [a]
++ [Char]
builtinHComp 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
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
[NamesT m Term
psi, NamesT m Term
u, NamesT m Term
u0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
la, Arg Term
phi, Arg Term
bT, Arg Term
bA]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *). PureTCM m => TermPosition -> m Term -> m Bool
headStop TermPosition
tpos NamesT m Term
phi) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bA
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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))
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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (forall a b. a -> b -> a
const NamesT m Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tSubIn forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT m Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
phi 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bAS forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
g
a1 :: NamesT m Term
a1 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT m Term
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o))
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i) 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)))
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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
case TermPosition
tpos of
TermPosition
Eliminated -> NamesT m Term
a1
TermPosition
Head -> NamesT m Term -> NamesT m Term
t1 (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 forall a. [a] -> [a] -> [a]
++ [Char]
" for " forall a. [a] -> [a] -> [a]
++ [Char]
builtinHComp forall a. [a] -> [a] -> [a]
++ [Char]
" of Set"
getTermLocal :: [Char] -> m Term
getTermLocal = 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 <- forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(HasBuiltins m, HasConstInfo m) =>
m (Maybe SigmaKit)
getSigmaKit
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
let ineg :: NamesT m Term -> NamesT m Term
ineg NamesT m Term
j = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (forall a b. a -> b -> a
const NamesT m Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz 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 <- 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 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 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)
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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
[NamesT m Term
psi,NamesT m Term
u0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl 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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Subst a => Int -> SubstArg a -> a -> a
subst Int
0 Term
io) 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tSubIn forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT m Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
bA
NamesT m Term
g <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tglue forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bAS
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
t NamesT m Term
a -> NamesT m Term
g forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
t 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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Names -> NamesT Fail a -> a
runNames [] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
a))) [Arg Term
la, Arg Term
phi, Arg Term
bT, Arg Term
bA]
Term
tunglue <- forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl 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 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tSubIn forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tLSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
bA 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 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tunglue forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term -> NamesT m Term
bAS NamesT m Term
i
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *). PureTCM m => TermPosition -> m Term -> m Bool
headStop TermPosition
tpos (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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 (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io 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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o
forallphi :: NamesT m Term
forallphi = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tForall forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi
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)
(forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
(\ NamesT m Term
j -> NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term -> NamesT m Term
ineg NamesT m Term
j 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 (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 = forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"x" 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i)
(\ NamesT m Term
j -> NamesT m Term
bT forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term -> NamesT m Term
ineg NamesT m Term
j 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 =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
forallphi
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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)
t1'alpha :: NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o =
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTranspProof forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term -> NamesT m Term
ineg NamesT m Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o)
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
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term -> NamesT m Term
pt NamesT m Term
o
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tSubIn forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
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
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1)
t1' :: NamesT m Term -> NamesT m Term
t1' NamesT m Term
o = NamesT m Term -> NamesT m Term
t1'alpha NamesT m Term
o forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (forall t. Apply t => t -> [Elim] -> t
`applyE` [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 forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
<&> (forall t. Apply t => t -> [Elim] -> t
`applyE` [forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (SigmaKit -> QName
sigmaSnd SigmaKit
kit)])
a1' :: NamesT m Term
a1' = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term -> NamesT m Term -> NamesT m Term
imax (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
psi)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT m Term
j ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
psi forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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 forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT m Term -> NamesT m Term -> NamesT m Term
w (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term
o 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
a1
case TermPosition
tpos of
TermPosition
Eliminated -> NamesT m Term
a1'
TermPosition
Head -> NamesT m Term -> NamesT m Term
t1' (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
_ = 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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. a -> FamilyOrNot a
IsFam Arg Term
l,forall a. a -> FamilyOrNot a
IsFam Arg Term
bA,Arg Term
phi,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
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (forall a. a -> FamilyOrNot a
IsNot Arg Term
l,forall a. a -> FamilyOrNot a
IsNot Arg Term
bA,Arg Term
phi,forall a. a -> Maybe a
Just Arg Term
u,Arg Term
u0)
(TranspOrHComp, Args)
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
Blocked (Arg Term)
sphi <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
IntervalView
vphi <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi
let clP :: [Char] -> NamesT ReduceM Term
clP [Char]
s = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm (TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd) [Char]
s
case IntervalView
vphi of
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Maybe (Arg Term)
u of
Just Arg Term
u -> forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
NamesT ReduceM Term
u <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (forall e. Arg e -> e
unArg Arg Term
u)
NamesT ReduceM Term
u forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char] -> NamesT ReduceM Term
clP [Char]
builtinIOne forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> [Char] -> NamesT ReduceM Term
clP [Char]
builtinItIsOne
Maybe (Arg Term)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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
Just Arg Term
u ->
(forall a. a -> [a] -> [a]
:[]) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case IntervalView
vphi of
IntervalView
IZero -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a t. a -> Blocked' t a
notBlocked forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Arg e
argN) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
[NamesT ReduceM Term
l,NamesT ReduceM Term
c] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Arg Term)
l, forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc]
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> [Char] -> NamesT ReduceM Term
clP [Char]
builtinIsOneEmpty forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> MaybeReduced a
notReduced Arg Term
u)
Maybe (Arg Term)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return []
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ [forall a. a -> MaybeReduced a
notReduced (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] forall a. [a] -> [a] -> [a]
++ MaybeReducedArgs
u' forall a. [a] -> [a] -> [a]
++ [forall a. a -> MaybeReduced a
notReduced Arg Term
u0]
Blocked (FamilyOrNot (Arg Term))
sbA <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' FamilyOrNot (Arg Term)
bA
Maybe (Blocked' Term (FamilyOrNot Term))
t <- case forall e. Arg e -> e
unArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t a. Blocked' t a -> a
ignoreBlocking Blocked (FamilyOrNot (Arg Term))
sbA of
IsFam (Lam ArgInfo
_info Abs Term
t) -> forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> FamilyOrNot a
IsFam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (forall a. Subst a => Abs a -> a
absBody Abs Term
t)
IsFam Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
IsNot Term
t -> forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> FamilyOrNot a
IsNot forall a b. (a -> b) -> a -> b
$ (Term
t 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' (forall a. FamilyOrNot a -> a
famThing 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' (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FamilyOrNot a -> a
famThing forall a b. (a -> b) -> a -> b
$ Blocked' Term (FamilyOrNot Term)
st forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Blocked (FamilyOrNot (Arg Term))
sbA)
t :: FamilyOrNot Term
t = forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term (FamilyOrNot Term)
st
Maybe QName
mHComp <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinHComp
Maybe QName
mGlue <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinGlue
Maybe QName
mId <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getBuiltinName' [Char]
builtinId
Type -> PathView
pathV <- forall (m :: * -> *). HasBuiltins m => m (Type -> PathView)
pathView'
case forall a. FamilyOrNot a -> a
famThing FamilyOrNot Term
t of
MetaV MetaId
m [Elim]
_ -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback' (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. FamilyOrNot a -> a
famThing forall a b. (a -> b) -> a -> b
$ forall t. MetaId -> Blocked' t ()
blocked_ MetaId
m forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Blocked (FamilyOrNot (Arg Term))
sbA)
Pi Dom Type
a Abs Type
b | Int
nelims forall a. Ord a => a -> a -> Bool
> Int
0 -> forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback forall a a'. a -> ReduceM (Reduced a' a)
redReturn 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) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) (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
l) | TranspOrHComp
DoTransp <- TranspOrHComp
cmd -> 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
l 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] | forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mGlue -> do
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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) 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]
| forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mHComp, Sort (Type Level
la) <- forall e. Arg e -> e
unArg Arg Term
s -> do
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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
Level Level
la forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Term
s, Arg Term
phi', Arg Term
bT, Arg Term
bA) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) TermPosition
Head
Term
d | PathType Sort
_ QName
_ Arg Term
_ Arg Term
bA Arg Term
x Arg Term
y <- Type -> PathView
pathV (forall t a. Sort' t -> a -> Type'' t a
El HasCallStack => Sort
__DUMMY_SORT__ Term
d) -> do
if Int
nelims forall a. Ord a => a -> a -> Bool
> Int
0 then 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) 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] | forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mId -> do
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback forall (m :: * -> *) a. Monad m => a -> m a
return forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t)
Def QName
q [Elim]
es -> do
Definition
info <- forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
q
let lam_i :: Term -> Term
lam_i = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall a. Ord a => a -> a -> Bool
> Int
0, Just Args
as <- 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 forall a. Eq a => a -> a -> Bool
== Int
0
then forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
u0
else forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ (QName -> [Elim] -> Term
Def QName
transpR []) forall t. Apply t => t -> Args -> t
`apply`
(forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) Args
as forall a. [a] -> [a] -> [a]
++ [forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi,Arg Term
u0])
| Int
nelims forall a. Ord a => a -> a -> Bool
> Int
0, Just Args
as <- forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, TranspOrHComp
DoHComp <- TranspOrHComp
cmd, Just QName
hCompR <- CompKit -> Maybe QName
nameOfHComp CompKit
kit
-> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ (QName -> [Elim] -> Term
Def QName
hCompR []) forall t. Apply t => t -> Args -> t
`apply`
(Args
as forall a. [a] -> [a] -> [a]
++ [forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi,forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Term)
u,Arg Term
u0])
| Just Args
as <- forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, [] <- Defn -> [Dom QName]
recFields Defn
r -> 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 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}
| forall (t :: * -> *). Foldable t => t Bool -> Bool
and [forall a. Null a => a -> Bool
null [QName]
pcons | TranspOrHComp
DoHComp <- [TranspOrHComp
cmd]], Just Args
as <- forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es -> 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 forall a b. (a -> b) -> a -> b
$ forall a. Null a => a -> Bool
null forall a b. (a -> b) -> a -> b
$ [QName]
pcons) (Int
parsforall a. Num a => a -> a -> a
+Int
ixs) TranspOrHComp
cmd FamilyOrNot (Arg Term)
l (Args
as 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 -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ 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
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg a
u0
compSort TranspOrHComp
_ p
fallback p
phi Maybe a
u Arg a
u0 FamilyOrNot a
_ = forall a. HasCallStack => a
__IMPOSSIBLE__
compPi :: TranspOrHComp -> ArgName -> FamilyOrNot (Dom Type, Abs Type)
-> 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 = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd 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)
toLevel' a
t = do
Sort
s <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall a. LensSort a => a -> Sort
getSort a
t
case Sort
s of
(Type Level
l) -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just Level
l)
Sort
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
toLevel :: a -> f Level
toLevel a
t = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {m :: * -> *} {a}.
(MonadReduce m, LensSort a) =>
a -> m (Maybe Level)
toLevel' a
t
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (forall {m :: * -> *} {a}.
(MonadReduce m, LensSort a) =>
a -> m (Maybe Level)
toLevel' forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Subst a => Abs a -> a
absBody forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. FamilyOrNot a -> a
famThing forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom Type, Abs Type)
ab) (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ \ Level
_ -> do
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] 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 -> forall a. Names -> NamesT Fail a -> a
runNames [] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
a)))
IsNot (Dom Type
a,Abs Type
_) -> (Dom Type
a, forall a. a -> a
id)
Sort
s <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall a. LensSort a => a -> Sort
getSort Dom Type
x
case Sort
s of
Type Level
lx -> do
[NamesT ReduceM Term
la,NamesT ReduceM Term
bA] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
f) [Level -> Term
Level Level
lx, forall t a. Type'' t a -> a
unEl forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom forall a b. (a -> b) -> a -> b
$ Dom Type
x]
forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
phi NamesT ReduceM Term
a0 -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
j)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
j)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
a0
Sort
LockUniv -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just 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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
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 (forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing) forall a b. (a -> b) -> a -> b
$ \ (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
trA -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
[NamesT ReduceM Term
phi, NamesT ReduceM Term
u0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
phi, Arg Term
u0]
Maybe (NamesT ReduceM Term)
u <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (forall e. Arg e -> e
unArg forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Arg Term)
u)
forall (m :: * -> *).
MonadFail m =>
ArgInfo
-> [Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
glam (forall a. LensArgInfo a => a -> ArgInfo
getArgInfo (forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Dom Type, Abs Type)
ab)) (forall a. Abs a -> [Char]
absName forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Dom Type, Abs Type)
ab) 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 <- (forall a. Subst a => Int -> a -> a
raise Int
1 Abs Type
b forall a. Subst a => Abs a -> SubstArg a -> a
`absApp`) 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
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Level -> Term
Level forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall {f :: * -> *} {a}.
(MonadReduce f, LensSort a) =>
a -> f Level
toLevel Type
bT)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> forall (f :: * -> *) a. Applicative f => a -> f a
pure (forall t a. Type'' t a -> a
unEl forall a b. (a -> b) -> a -> b
$ Type
bT)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT ReduceM Term
i -> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
o -> forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (forall a. LensHiding a => a -> Hiding
getHiding Dom Type
a) (NamesT ReduceM Term
u forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o) NamesT ReduceM Term
v)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i)
NamesT ReduceM Term
u1
bB :: Term -> Type
bB Term
v = forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
v (forall a. Int -> Substitution' a -> Substitution' a
liftS Int
1 forall a b. (a -> b) -> a -> b
$ forall a. Int -> Substitution' a
raiseS Int
1) forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` (forall a. Subst a => Abs a -> a
absBody Abs Type
b )
tLam :: Abs Term -> Term
tLam = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo
Abs Type
bT <- 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" forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Type
bB forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamesT ReduceM Term -> NamesT ReduceM Term
v
(forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Abs Term -> Term
tLam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Level -> Term
Level forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: * -> *} {a}.
(MonadReduce f, LensSort a) =>
a -> f Level
toLevel) Abs Type
bT)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Term -> Term
tLam forall a b. (a -> b) -> a -> b
$ forall t a. Type'' t a -> a
unEl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs Type
bT)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (forall a. LensHiding a => a -> Hiding
getHiding Dom Type
a) NamesT ReduceM Term
u0 (NamesT ReduceM Term -> NamesT ReduceM Term
v (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz)))
(TranspOrHComp
_,FamilyOrNot (Dom Type, Abs Type)
_,Maybe (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 = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
j
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Names -> NamesT Fail a -> a
runNames [] forall a b. (a -> b) -> a -> b
$ do
[NamesT Fail Term
l,NamesT Fail Term
u,NamesT Fail Term
u0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
u,Arg Term
u0]
NamesT Fail Term
phi <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked' t (Arg Term)
sphi
[NamesT Fail Term
bA, NamesT Fail Term
x, NamesT Fail Term
y] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
bA, Arg Term
x, Arg Term
y]
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
j ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
l
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Fail Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
j)
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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
f1 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
f2 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" (\ NamesT Fail Term
_ -> NamesT Fail Term
bA 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT Fail Term
o 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))
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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (forall a b. a -> b -> a
const NamesT Fail Term
x)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (forall a b. a -> b -> a
const NamesT Fail Term
y)))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT Fail Term
u0 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
let getTermLocal :: [Char] -> ReduceM Term
getTermLocal = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
r
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
u
forall (m :: * -> *) a. Monad m => a -> m a
return 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 ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Fail Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT Fail Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT Fail Term
i -> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT Fail Term
o))
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 (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT Fail Term
u0
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Names -> NamesT Fail a -> a
runNames [] forall a b. (a -> b) -> a -> b
$ do
[NamesT Fail Term
l,NamesT Fail Term
u0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
u0]
NamesT Fail Term
phi <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked' t (Arg Term)
sphi
[NamesT Fail Term
bA, NamesT Fail Term
x, NamesT Fail Term
y] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Names -> NamesT Fail a -> a
runNames [] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
a))) [Arg Term
bA, Arg Term
x, Arg Term
y]
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" 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 (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
i -> NamesT Fail Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i 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))
(forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i'" 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
f1 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
f2 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"_" (\ NamesT Fail Term
_ -> NamesT Fail Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT Fail Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT Fail Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT Fail Term
j))
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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (forall a b. a -> b -> a
const (NamesT Fail Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"_" (forall a b. a -> b -> a
const (NamesT Fail Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT Fail Term
i))))
(NamesT Fail Term
u0 forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT Fail Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT Fail Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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)
_ = 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 = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd forall a. [a] -> [a] -> [a]
++ [Char]
" for " forall a. [a] -> [a] -> [a]
++ [Char]
builtinId
IntervalView -> Term
unview <- forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
Maybe QName
mConId <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getBuiltinName' [Char]
builtinConId
let isConId :: Term -> Bool
isConId (Def QName
q [Elim]
_) = forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mConId
isConId Term
_ = Bool
False
Blocked (Arg Term)
sa0 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
a0
Bool
b <- case Maybe (Arg Term)
u of
Maybe (Arg Term)
Nothing -> 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 (forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked' t (Arg Term)
sphi) (forall e. Arg e -> e
unArg Arg Term
u) Term -> Bool
isConId
case Maybe QName
mConId of
Just QName
conid | Term -> Bool
isConId (forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sa0) , Bool
b -> (forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. (forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) 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
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
let io :: NamesT ReduceM Term
io = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ IntervalView -> Term
unview IntervalView
IOne
iz :: NamesT ReduceM Term
iz = forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ IntervalView -> Term
unview IntervalView
IZero
conId :: NamesT ReduceM Term
conId = forall (f :: * -> *) a. Applicative f => a -> f a
pure 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 -> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ Arg Term
l
IsNot Arg Term
l -> do
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> a -> Abs a
NoAbs [Char]
"_" forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
l)
[NamesT ReduceM Term
p0] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ Arg Term
u
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i NamesT ReduceM Term
o -> NamesT ReduceM Term
u forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o
Maybe (Arg Term)
Nothing -> do
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i NamesT ReduceM Term
o -> NamesT ReduceM Term
p0
NamesT ReduceM Term
phi <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking 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) -> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (\ Arg Term
a -> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Names -> NamesT Fail a -> a
runNames [] forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (forall a b. a -> b -> a
const (forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ 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) -> 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] forall a b. (a -> b) -> a -> b
$ \ Arg Term
a -> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> a -> Abs a
NoAbs [Char]
"_" forall a b. (a -> b) -> a -> b
$ 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u0
NamesT ReduceM Term
conId forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" (\ NamesT ReduceM Term
o -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tFace forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
io)
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)))
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
(forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPathType forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i))
NamesT ReduceM Term
phi
(forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
o -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPath forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i)
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)
)
(forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPath forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
iz) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
iz) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
iz) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
y forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
iz)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
p0)
)
Maybe QName
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ 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 <- forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Int Bool, [Term])]
decomposeInterval Term
phi
forall (f :: * -> *) (m :: * -> *).
(Foldable f, Monad m) =>
f (m Bool) -> m Bool
andM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [(Map Int Bool, [Term])]
as forall a b. (a -> b) -> a -> b
$ \ (Map Int Bool
bs,[Term]
ts) -> do
let u' :: Term
u' = forall a. EndoSubst a => [(Int, a)] -> Substitution' a
listS (forall k a. Map k a -> [(k, a)]
Map.toAscList forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Bool -> Term
boolToI Map Int Bool
bs) forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u
Blocked' Term Term
t <- Term -> ReduceM (Blocked' Term Term)
reduce2Lam Term
u'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! Term -> Bool
p forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term Term
t
reduce2Lam :: Term -> ReduceM (Blocked' Term Term)
reduce2Lam Term
t = do
Term
t <- forall t. Reduce t => t -> ReduceM t
reduce' Term
t
case Term -> Abs Term
lam2Abs Term
t of
Abs Term
t -> forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs Term
t forall a b. (a -> b) -> a -> b
$ \ Term
t -> do
Term
t <- forall t. Reduce t => t -> ReduceM t
reduce' Term
t
case Term -> Abs Term
lam2Abs Term
t of
Abs Term
t -> forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs Term
t forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB'
where
lam2Abs :: Term -> Abs Term
lam2Abs (Lam ArgInfo
_ Abs Term
t) = forall a. Subst a => Abs a -> a
absBody Abs Term
t forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Abs Term
t
lam2Abs Term
t = forall a. [Char] -> a -> Abs a
Abs [Char]
"y" (forall a. Subst a => Int -> a -> a
raise Int
1 Term
t forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN 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 (forall a. [Char] -> a -> Abs a
Abs [Char]
"i" (ArgInfo -> Abs Term -> Term
Lam (forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant ArgInfo
defaultArgInfo) (forall a. [Char] -> a -> Abs a
Abs [Char]
"o" Term
t)))
[(Map Int Bool, [Term])]
as <- forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Int Bool, [Term])]
decomposeInterval Term
phi
([a]
flags,[Maybe (Blocked' Term Term, Map Int Bool)]
t_alphas) <- forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. [(a, b)] -> ([a], [b])
unzip forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Map Int Bool, [Term])]
as forall a b. (a -> b) -> a -> b
$ \ (Map Int Bool
bs,[Term]
ts) -> do
let u' :: Term
u' = forall a. EndoSubst a => [(Int, a)] -> Substitution' a
listS [(Int, Term)]
bs' forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u
bs' :: [(Int, Term)]
bs' = (forall k a. Map k a -> [(k, a)]
Map.toAscList forall a b. (a -> b) -> a -> b
$ forall a b k. (a -> b) -> Map k a -> Map k b
Map.map Bool -> Term
boolToI Map Int Bool
bs)
let weaken :: Substitution' Term
weaken = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Int
j Substitution' Term
s -> Substitution' Term
s forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` forall a. Int -> Int -> Substitution' a
raiseFromS Int
j Int
1) forall a. Substitution' a
idS (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Int, Term)]
bs')
Blocked' Term Term
t <- Term -> ReduceM (Blocked' Term Term)
reduce2Lam Term
u'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ (Term -> a
p forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term Term
t, forall a. [a] -> Maybe a
listToMaybe [ (Substitution' Term
weaken forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` (Term -> Term
lamlam forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked' Term Term
t),Map Int Bool
bs) | forall a. Null a => a -> Bool
null [Term]
ts ])
forall (m :: * -> *) a. Monad m => a -> m a
return 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 = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd forall a. [a] -> [a] -> [a]
++ [Char]
" for data types"
let sc :: Blocked (Arg Term)
sc = forall a. FamilyOrNot a -> a
famThing 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 forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
t]
iMin :: Term -> Term -> Term
iMin Term
t Term
u = Term
tMin forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
t, forall e. e -> Arg e
argN Term
u]
iz :: NamesT ReduceM Term
iz = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iZ
Term -> Term
constrForm <- do
Maybe Term
mz <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe Term)
getTerm' [Char]
builtinZero
Maybe Term
ms <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe Term)
getTerm' [Char]
builtinSuc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ Term
t -> forall a. a -> Maybe a -> a
fromMaybe Term
t (forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> Term -> m Term
constructorForm' Maybe Term
mz Maybe Term
ms Term
t)
Blocked (Arg Term)
su <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
u
Blocked (Arg Term)
sa0 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
a0
Term -> IntervalView
view <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
IntervalView -> Term
unview <- forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
let f :: Blocked' t (Arg c) -> c
f = forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking
phi :: Term
phi = forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sphi
a0 :: Term
a0 = forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sa0
isLit :: Term -> Maybe Term
isLit t :: Term
t@(Lit Literal
lt) = forall a. a -> Maybe a
Just Term
t
isLit Term
_ = forall a. Maybe a
Nothing
isCon :: Term -> Maybe ConHead
isCon (Con ConHead
h ConInfo
_ [Elim]
_) = forall a. a -> Maybe a
Just ConHead
h
isCon Term
_ = 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)
= forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
psi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst) NamesT ReduceM Term
iz [(NamesT ReduceM Term, NamesT ReduceM Term)]
xs
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u 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 = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction [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 -> forall a t. a -> Blocked' t a
notBlocked forall a b. (a -> b) -> a -> b
$ forall e. e -> Arg e
argN forall a b. (a -> b) -> a -> b
$ forall a. Names -> NamesT Fail a -> a
runNames [] forall a b. (a -> b) -> a -> b
$ do
[NamesT Fail Term
l,NamesT Fail Term
c] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
l,forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc]
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
i -> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEmpty forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
l
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 = forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
su
([(Bool, Bool)]
b, [Maybe (Blocked' Term Term, Map Int Bool)]
ts) <- 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 forall a b. (a -> b) -> a -> b
$ \ Term
t ->
(Term -> Maybe Term
isLit Term
t forall a. Eq a => a -> a -> Bool
== Maybe Term
lt, Term -> Maybe ConHead
isCon (Term -> Term
constrForm Term
t) forall a. Eq a => a -> a -> Bool
== Maybe ConHead
h)
let
([Bool]
lit,[Bool]
hd) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, Bool)]
b
if forall a. Maybe a -> Bool
isJust Maybe Term
lt Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
lit then forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
a0 else do
Blocked (Arg Term)
su <- forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
sequence [Maybe (Blocked' Term Term, Map Int Bool)]
ts) (forall (m :: * -> *) a. Monad m => a -> m a
return Blocked (Arg Term)
su) forall a b. (a -> b) -> a -> b
$ \ [(Blocked' Term Term, Map Int Bool)]
ts -> do
let ([Blocked' Term Term]
us,[Map Int Bool]
bools) = forall a b. [(a, b)] -> ([a], [b])
unzip [(Blocked' Term Term, Map Int Bool)]
ts
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_ [Blocked' Term Term]
us forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Arg e
argN) forall a b. (a -> b) -> a -> b
$ do
let
phis :: [Term]
phis :: [Term]
phis = forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [Map Int Bool]
bools forall a b. (a -> b) -> a -> b
$ \ Map Int Bool
m ->
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Term -> Term -> Term
iMin 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 (forall k a. Map k a -> [(k, a)]
Map.toList Map Int Bool
m)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
NamesT ReduceM Term
u <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u
[NamesT ReduceM Term
l,NamesT ReduceM Term
c] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
l,forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc]
[NamesT ReduceM Term]
phis <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Term]
phis
[NamesT ReduceM Term]
us <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking) [Blocked' Term Term]
us
forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) forall a b. (a -> b) -> a -> b
$ forall a b. [a] -> [b] -> [(a, b)]
zip [NamesT ReduceM Term]
phis (forall a b. (a -> b) -> [a] -> [b]
map (\ NamesT ReduceM Term
t -> NamesT ReduceM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) [NamesT ReduceM Term]
us)
if forall a. Maybe a -> Bool
isJust Maybe ConHead
h Bool -> Bool -> Bool
&& forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
hd then ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
k (forall a. a -> Maybe a -> a
fromMaybe 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 forall a b. (a -> b) -> a -> b
$ \ ConHead
h Blocked (Arg Term)
su -> do
let u :: Term
u = forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
su
Constructor{ conComp :: Defn -> CompKit
conComp = CompKit
cm } <- Definition -> Defn
theDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
h)
case CompKit -> Maybe QName
nameOfHComp CompKit
cm of
Just QName
hcompD -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
hcompD [] forall t. Apply t => t -> Args -> t
`apply`
(Args
ps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map 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 = forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ 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 = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm forall a b. (a -> b) -> a -> b
$ TranspOrHComp -> [Char]
cmdToName TranspOrHComp
cmd forall a. [a] -> [a] -> [a]
++ [Char]
" for data types"
let sc :: Blocked (Arg Term)
sc = forall a. FamilyOrNot a -> a
famThing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
fsc
Maybe QName
mhcompName <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getName' [Char]
builtinHComp
Term -> Term
constrForm <- do
Maybe Term
mz <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe Term)
getTerm' [Char]
builtinZero
Maybe Term
ms <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe Term)
getTerm' [Char]
builtinSuc
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ \ Term
t -> forall a. a -> Maybe a -> a
fromMaybe Term
t (forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> Term -> m Term
constructorForm' Maybe Term
mz Maybe Term
ms Term
t)
Blocked (Arg Term)
sa0 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
a0
let f :: Blocked' t (Arg c) -> c
f = forall e. Arg e -> e
unArg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t a. Blocked' t a -> a
ignoreBlocking
phi :: Term
phi = forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sphi
a0 :: Term
a0 = forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sa0
noRed :: ReduceM (Reduced MaybeReducedArgs Term)
noRed = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction [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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
h)
case CompKit -> Maybe QName
nameOfTransp CompKit
cm of
Just QName
transpD -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
transpD [] forall t. Apply t => t -> Args -> t
`apply`
(forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) Args
ps forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map 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, forall a. a -> Maybe a
Just QName
q 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] <- forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es -> do
let bC :: Arg Term
bC = 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
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] 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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
bC,forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi,Arg Term
psi,Arg Term
u,Arg Term
u0]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
hcomp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bC forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
psi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" (\ NamesT ReduceM Term
j -> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
o ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
transp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
bC forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
u forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
transp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
bC forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi 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
_ = forall a. HasCallStack => a
__IMPOSSIBLE__
primComp :: TCM PrimitiveImpl
primComp :: TCM PrimitiveImpl
primComp = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"a" (forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Functor m => m Term -> m Type
el (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"A" (forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
i -> (Sort -> Type
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i))) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
bA ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
phi ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT TCM Term
i -> 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 forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i) (NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i)) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
(forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) (NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne) (NamesT TCM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne))
Term
one <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
Term
io <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
IntervalView
vphi <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi
case IntervalView
vphi of
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn (forall e. Arg e -> e
unArg Arg Term
u forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
io, forall e. e -> Arg e
argN Term
one])
IntervalView
_ -> do
let getTermLocal :: [Char] -> ReduceM Term
getTermLocal = forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm 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
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> NamesT ReduceM Term
la 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> NamesT ReduceM Term
bA 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))
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
r
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u
forall (m :: * -> *) a. Monad m => a -> m a
return 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 ->
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
phi
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT ReduceM Term
i -> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam [Char]
"o" 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o))
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 (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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_ -> 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 <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) (\ NamesT TCM Term
la ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"T" (forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> 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
φ forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> Sort -> Type
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"A" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSub forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
φ forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a -> do
let bA :: NamesT TCM Term
bA = (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSubOut forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a)
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 -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la (NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT TCM Term
o))
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la NamesT TCM Term
bA)
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA))
Term -> IntervalView
view <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
Term
one <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
6 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
case Term -> IntervalView
view forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
t forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
one]
IntervalView
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
la] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
bA,Arg Term
t,Arg Term
a])
Args
_ -> 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 <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) (\ NamesT TCM Term
la ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"T" (forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"i" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> 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
φ forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> Sort -> Type
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"A" (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSub forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
φ forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a -> do
let bA :: NamesT TCM Term
bA = (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSubOut forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primHComp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
bA)
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la NamesT TCM Term
bA)
Term -> IntervalView
view <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
Term
one <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
Maybe QName
mglueU <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtin_glueU
Maybe QName
mtransp <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinTrans
Maybe QName
mHCompU <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinHComp
let mhcomp :: Maybe QName
mhcomp = Maybe QName
mHCompU
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
5 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
case Term -> IntervalView
view forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
IntervalView
IOne -> do
Term
tTransp <- forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtin_unglueU [Char]
builtinTrans
Term
iNeg <- forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtin_unglueU [Char]
builtinINeg
Term
iZ <- forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtin_unglueU [Char]
builtinIZero
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
[NamesT ReduceM Term
la,NamesT ReduceM Term
bT,NamesT ReduceM Term
b] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
la,Arg Term
bT,Arg Term
b]
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m 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 forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iNeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
one)
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iZ
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
b
IntervalView
_ -> do
Blocked (Arg Term)
sb <- 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
la] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
bA] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sb])
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking 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]
| forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mglueU -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ 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]
| forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mtransp -> do
Blocked (Arg Term)
sbA <- forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Arg Term
bA
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sbA of
Lam ArgInfo
_ Abs Term
t -> do
Blocked' Term Term
st <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (forall a. Subst a => Abs a -> a
absBody Abs Term
t)
case 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] <- forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, forall a. a -> Maybe a
Just QName
h forall a. Eq a => a -> a -> Bool
== Maybe QName
mHCompU -> do
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 forall a. Maybe a
Nothing Arg Term
u0 (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 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]
| forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mhcomp -> do
Blocked (Arg Term)
sbA <- forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Arg Term
bA
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ 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] <- forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, forall a. a -> Maybe a
Just QName
h forall a. Eq a => a -> a -> Bool
== Maybe QName
mHCompU -> do
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 (forall a. a -> Maybe a
Just Arg Term
u) Arg Term
u0 (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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
la] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
bA] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sb])
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primGlue' :: TCM PrimitiveImpl
primGlue' :: TCM PrimitiveImpl
primGlue' = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CFull [Char]
""
Type
t <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) (\ NamesT TCM Term
la ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"lb" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
lb ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' [Char]
"T" (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
φ forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
lb)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
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 -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primEquiv forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
o) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a)
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (Sort -> Type
sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
lb))
Term -> IntervalView
view <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
Term
one <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
6 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
case Term -> IntervalView
view forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
t forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
one]
IntervalView
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
la,Arg Term
lb,Arg Term
a] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
t,Arg Term
e])
Args
_ -> 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 <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) (\ NamesT TCM Term
la ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"lb" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
lb ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"T" (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
φ forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
lb)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"e" (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
φ forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primEquiv forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
o) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
e ->
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 -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
lb (NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
o)) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> (forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
lb (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primGlue forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
e)))
Term -> IntervalView
view <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
Term
one <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
8 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
case Term -> IntervalView
view forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
IntervalView
IOne -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
t forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
one]
IntervalView
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
la,Arg Term
lb,Arg Term
bA] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
e,Arg Term
t,Arg Term
a])
Args
_ -> 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 <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"la" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) (\ NamesT TCM Term
la ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"lb" (forall (m :: * -> *). Functor m => m Term -> m Type
el forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
lb ->
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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
la) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
a ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"φ" forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
φ ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"T" (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
φ forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) (Sort -> Term
Sort forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
lb)) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
t ->
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
[Char]
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' [Char]
"e" (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
φ forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelMax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
lb) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primEquiv forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
o) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a) forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
e ->
(forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
lb (forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primGlue forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
lb forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
a forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
φ forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
t forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
e)) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT TCM Term
la NamesT TCM Term
a)
Term -> IntervalView
view <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
Term
one <- forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
Maybe QName
mGlue <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinGlue
Maybe QName
mglue <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtin_glue
Maybe QName
mtransp <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinTrans
Maybe QName
mhcomp <- forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getPrimitiveName' [Char]
builtinHComp
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
7 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 <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
case Term -> IntervalView
view forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
IntervalView
IOne -> do
let argOne :: Arg Term
argOne = forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant forall a b. (a -> b) -> a -> b
$ forall e. e -> Arg e
argN Term
one
Term
tEFun <- forall (m :: * -> *). HasBuiltins m => [Char] -> [Char] -> m Term
getTerm [Char]
builtin_unglue [Char]
builtinEquivFun
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ Term
tEFun forall t. Apply t => t -> Args -> t
`apply` [Arg Term
lb,Arg Term
la,forall e. e -> Arg e
argH forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
bT forall t. Apply t => t -> Args -> t
`apply` [Arg Term
argOne],Arg Term
bA, forall e. e -> Arg e
argN forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Term
e forall t. Apply t => t -> Args -> t
`apply` [Arg Term
argOne],Arg Term
b]
IntervalView
_ -> do
Blocked (Arg Term)
sb <- 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 = forall (m :: * -> *) a. Monad m => a -> m a
return (forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
la,Arg Term
lb] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced [Blocked (Arg Term)
sbA, Blocked (Arg Term)
sphi] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
e] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sb])
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking 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]
| forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mglue -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall a b. (a -> b) -> a -> b
$ 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]
| forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mtransp -> do
Blocked (Arg Term)
sbA <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
bA
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sbA of
Lam ArgInfo
_ Abs Term
t -> do
Blocked' Term Term
st <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (forall a. Subst a => Abs a -> a
absBody Abs Term
t)
case 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'] <- forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, forall a. a -> Maybe a
Just QName
g forall a. Eq a => a -> a -> Bool
== Maybe QName
mGlue -> do
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 forall a. Maybe a
Nothing Arg Term
u0 (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 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]
| forall a. a -> Maybe a
Just QName
q forall a. Eq a => a -> a -> Bool
== Maybe QName
mhcomp -> do
Blocked (Arg Term)
sbA <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
bA
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ 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'] <- forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, forall a. a -> Maybe a
Just QName
g forall a. Eq a => a -> a -> Bool
== Maybe QName
mGlue -> do
forall a a'. a -> ReduceM (Reduced a' a)
redReturn forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< 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 (forall a. a -> Maybe a
Just Arg Term
u) Arg Term
u0 (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
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall no yes. no -> Reduced no yes
NoReduction forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
la,Arg Term
lb,Arg Term
bA] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a. a -> MaybeReduced a
notReduced [Arg Term
bT,Arg Term
e] forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sb])
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
primFaceForall' :: TCM PrimitiveImpl
primFaceForall' :: TCM PrimitiveImpl
primFaceForall' = do
Cubical -> [Char] -> TCM ()
requireCubical Cubical
CErased [Char]
""
Type
t <- (forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType) forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t forall a b. (a -> b) -> a -> b
$ QName
-> Int
-> (Args -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun forall a. HasCallStack => a
__IMPOSSIBLE__ Int
1 forall a b. (a -> b) -> a -> b
$ \Args
ts -> case Args
ts of
[Arg Term
phi] -> do
Blocked (Arg Term)
sphi <- forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
case forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall t a. Blocked' t a -> a
ignoreBlocking forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
Lam ArgInfo
_ Abs Term
t -> do
Abs Term
t <- forall t. Reduce t => t -> ReduceM t
reduce' Abs Term
t
case Abs Term
t of
NoAbs [Char]
_ Term
t -> forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
t
Abs [Char]
_ Term
t ->
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall no yes. no -> Reduced no yes
NoReduction [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi]) forall a a'. a -> ReduceM (Reduced a' a)
redReturn
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {m :: * -> *}. HasBuiltins m => Term -> m (Maybe Term)
toFaceMapsPrim Term
t
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall no yes. no -> Reduced no yes
NoReduction [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi])
Args
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
where
toFaceMapsPrim :: Term -> m (Maybe Term)
toFaceMapsPrim Term
t = do
Term -> IntervalView
view <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
IntervalView -> Term
unview <- forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
[(Map Int Bool, [Term])]
us' <- forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Int Bool, [Term])]
decomposeInterval Term
t
Term
fr <- 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 =
[ forall a b. (a -> b) -> [a] -> [b]
map forall a b. a -> Either a b
Left (forall k a. Map k a -> [(k, a)]
Map.toList Map Int Bool
bsm) forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. b -> Either a b
Right [Term]
ts
| (Map Int Bool
bsm, [Term]
ts) <- [(Map Int Bool, [Term])]
us',
Int
0 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 forall a. Num a => a -> a -> a
- Int
1) else IntervalView -> Term
unview (Arg Term -> IntervalView
INeg (forall e. e -> Arg e
argN (Int -> Term
var forall a b. (a -> b) -> a -> b
$ Int
i forall a. Num a => a -> a -> a
- Int
1)))
ffr :: Term -> Term
ffr Term
t = Term
fr forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> a -> Abs a
Abs [Char]
"i" Term
t]
r :: Maybe Term
r =
forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$
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 (forall e. e -> Arg e
argN Term
x) (forall e. e -> Arg e
argN Term
r)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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 (forall e. e -> Arg e
argN (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)) (forall e. e -> Arg e
argN Term
r)))
(IntervalView -> Term
unview IntervalView
IOne)
)
(IntervalView -> Term
unview IntervalView
IZero)
[[Either (Int, Bool) Term]]
us
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [(Map Int Bool, [Term])]
us' of
[(Map Int Bool
m, [Term
_])] | forall k a. Map k a -> Bool
Map.null Map Int Bool
m -> 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 <- 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 = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\ Set a
xs -> forall a. Set a -> Int
Set.size Set a
xs forall a. Eq a => a -> a -> Bool
== Int
1) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Map k a -> [a]
Map.elems forall a b. (a -> b) -> a -> b
$ Map k (Set a)
xs
forall (m :: * -> *) a. Monad m => a -> m a
return [ (forall a b k. (a -> b) -> Map k a -> Map k b
Map.map (forall a. [a] -> a
head forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
, 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 <- forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
IntervalView -> Term
unview <- forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
let f :: IntervalView -> [[Either (Int,Bool) Term]]
f :: IntervalView -> [[Either (Int, Bool) Term]]
f IntervalView
IZero = forall (m :: * -> *) a. MonadPlus m => m a
mzero
f IntervalView
IOne = 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> IntervalView
view forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) Arg Term
x; [Either (Int, Bool) Term]
ys <- (IntervalView -> [[Either (Int, Bool) Term]]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> IntervalView
view forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) Arg Term
y; forall (m :: * -> *) a. Monad m => a -> m a
return ([Either (Int, Bool) Term]
xs forall a. [a] -> [a] -> [a]
++ [Either (Int, Bool) Term]
ys)
f (IMax Arg Term
x Arg Term
y) = forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, MonadPlus m) =>
t (m a) -> m a
msum forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (IntervalView -> [[Either (Int, Bool) Term]]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> IntervalView
view forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) [Arg Term
x,Arg Term
y]
f (INeg Arg Term
x) = forall a b. (a -> b) -> [a] -> [b]
map (forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (\ (Int
x,Bool
y) -> forall a b. a -> Either a b
Left (Int
x,Bool -> Bool
not Bool
y)) (forall a b. b -> Either a b
Right forall b c a. (b -> c) -> (a -> b) -> a -> c
. IntervalView -> Term
unview forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> IntervalView
INeg forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. e -> Arg e
argN)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IntervalView -> [[Either (Int, Bool) Term]]
f forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> IntervalView
view forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) Arg Term
x
f (OTerm (Var Int
i [])) = forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. a -> Either a b
Left (Int
i,Bool
True)]
f (OTerm Term
t) = forall (m :: * -> *) a. Monad m => a -> m a
return [forall a b. b -> Either a b
Right Term
t]
v :: IntervalView
v = Term -> IntervalView
view Term
t
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) = forall a b. [Either a b] -> ([a], [b])
partitionEithers [Either (Int, Bool) Term]
xs
, let bsm :: Map Int (Set Bool)
bsm = (forall k a. Ord k => (a -> a -> a) -> [(k, a)] -> Map k a
Map.fromListWith forall a. Ord a => Set a -> Set a -> Set a
Set.union forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a -> b) -> [a] -> [b]
map (forall a. a -> a
id forall a c b d. (a -> c) -> (b -> d) -> (a, b) -> (c, d)
-*- forall a. a -> Set a
Set.singleton)) [(Int, Bool)]
bs
]
transpTel :: Abs Telescope
-> Term
-> Args
-> ExceptT (Closure (Abs Type)) TCM Args
transpTel :: Abs Telescope
-> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args
transpTel Abs Telescope
delta Term
phi Args
args = do
Term
tTransp <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primTrans
Term
imin <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin
Term
imax <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax
Term
ineg <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
let
noTranspError :: a -> t m b
noTranspError a
t = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (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 = forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Abs a)
t 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 = forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t a. Type'' t a -> a
unEl forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t) forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
phi 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
NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
xi <- (forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ do
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" forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i -> do
TelV Telescope
xi Type
_ <- (forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) forall a b. (a -> b) -> a -> b
$ NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i
forall (m :: * -> *) a. Monad m => a -> m a
return Telescope
xi
[Arg [Char]]
argnames <- do
Telescope -> [Arg [Char]]
teleArgNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Abs a -> a
unAbs forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
xi
forall (m :: * -> *).
(Functor m, MonadFail m) =>
[Arg [Char]] -> (NamesT m Args -> NamesT m Term) -> NamesT m Term
glamN [Arg [Char]]
argnames forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Args
xi_args -> do
Abs Type
b' <- 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" 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 forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i
Abs Telescope
xin <- 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" forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
xi forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg 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 <- forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
piApplyM Type
ti 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 <- 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" forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Telescope)
xi forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg 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
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall t. Apply t => t -> Args -> t
apply Term
a 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 <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall a. LensSort a => a -> Sort
getSort (forall a. Subst a => Abs a -> a
absBody Abs Type
b')
case Sort
s of
Type Level
l -> do
NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ Term -> Term
lam_i (Level -> Term
Level Level
l)
NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
b' <- 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 <- 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 (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 forall a. Free a => Int -> a -> Bool
`freeIn` (forall a. Subst a => Int -> a -> a
raise Int
1 Abs Type
b' forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Int -> Term
var Int
0) then forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadError (Closure a) m, MonadTCM (t m)) =>
a -> t m b
noTranspError Abs Type
b' else forall (m :: * -> *) a. Monad m => a -> m a
return Term
axi
SSet Level
_ ->
if Int
0 forall a. Free a => Int -> a -> Bool
`freeIn` (forall a. Subst a => Int -> a -> a
raise Int
1 Abs Type
b' forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Int -> Term
var Int
0) then forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadError (Closure a) m, MonadTCM (t m)) =>
a -> t m b
noTranspError Abs Type
b' else forall (m :: * -> *) a. Monad m => a -> m a
return Term
axi
Sort
_ -> 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 forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
_ [] = 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
Sort
s <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall a. LensSort a => a -> Sort
getSort Dom Type
t
(Term
b,Term
bf) <- forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] forall a b. (a -> b) -> a -> b
$ do
Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
l <- case Sort
s of
SSet Level
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Inf IsFibrant
_ Integer
n -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Type Level
l -> forall a. a -> Maybe a
Just forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> Term
lam_i (Level -> Term
Level Level
l))
Sort
_ -> forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadTrans t, MonadError (Closure a) m, MonadTCM (t m)) =>
a -> t m b
noTranspError (forall a. [Char] -> a -> Abs a
Abs [Char]
"i" (forall t e. Dom' t e -> e
unDom Dom Type
t))
NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t <- forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open forall a b. (a -> b) -> a -> b
$ forall a. [Char] -> a -> Abs a
Abs [Char]
"i" (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] <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Term
phi, 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 <- 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" 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 ((forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NamesT (ExceptT (Closure (Abs Type)) TCM) Term)
l) forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l -> forall (m :: * -> *).
MonadFail m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"j" forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
j -> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
l forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
j))
(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" forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) TCM) Term
j -> NamesT (ExceptT (Closure (Abs Type)) TCM) (Abs Type)
t forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
j))
(forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imax forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) TCM) Term
i) 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
forall (m :: * -> *) a. Monad m => a -> m a
return (Term
b, forall a. Subst a => Abs a -> a
absBody Abs Term
bf)
(:) (Term
b forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Term
a) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args
go (forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp Abs Telescope
delta Term
bf) Term
phi Args
args
go (ExtendTel Dom Type
t Abs Telescope
delta) Term
phi [] = forall a. HasCallStack => a
__IMPOSSIBLE__
go Telescope
EmptyTel Term
_ (Arg Term
_:Args
_) = forall a. HasCallStack => a
__IMPOSSIBLE__
Telescope -> Term -> Args -> ExceptT (Closure (Abs Type)) TCM Args
go (forall a. Subst a => Abs a -> a
absBody Abs Telescope
delta) Term
phi Args
args
trFillTel :: Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) TCM Args
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 <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin
Term
imax <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax
Term
ineg <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM 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 (forall a. [Char] -> a -> Abs a
Abs [Char]
"j" forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Int -> a -> a
raise Int
1 Abs Telescope
delta forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` (Term
imin forall t. Apply t => t -> Args -> t
`apply` (forall a b. (a -> b) -> [a] -> [b]
map forall e. e -> Arg e
argN [Int -> Term
var Int
0, forall a. Subst a => Int -> a -> a
raise Int
1 Term
r])))
(Term
imax forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN forall a b. (a -> b) -> a -> b
$ Term
ineg forall t. Apply t => t -> Args -> t
`apply` [forall e. e -> Arg e
argN Term
r], forall e. e -> Arg e
argN Term
phi])
Args
args