{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TypeFamilies #-}
module Agda.TypeChecking.Primitive.Cubical
( module Agda.TypeChecking.Primitive.Cubical
, module Agda.TypeChecking.Primitive.Cubical.Id
, module Agda.TypeChecking.Primitive.Cubical.Base
, module Agda.TypeChecking.Primitive.Cubical.Glue
, module Agda.TypeChecking.Primitive.Cubical.HCompU
)
where
import Prelude hiding (null, (!!))
import Control.Monad
import Control.Monad.Except
import Control.Monad.Trans ( lift )
import Control.Exception
import Data.String ()
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import qualified Data.List as List
import Data.Foldable hiding (null)
import Agda.Syntax.Common
import Agda.Syntax.Internal
import Agda.Syntax.Internal.Pattern
import qualified Agda.Syntax.Common.Pretty as P
import Agda.TypeChecking.Names
import Agda.TypeChecking.Positivity.Occurrence
import Agda.TypeChecking.Primitive.Base
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Free
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Telescope
import Agda.Utils.Either
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Impossible
import Agda.Utils.Maybe
import Agda.Utils.Null
import Agda.Utils.Tuple
import Agda.Utils.Size
import Agda.Utils.BoolSet (BoolSet)
import qualified Agda.Utils.BoolSet as BoolSet
import Agda.TypeChecking.Primitive.Cubical.HCompU
import Agda.TypeChecking.Primitive.Cubical.Glue
import Agda.TypeChecking.Primitive.Cubical.Base
import Agda.TypeChecking.Primitive.Cubical.Id
primPOr :: TCM PrimitiveImpl
primPOr :: TCM PrimitiveImpl
primPOr = do
Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
Type
t <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel)) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
a ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"j" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"A" (String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
j) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
a) (Sort -> Term
Sort (Sort -> Term) -> (Term -> Sort) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Term) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a)) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
bA ->
((String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"i1" NamesT (TCMT IO) Term
i ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i1 -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne1 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i1))) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
((String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"j1" NamesT (TCMT IO) Term
j ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
j1 -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne2 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
j1))) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT (TCMT IO) Term
i NamesT (TCMT IO) Term
j) (\ NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o)
PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
6 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
ts -> do
case [Arg Term]
ts of
[Arg Term
l,Arg Term
i,Arg Term
j,Arg Term
a,Arg Term
u,Arg Term
v] -> do
Blocked (Arg Term)
si <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
i
IntervalView
vi <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
si
case IntervalView
vi of
IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u)
IntervalView
IZero -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
v)
IntervalView
_ -> do
Blocked (Arg Term)
sj <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
j
IntervalView
vj <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sj
case IntervalView
vj of
IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
v)
IntervalView
IZero -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u)
IntervalView
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
l,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
si,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sj,Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
a,Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
u,Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
v]
[Arg Term]
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
primPartial' :: TCM PrimitiveImpl
primPartial' :: TCM PrimitiveImpl
primPartial' = do
Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
Type
t <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel)) (\ NamesT (TCMT IO) Term
a ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"A" (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
bA ->
(Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a))
Term
isOne <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne
Term
v <- Names -> NamesT (TCMT IO) Term -> TCMT IO Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Term -> TCMT IO Term)
-> NamesT (TCMT IO) Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$
String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"a" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
l ->
String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"φ" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
phi ->
String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"A" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
a ->
Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"p" NamesT (TCMT IO) Term
phi (\NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
a)
PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
0 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
_ -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
v
primPartialP' :: TCM PrimitiveImpl
primPartialP' :: TCM PrimitiveImpl
primPartialP' = do
Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
Type
t <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel)) (\ NamesT (TCMT IO) Term
a ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
phi ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"A" (String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" NamesT (TCMT IO) Term
phi ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
a) (Sort -> Term
Sort (Sort -> Term) -> (Term -> Sort) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Term) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a)) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
bA ->
(Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a))
Term
v <- Names -> NamesT (TCMT IO) Term -> TCMT IO Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Term -> TCMT IO Term)
-> NamesT (TCMT IO) Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$
String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"a" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
l ->
String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"φ" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
phi ->
String
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"A" ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
a ->
Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"p" NamesT (TCMT IO) Term
phi (\ NamesT (TCMT IO) Term
p -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
l (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
p))
PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
0 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
_ -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
v
primSubOut' :: TCM PrimitiveImpl
primSubOut' :: TCM PrimitiveImpl
primSubOut' = do
Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
Type
t <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel)) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
a ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"A" (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevelSuc NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
a) (Sort -> Term
Sort (Sort -> Term) -> (Term -> Sort) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Term) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a)) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
bA ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
phi ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"u" (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT (TCMT IO) Term
a (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primPartial NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
bA) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
u ->
NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el's NamesT (TCMT IO) Term
a (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primSub NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
u) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
bA
PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
5 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \ [Arg Term]
ts -> do
case [Arg Term]
ts of
[Arg Term
a,Arg Term
bA,Arg Term
phi,Arg Term
u,Arg Term
x] -> do
Term -> IntervalView
view <- ReduceM (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
case Term -> IntervalView
view (Term -> IntervalView) -> Term -> IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi of
IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u) ReduceM Term -> ReduceM Term -> ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> String -> BuiltinId -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (PrimitiveId -> String
forall a. IsBuiltin a => a -> String
getBuiltinId PrimitiveId
PrimSubOut) BuiltinId
BuiltinItIsOne)
IntervalView
_ -> do
Blocked (Arg Term)
sx <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
x
Maybe QName
mSubIn <- BuiltinId -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe QName)
getBuiltinName' BuiltinId
builtinSubIn
case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sx of
Def QName
q [Elim
_,Elim
_,Elim
_, Apply Arg Term
t] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mSubIn -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
t)
Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction (MaybeReducedArgs -> Reduced MaybeReducedArgs Term)
-> MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall a b. (a -> b) -> a -> b
$ (Arg Term -> MaybeReduced (Arg Term))
-> [Arg Term] -> MaybeReducedArgs
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced [Arg Term
a,Arg Term
bA] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi, Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
u, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sx]
[Arg Term]
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
primTrans' :: TCM PrimitiveImpl
primTrans' :: TCM PrimitiveImpl
primTrans' = do
Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
Type
t <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel)) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
a ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"A" (String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i))) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
bA ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
phi ->
(NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) (NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne) (NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne))
PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> [Occurrence]
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
4 [] (([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun)
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \[Arg Term]
ts Nat
nelims -> do
Command
-> [Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp Command
DoTransp [Arg Term]
ts Nat
nelims
primHComp' :: TCM PrimitiveImpl
primHComp' :: TCM PrimitiveImpl
primHComp' = do
Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
Type
t <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel)) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
a ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"A" (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) Term
a) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
bA ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
phi ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT (TCMT IO) Term
i -> String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" NamesT (TCMT IO) Term
phi ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
bA) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
(NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
bA)
let occs :: [Occurrence]
occs = [Occurrence
Mixed, Occurrence
StrictPos, Occurrence
Mixed, Occurrence
StrictPos, Occurrence
StrictPos]
PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> [Occurrence]
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
5 [Occurrence]
occs (([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun)
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \[Arg Term]
ts Nat
nelims -> do
Command
-> [Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp Command
DoHComp [Arg Term]
ts Nat
nelims
mkComp :: forall m. HasBuiltins m
=> String
-> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)
mkComp :: forall (m :: * -> *).
HasBuiltins m =>
String
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
mkComp String
s = do
let getTermLocal :: IsBuiltin a => a -> NamesT m Term
getTermLocal :: forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal = String -> a -> NamesT m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
s
Term
tIMax <- PrimitiveId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal PrimitiveId
builtinIMax
Term
tINeg <- PrimitiveId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal PrimitiveId
builtinINeg
Term
tHComp <- PrimitiveId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal PrimitiveId
builtinHComp
Term
tTrans <- PrimitiveId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal PrimitiveId
builtinTrans
Term
iz <- BuiltinId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal BuiltinId
builtinIZero
Term
io <- BuiltinId -> NamesT m Term
forall a. IsBuiltin a => a -> NamesT m Term
getTermLocal BuiltinId
builtinIOne
let
forward :: NamesT m Term
-> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
forward NamesT m Term
la NamesT m Term
bA NamesT m Term
r NamesT m Term
u = Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans
NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
i -> NamesT m Term
la NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` NamesT m Term
r))
NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
i -> NamesT m Term
bA NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` NamesT m Term
r))
NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
r
NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term))
-> (NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u NamesT m Term
u0 ->
Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
la NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT m Term
bA NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
phi
NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (\NamesT m Term
i -> String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
o ->
NamesT m Term
-> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
forward NamesT m Term
la NamesT m Term
bA NamesT m Term
i (NamesT m Term
u NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT m Term
o))
NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
-> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term
forward NamesT m Term
la NamesT m Term
bA (Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT m Term
u0
mkCompLazy
:: HasBuiltins m
=> String
-> NamesT m (NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term -> NamesT m Term)
mkCompLazy :: forall (m :: * -> *).
HasBuiltins m =>
String
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
mkCompLazy String
s = do
let getTermLocal :: PrimitiveId -> NamesT m Term
getTermLocal = String -> PrimitiveId -> NamesT m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
s
Term
tComp <- PrimitiveId -> NamesT m Term
getTermLocal PrimitiveId
builtinComp
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term))
-> (NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
forall a b. (a -> b) -> a -> b
$ \NamesT m Term
la NamesT m Term
bA NamesT m Term
phi NamesT m Term
u NamesT m Term
u0 -> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tComp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
la NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
bA NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
doPiKanOp
:: KanOperation
-> ArgName
-> FamilyOrNot (Dom Type, Abs Type)
-> ReduceM (Maybe Term)
doPiKanOp :: KanOperation
-> String
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> ReduceM (Maybe Term)
doPiKanOp KanOperation
cmd String
t FamilyOrNot (Dom' Term Type, Abs Type)
ab = do
let getTermLocal :: IsBuiltin a => a -> ReduceM Term
getTermLocal :: forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal = String -> a -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (String -> a -> ReduceM Term) -> String -> a -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ KanOperation -> String
kanOpName KanOperation
cmd String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for function types"
Term
tTrans <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinTrans
Term
tHComp <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinHComp
Term
tINeg <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinINeg
Term
tIMax <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinIMax
Term
iz <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIZero
let
toLevel' :: a -> m (Maybe (Level' Term))
toLevel' a
t = do
Sort
s <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ a -> Sort
forall a. LensSort a => a -> Sort
getSort a
t
case Sort
s of
Type Level' Term
l -> Maybe (Level' Term) -> m (Maybe (Level' Term))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level' Term -> Maybe (Level' Term)
forall a. a -> Maybe a
Just Level' Term
l)
Sort
_ -> Maybe (Level' Term) -> m (Maybe (Level' Term))
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Level' Term)
forall a. Maybe a
Nothing
toLevel :: a -> f (Level' Term)
toLevel a
t = Level' Term -> Maybe (Level' Term) -> Level' Term
forall a. a -> Maybe a -> a
fromMaybe Level' Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe (Level' Term) -> Level' Term)
-> f (Maybe (Level' Term)) -> f (Level' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> f (Maybe (Level' Term))
forall {m :: * -> *} {a}.
(MonadReduce m, LensSort a) =>
a -> m (Maybe (Level' Term))
toLevel' a
t
ReduceM (Maybe (Level' Term))
-> ReduceM (Maybe Term)
-> (Level' Term -> ReduceM (Maybe Term))
-> ReduceM (Maybe Term)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Type -> ReduceM (Maybe (Level' Term))
forall {m :: * -> *} {a}.
(MonadReduce m, LensSort a) =>
a -> m (Maybe (Level' Term))
toLevel' (Type -> ReduceM (Maybe (Level' Term)))
-> (FamilyOrNot (Dom' Term Type, Abs Type) -> Type)
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> ReduceM (Maybe (Level' Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody (Abs Type -> Type)
-> (FamilyOrNot (Dom' Term Type, Abs Type) -> Abs Type)
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dom' Term Type, Abs Type) -> Abs Type
forall a b. (a, b) -> b
snd ((Dom' Term Type, Abs Type) -> Abs Type)
-> (FamilyOrNot (Dom' Term Type, Abs Type)
-> (Dom' Term Type, Abs Type))
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> Abs Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. FamilyOrNot (Dom' Term Type, Abs Type)
-> (Dom' Term Type, Abs Type)
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Dom' Term Type, Abs Type)
-> ReduceM (Maybe (Level' Term)))
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> ReduceM (Maybe (Level' Term))
forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom' Term Type, Abs Type)
ab) (Maybe Term -> ReduceM (Maybe Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) ((Level' Term -> ReduceM (Maybe Term)) -> ReduceM (Maybe Term))
-> (Level' Term -> ReduceM (Maybe Term)) -> ReduceM (Maybe Term)
forall a b. (a -> b) -> a -> b
$ \ Level' Term
_ -> do
Names -> NamesT ReduceM (Maybe Term) -> ReduceM (Maybe Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM (Maybe Term) -> ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term) -> ReduceM (Maybe Term)
forall a b. (a -> b) -> a -> b
$ do
Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
trFibrantDomain <- do
let
(Dom' Term Type
x, Term -> Term
f) = case FamilyOrNot (Dom' Term Type, Abs Type)
ab of
IsFam (Dom' Term Type
a, Abs Type
_) -> (Dom' Term Type
a, \ Term
a -> Names -> NamesT Fail Term -> Term
forall a. Names -> NamesT Fail a -> a
runNames [] (NamesT Fail Term -> Term) -> NamesT Fail Term -> Term
forall a b. (a -> b) -> a -> b
$ String
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall a. a -> NamesT Fail a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
a)))
IsNot (Dom' Term Type
a, Abs Type
_) -> (Dom' Term Type
a, Term -> Term
forall a. a -> a
id)
Sort
s <- Sort -> NamesT ReduceM Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> NamesT ReduceM Sort) -> Sort -> NamesT ReduceM Sort
forall a b. (a -> b) -> a -> b
$ Dom' Term Type -> Sort
forall a. LensSort a => a -> Sort
getSort Dom' Term Type
x
case Sort
s of
Type Level' Term
lx -> do
[NamesT ReduceM Term
la, NamesT ReduceM Term
bA] <- (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Term -> Term) -> Term -> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
f) [Level' Term -> Term
Level Level' Term
lx, Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term)
-> (Dom' Term Type -> Type) -> Dom' Term Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom (Dom' Term Type -> Term) -> Dom' Term Type -> Term
forall a b. (a -> b) -> a -> b
$ Dom' Term Type
x]
Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)))
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
forall a b. (a -> b) -> a -> b
$ ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall a. a -> Maybe a
Just (((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
-> ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
phi NamesT ReduceM Term
a0 ->
Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" (\NamesT ReduceM Term
j -> NamesT ReduceM Term
la NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
j)
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" (\ NamesT ReduceM Term
j -> NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term -> NamesT ReduceM Term
iOrNot NamesT ReduceM Term
j)
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
a0
Sort
LockUniv -> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)))
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
forall a b. (a -> b) -> a -> b
$ ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall a. a -> Maybe a
Just (((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
-> ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term -> NamesT ReduceM Term
_ NamesT ReduceM Term
_ NamesT ReduceM Term
a0 -> NamesT ReduceM Term
a0
Sort
IntervalUniv -> do
Blocked Type
x' <- Type -> NamesT ReduceM (Blocked Type)
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB (Type -> NamesT ReduceM (Blocked Type))
-> Type -> NamesT ReduceM (Blocked Type)
forall a b. (a -> b) -> a -> b
$ Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom Dom' Term Type
x
Maybe QName
mInterval <- BuiltinId -> NamesT ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe QName)
getBuiltinName' BuiltinId
builtinInterval
case Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> Type -> Term
forall a b. (a -> b) -> a -> b
$ Blocked Type -> Type
forall t a. Blocked' t a -> a
ignoreBlocking Blocked Type
x' of
Def QName
q [] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mInterval -> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)))
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
forall a b. (a -> b) -> a -> b
$ ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall a. a -> Maybe a
Just (((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
-> ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term -> NamesT ReduceM Term
_ NamesT ReduceM Term
_ NamesT ReduceM Term
a0 -> NamesT ReduceM Term
a0
Term
_ -> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall a. Maybe a
Nothing
Sort
_ -> Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT
ReduceM
(Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall a. Maybe a
Nothing
Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT ReduceM (Maybe Term)
-> (((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term)
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe
((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
trFibrantDomain (Maybe Term -> NamesT ReduceM (Maybe Term)
forall a. a -> NamesT ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Term
forall a. Maybe a
Nothing) ((((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term))
-> (((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
-> NamesT ReduceM (Maybe Term))
-> NamesT ReduceM (Maybe Term)
forall a b. (a -> b) -> a -> b
$ \(NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
trA -> Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term)
-> NamesT ReduceM Term -> NamesT ReduceM (Maybe Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
[NamesT ReduceM Term
phi, NamesT ReduceM Term
u0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (KanOperation -> Blocked (Arg Term)
kanOpCofib KanOperation
cmd), KanOperation -> Arg Term
kanOpBase KanOperation
cmd]
ArgInfo
-> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
ArgInfo
-> String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
glam (Dom' Term Type -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo ((Dom' Term Type, Abs Type) -> Dom' Term Type
forall a b. (a, b) -> a
fst ((Dom' Term Type, Abs Type) -> Dom' Term Type)
-> (Dom' Term Type, Abs Type) -> Dom' Term Type
forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom' Term Type, Abs Type)
-> (Dom' Term Type, Abs Type)
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Dom' Term Type, Abs Type)
ab)) (Abs Type -> String
forall a. Abs a -> String
absName (Abs Type -> String) -> Abs Type -> String
forall a b. (a -> b) -> a -> b
$ (Dom' Term Type, Abs Type) -> Abs Type
forall a b. (a, b) -> b
snd ((Dom' Term Type, Abs Type) -> Abs Type)
-> (Dom' Term Type, Abs Type) -> Abs Type
forall a b. (a -> b) -> a -> b
$ FamilyOrNot (Dom' Term Type, Abs Type)
-> (Dom' Term Type, Abs Type)
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Dom' Term Type, Abs Type)
ab) ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term
u1 -> do
case (KanOperation
cmd, FamilyOrNot (Dom' Term Type, Abs Type)
ab) of
(HCompOp Blocked (Arg Term)
_ Arg Term
u Arg Term
_, IsNot (Dom' Term Type
a , Abs Type
b)) -> do
Type
bT <- (Nat -> Abs Type -> Abs Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Type
b Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`absApp`) (Term -> Type) -> NamesT ReduceM Term -> NamesT ReduceM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT ReduceM Term
u1
NamesT ReduceM Term
u <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise Nat
1 (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u))
Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Level' Term -> Term
Level (Level' Term -> Term)
-> NamesT ReduceM (Level' Term) -> NamesT ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> NamesT ReduceM (Level' Term)
forall {f :: * -> *} {a}.
(MonadReduce f, LensSort a) =>
a -> f (Level' Term)
toLevel Type
bT)
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Type -> Term
forall t a. Type'' t a -> a
unEl Type
bT)
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
phi
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (\ NamesT ReduceM Term
i -> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
o -> Hiding
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (Dom' Term Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom' Term Type
a) (NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o) NamesT ReduceM Term
u1)
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Hiding
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (Dom' Term Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom' Term Type
a) NamesT ReduceM Term
u0 NamesT ReduceM Term
u1
(TranspOp Blocked (Arg Term)
_ Arg Term
_, IsFam (Dom' Term Type
a , Abs Type
b)) -> do
let
v :: NamesT ReduceM Term -> NamesT ReduceM Term
v NamesT ReduceM Term
i = (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
trA (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT ReduceM Term
i (NamesT ReduceM Term -> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg) (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax NamesT ReduceM Term
phi NamesT ReduceM Term
i) NamesT ReduceM Term
u1
bB :: Term -> Type
bB Term
v = Term -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
v (Nat -> Substitution' Term -> Substitution' Term
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
1 (Substitution' Term -> Substitution' Term)
-> Substitution' Term -> Substitution' Term
forall a b. (a -> b) -> a -> b
$ Nat -> Substitution' Term
forall a. Nat -> Substitution' a
raiseS Nat
1) Substitution' (SubstArg Type) -> Type -> Type
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst`
(Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody Abs Type
b )
tLam :: Abs Term -> Term
tLam = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo
Abs Type
bT <- String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b)
-> NamesT ReduceM Type)
-> NamesT ReduceM (Abs Type)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b)
-> NamesT ReduceM Type)
-> NamesT ReduceM (Abs Type))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b)
-> NamesT ReduceM Type)
-> NamesT ReduceM (Abs Type)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b
x -> (Term -> Type) -> NamesT ReduceM Term -> NamesT ReduceM Type
forall a b. (a -> b) -> NamesT ReduceM a -> NamesT ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Type
bB (NamesT ReduceM Term -> NamesT ReduceM Type)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamesT ReduceM Term -> NamesT ReduceM Term
v (NamesT ReduceM Term -> NamesT ReduceM Type)
-> NamesT ReduceM Term -> NamesT ReduceM Type
forall a b. (a -> b) -> a -> b
$ NamesT ReduceM Term
forall {b}. (Subst b, DeBruijn b) => NamesT ReduceM b
x
Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (Abs Term -> Term
tLam (Abs Term -> Term)
-> NamesT ReduceM (Abs Term) -> NamesT ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Type -> NamesT ReduceM Term)
-> Abs Type -> NamesT ReduceM (Abs Term)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Abs a -> f (Abs b)
traverse ((Level' Term -> Term)
-> NamesT ReduceM (Level' Term) -> NamesT ReduceM Term
forall a b. (a -> b) -> NamesT ReduceM a -> NamesT ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Level' Term -> Term
Level (NamesT ReduceM (Level' Term) -> NamesT ReduceM Term)
-> (Type -> NamesT ReduceM (Level' Term))
-> Type
-> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> NamesT ReduceM (Level' Term)
forall {f :: * -> *} {a}.
(MonadReduce f, LensSort a) =>
a -> f (Level' Term)
toLevel) Abs Type
bT)
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT ReduceM Term)
-> (Abs Term -> Term) -> Abs Term -> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Term -> Term
tLam (Abs Term -> NamesT ReduceM Term)
-> Abs Term -> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> Abs Type -> Abs Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs Type
bT)
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Hiding
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
Hiding -> m Term -> m Term -> m Term
gApply (Dom' Term Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom' Term Type
a) NamesT ReduceM Term
u0 (NamesT ReduceM Term -> NamesT ReduceM Term
v (Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz))
(KanOperation
_, FamilyOrNot (Dom' Term Type, Abs Type)
_) -> String -> NamesT ReduceM Term
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
String -> m a
__IMPOSSIBLE_VERBOSE__ String
"Invalid Kan operation in doPiKanOp"
doPathPKanOp
:: KanOperation
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Reduced MaybeReducedArgs Term)
doPathPKanOp :: KanOperation
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Reduced MaybeReducedArgs Term)
doPathPKanOp (HCompOp Blocked (Arg Term)
phi Arg Term
u Arg Term
u0) (IsNot Arg Term
l) (IsNot (Arg Term
bA,Arg Term
x,Arg Term
y)) = do
let getTermLocal :: PrimitiveId -> ReduceM Term
getTermLocal = String -> PrimitiveId -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
"primHComp for path types"
Term
tHComp <- PrimitiveId -> ReduceM Term
getTermLocal PrimitiveId
builtinHComp
Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
[NamesT ReduceM Term
l, NamesT ReduceM Term
u, NamesT ReduceM Term
u0, NamesT ReduceM Term
phi, NamesT ReduceM Term
bA, NamesT ReduceM Term
x, NamesT ReduceM Term
y] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l, Arg Term
u, Arg Term
u0, Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
phi, Arg Term
bA, Arg Term
x, Arg Term
y]
String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
j ->
Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` (NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg NamesT ReduceM Term
j NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` NamesT ReduceM Term
j))
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i'" (\NamesT ReduceM Term
i -> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
forall (m :: * -> *).
HasBuiltins m =>
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
combineSys NamesT ReduceM Term
l (NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i)
[ (NamesT ReduceM Term
phi, String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT ReduceM Term
o -> NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o NamesT ReduceM Term
-> (NamesT ReduceM Term, NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT ReduceM Term
x, NamesT ReduceM Term
y, NamesT ReduceM Term
j)))
, (NamesT ReduceM Term
j, String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall a b. a -> b -> a
const NamesT ReduceM Term
y))
, (NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg NamesT ReduceM Term
j, String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall a b. a -> b -> a
const NamesT ReduceM Term
x)) ])
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
u0 NamesT ReduceM Term
-> (NamesT ReduceM Term, NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT ReduceM Term
x, NamesT ReduceM Term
y, NamesT ReduceM Term
j))
doPathPKanOp (TranspOp Blocked (Arg Term)
phi Arg Term
u0) (IsFam Arg Term
l) (IsFam (Arg Term
bA,Arg Term
x,Arg Term
y)) = do
let getTermLocal :: BuiltinId -> ReduceM Term
getTermLocal = String -> BuiltinId -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
"transport for path types"
Term
iz <- BuiltinId -> ReduceM Term
getTermLocal BuiltinId
builtinIZero
Term
io <- BuiltinId -> ReduceM Term
getTermLocal BuiltinId
builtinIOne
Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp <- String
-> NamesT
ReduceM
(NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall (m :: * -> *).
HasBuiltins m =>
String
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
mkComp (String
-> NamesT
ReduceM
(NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term))
-> String
-> NamesT
ReduceM
(NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ String
"transport for path types"
[NamesT ReduceM Term
l, NamesT ReduceM Term
u0, NamesT ReduceM Term
phi] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l, Arg Term
u0, Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
phi]
[NamesT ReduceM Term
bA, NamesT ReduceM Term
x, NamesT ReduceM Term
y] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (\ Arg Term
a -> Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (NamesT Fail Term -> Term)
-> NamesT Fail Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> NamesT Fail Term -> Term
forall a. Names -> NamesT Fail a -> a
runNames [] (NamesT Fail Term -> NamesT ReduceM (NamesT ReduceM Term))
-> NamesT Fail Term -> NamesT ReduceM (NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ String
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" (NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall a b. a -> b -> a
const (Term -> NamesT Fail Term
forall a. a -> NamesT Fail a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT Fail Term) -> Term -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a))) [Arg Term
bA, Arg Term
x, Arg Term
y]
String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
j ->
NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp NamesT ReduceM Term
l (String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j) (NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` (NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg NamesT ReduceM Term
j NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
`imax` NamesT ReduceM Term
j))
(String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i'" ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \NamesT ReduceM Term
i -> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
forall (m :: * -> *).
HasBuiltins m =>
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
combineSys (NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) (NamesT ReduceM Term
bA NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j)
[ (NamesT ReduceM Term
phi, String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\NamesT ReduceM Term
o -> NamesT ReduceM Term
u0 NamesT ReduceM Term
-> (NamesT ReduceM Term, NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT ReduceM Term
x NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT ReduceM Term
y NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT ReduceM Term
j)))
, (NamesT ReduceM Term
j, String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"_" (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall a b. a -> b -> a
const (NamesT ReduceM Term
y NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i)))
, (NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term
ineg NamesT ReduceM Term
j, String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"_" (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall a b. a -> b -> a
const (NamesT ReduceM Term
x NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i)))
])
(NamesT ReduceM Term
u0 NamesT ReduceM Term
-> (NamesT ReduceM Term, NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT ReduceM Term
x NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT ReduceM Term
y NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz, NamesT ReduceM Term
j))
doPathPKanOp KanOperation
a0 FamilyOrNot (Arg Term)
_ FamilyOrNot (Arg Term, Arg Term, Arg Term)
_ = ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
redReturnNoSimpl :: a -> ReduceM (Reduced a' a)
redReturnNoSimpl :: forall a a'. a -> ReduceM (Reduced a' a)
redReturnNoSimpl = Reduced a' a -> ReduceM (Reduced a' a)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reduced a' a -> ReduceM (Reduced a' a))
-> (a -> Reduced a' a) -> a -> ReduceM (Reduced a' a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Simplification -> a -> Reduced a' a
forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
NoSimplification
primTransHComp :: Command -> [Arg Term] -> Int -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp :: Command
-> [Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term)
primTransHComp Command
cmd [Arg Term]
ts Nat
nelims = do
(FamilyOrNot (Arg Term)
l,FamilyOrNot (Arg Term)
bA,Arg Term
phi,Maybe (Arg Term)
u,Arg Term
u0) <- (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
Maybe (Arg Term), Arg Term)
-> ReduceM
(FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
Maybe (Arg Term), Arg Term)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ((FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
Maybe (Arg Term), Arg Term)
-> ReduceM
(FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
Maybe (Arg Term), Arg Term))
-> (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
Maybe (Arg Term), Arg Term)
-> ReduceM
(FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
Maybe (Arg Term), Arg Term)
forall a b. (a -> b) -> a -> b
$ case (Command
cmd,[Arg Term]
ts) of
(Command
DoTransp, [Arg Term
l, Arg Term
bA, Arg Term
phi, Arg Term
u0]) -> (Arg Term -> FamilyOrNot (Arg Term)
forall a. a -> FamilyOrNot a
IsFam Arg Term
l, Arg Term -> FamilyOrNot (Arg Term)
forall a. a -> FamilyOrNot a
IsFam Arg Term
bA, Arg Term
phi, Maybe (Arg Term)
forall a. Maybe a
Nothing, Arg Term
u0)
(Command
DoHComp, [Arg Term
l, Arg Term
bA, Arg Term
phi, Arg Term
u, Arg Term
u0]) -> (Arg Term -> FamilyOrNot (Arg Term)
forall a. a -> FamilyOrNot a
IsNot Arg Term
l, Arg Term -> FamilyOrNot (Arg Term)
forall a. a -> FamilyOrNot a
IsNot Arg Term
bA, Arg Term
phi, Arg Term -> Maybe (Arg Term)
forall a. a -> Maybe a
Just Arg Term
u, Arg Term
u0)
(Command, [Arg Term])
_ -> (FamilyOrNot (Arg Term), FamilyOrNot (Arg Term), Arg Term,
Maybe (Arg Term), Arg Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
IntervalView
vphi <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi
let clP :: a -> m Term
clP a
s = String -> a -> m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
"primTransHComp" a
s
case IntervalView
vphi of
IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< case Command
cmd of
Command
DoHComp -> Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ do
NamesT ReduceM Term
u <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> Term -> NamesT ReduceM (NamesT ReduceM Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Maybe (Arg Term) -> Arg Term
forall a. a -> Maybe a -> a
fromMaybe Arg Term
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Term)
u
NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> BuiltinId -> NamesT ReduceM Term
forall {m :: * -> *} {a}.
(HasBuiltins m, IsBuiltin a) =>
a -> m Term
clP BuiltinId
builtinIOne NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> BuiltinId -> NamesT ReduceM Term
forall {m :: * -> *} {a}.
(HasBuiltins m, IsBuiltin a) =>
a -> m Term
clP BuiltinId
builtinItIsOne
Command
DoTransp ->
Term -> ReduceM Term
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> ReduceM Term) -> Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0
IntervalView
_ -> do
let
fallback' :: Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback' Blocked (Arg Term)
sc = do
MaybeReducedArgs
u' <- case Command
cmd of
Command
DoHComp -> (MaybeReduced (Arg Term) -> MaybeReducedArgs -> MaybeReducedArgs
forall a. a -> [a] -> [a]
:[]) (MaybeReduced (Arg Term) -> MaybeReducedArgs)
-> ReduceM (MaybeReduced (Arg Term)) -> ReduceM MaybeReducedArgs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> case IntervalView
vphi of
IntervalView
IZero -> (Term -> MaybeReduced (Arg Term))
-> ReduceM Term -> ReduceM (MaybeReduced (Arg Term))
forall a b. (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced (Blocked (Arg Term) -> MaybeReduced (Arg Term))
-> (Term -> Blocked (Arg Term)) -> Term -> MaybeReduced (Arg Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Blocked (Arg Term)
forall a t. a -> Blocked' t a
notBlocked (Arg Term -> Blocked (Arg Term))
-> (Term -> Arg Term) -> Term -> Blocked (Arg Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argN) (ReduceM Term -> ReduceM (MaybeReduced (Arg Term)))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (MaybeReduced (Arg Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (MaybeReduced (Arg Term)))
-> NamesT ReduceM Term -> ReduceM (MaybeReduced (Arg Term))
forall a b. (a -> b) -> a -> b
$ do
[NamesT ReduceM Term
l,NamesT ReduceM Term
c] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Arg Term)
l, Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc]
String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> BuiltinId -> NamesT ReduceM Term
forall {m :: * -> *} {a}.
(HasBuiltins m, IsBuiltin a) =>
a -> m Term
clP BuiltinId
builtinIsOneEmpty NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT ReduceM Term
_ -> NamesT ReduceM Term
c)
IntervalView
_ -> MaybeReduced (Arg Term) -> ReduceM (MaybeReduced (Arg Term))
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (MaybeReduced (Arg Term) -> ReduceM (MaybeReduced (Arg Term)))
-> MaybeReduced (Arg Term) -> ReduceM (MaybeReduced (Arg Term))
forall a b. (a -> b) -> a -> b
$ Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced (Arg Term -> MaybeReduced (Arg Term))
-> Arg Term -> MaybeReduced (Arg Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Maybe (Arg Term) -> Arg Term
forall a. a -> Maybe a -> a
fromMaybe Arg Term
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Term)
u
Command
DoTransp -> MaybeReducedArgs -> ReduceM MaybeReducedArgs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term))
-> (MaybeReducedArgs -> Reduced MaybeReducedArgs Term)
-> MaybeReducedArgs
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction (MaybeReducedArgs -> ReduceM (Reduced MaybeReducedArgs Term))
-> MaybeReducedArgs -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced (FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing FamilyOrNot (Arg Term)
l), Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sc, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi] MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ MaybeReducedArgs
u' MaybeReducedArgs -> MaybeReducedArgs -> MaybeReducedArgs
forall a. [a] -> [a] -> [a]
++ [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
u0]
Blocked (FamilyOrNot (Arg Term))
sbA <- FamilyOrNot (Arg Term)
-> ReduceM (Blocked (FamilyOrNot (Arg Term)))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' FamilyOrNot (Arg Term)
bA
Maybe (Blocked' Term (FamilyOrNot Term))
t <- case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> FamilyOrNot (Arg Term) -> FamilyOrNot Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term)) -> FamilyOrNot (Arg Term)
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (FamilyOrNot (Arg Term))
sbA of
IsFam (Lam ArgInfo
_ Abs Term
t) -> Blocked' Term (FamilyOrNot Term)
-> Maybe (Blocked' Term (FamilyOrNot Term))
forall a. a -> Maybe a
Just (Blocked' Term (FamilyOrNot Term)
-> Maybe (Blocked' Term (FamilyOrNot Term)))
-> (Blocked' Term Term -> Blocked' Term (FamilyOrNot Term))
-> Blocked' Term Term
-> Maybe (Blocked' Term (FamilyOrNot Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> FamilyOrNot Term)
-> Blocked' Term Term -> Blocked' Term (FamilyOrNot Term)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> FamilyOrNot Term
forall a. a -> FamilyOrNot a
IsFam (Blocked' Term Term -> Maybe (Blocked' Term (FamilyOrNot Term)))
-> ReduceM (Blocked' Term Term)
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM (Blocked' Term Term)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
t)
IsFam Term
_ -> Maybe (Blocked' Term (FamilyOrNot Term))
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe (Blocked' Term (FamilyOrNot Term))
forall a. Maybe a
Nothing
IsNot Term
t -> Maybe (Blocked' Term (FamilyOrNot Term))
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Maybe (Blocked' Term (FamilyOrNot Term))
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term))))
-> (Blocked' Term Term -> Maybe (Blocked' Term (FamilyOrNot Term)))
-> Blocked' Term Term
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' Term (FamilyOrNot Term)
-> Maybe (Blocked' Term (FamilyOrNot Term))
forall a. a -> Maybe a
Just (Blocked' Term (FamilyOrNot Term)
-> Maybe (Blocked' Term (FamilyOrNot Term)))
-> (Blocked' Term Term -> Blocked' Term (FamilyOrNot Term))
-> Blocked' Term Term
-> Maybe (Blocked' Term (FamilyOrNot Term))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term -> FamilyOrNot Term)
-> Blocked' Term Term -> Blocked' Term (FamilyOrNot Term)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> FamilyOrNot Term
forall a. a -> FamilyOrNot a
IsNot (Blocked' Term Term
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term))))
-> Blocked' Term Term
-> ReduceM (Maybe (Blocked' Term (FamilyOrNot Term)))
forall a b. (a -> b) -> a -> b
$ (Term
t Term -> Blocked (FamilyOrNot (Arg Term)) -> Blocked' Term Term
forall a b. a -> Blocked' Term b -> Blocked' Term a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Blocked (FamilyOrNot (Arg Term))
sbA)
case Maybe (Blocked' Term (FamilyOrNot Term))
t of
Maybe (Blocked' Term (FamilyOrNot Term))
Nothing -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback' (FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
sbA)
Just Blocked' Term (FamilyOrNot Term)
st -> do
let
fallback :: ReduceM (Reduced MaybeReducedArgs Term)
fallback = Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback' ((FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term))
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall a b. (a -> b) -> a -> b
$ Blocked' Term (FamilyOrNot Term)
st Blocked' Term (FamilyOrNot Term)
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (FamilyOrNot (Arg Term))
forall a b. Blocked' Term a -> Blocked' Term b -> Blocked' Term b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Blocked (FamilyOrNot (Arg Term))
sbA)
t :: FamilyOrNot Term
t = Blocked' Term (FamilyOrNot Term) -> FamilyOrNot Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term (FamilyOrNot Term)
st
operation :: KanOperation
operation = case Command
cmd of
Command
DoTransp -> TranspOp { kanOpCofib :: Blocked (Arg Term)
kanOpCofib = Blocked (Arg Term)
sphi, kanOpBase :: Arg Term
kanOpBase = Arg Term
u0 }
Command
DoHComp -> HCompOp
{ kanOpCofib :: Blocked (Arg Term)
kanOpCofib = Blocked (Arg Term)
sphi, kanOpSides :: Arg Term
kanOpSides = Arg Term -> Maybe (Arg Term) -> Arg Term
forall a. a -> Maybe a -> a
fromMaybe Arg Term
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Term)
u, kanOpBase :: Arg Term
kanOpBase = Arg Term
u0 }
Maybe QName
mHComp <- PrimitiveId -> ReduceM (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
PrimitiveId -> m (Maybe QName)
getPrimitiveName' PrimitiveId
builtinHComp
Maybe QName
mGlue <- PrimitiveId -> ReduceM (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
PrimitiveId -> m (Maybe QName)
getPrimitiveName' PrimitiveId
builtinGlue
Maybe QName
mId <- BuiltinId -> ReduceM (Maybe QName)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe QName)
getBuiltinName' BuiltinId
builtinId
Type -> PathView
pathV <- ReduceM (Type -> PathView)
forall (m :: * -> *). HasBuiltins m => m (Type -> PathView)
pathView'
case FamilyOrNot Term -> Term
forall a. FamilyOrNot a -> a
famThing FamilyOrNot Term
t of
MetaV MetaId
m [Elim]
_ -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
fallback' ((FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term))
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall a b. (a -> b) -> a -> b
$ MetaId -> Blocked' Term ()
forall t. MetaId -> Blocked' t ()
blocked_ MetaId
m Blocked' Term ()
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (FamilyOrNot (Arg Term))
forall a b. Blocked' Term a -> Blocked' Term b -> Blocked' Term b
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f b
*> Blocked (FamilyOrNot (Arg Term))
sbA)
Pi Dom' Term Type
a Abs Type
b
| Nat
nelims Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
0 -> ReduceM (Reduced MaybeReducedArgs Term)
-> (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Maybe Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe Term) -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KanOperation
-> String
-> FamilyOrNot (Dom' Term Type, Abs Type)
-> ReduceM (Maybe Term)
doPiKanOp KanOperation
operation String
"i" ((Dom' Term Type
a, Abs Type
b) (Dom' Term Type, Abs Type)
-> FamilyOrNot Term -> FamilyOrNot (Dom' Term Type, Abs Type)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t)
| Bool
otherwise -> ReduceM (Reduced MaybeReducedArgs Term)
fallback
Sort (Type Level' Term
l)
| Command
DoTransp <- Command
cmd -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0
| Command
DoHComp <- Command
cmd -> ReduceM (Reduced MaybeReducedArgs Term)
fallback
Def QName
q [Apply Arg Term
la, Apply Arg Term
lb, Apply Arg Term
bA, Apply Arg Term
phi', Apply Arg Term
bT, Apply Arg Term
e] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mGlue -> do
ReduceM (Reduced MaybeReducedArgs Term)
-> (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Maybe Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe Term) -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KanOperation
-> FamilyOrNot
(Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
KanOperation
-> FamilyOrNot
(Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
doGlueKanOp
KanOperation
operation ((Arg Term
la, Arg Term
lb, Arg Term
bA, Arg Term
phi', Arg Term
bT, Arg Term
e) (Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
-> FamilyOrNot Term
-> FamilyOrNot
(Arg Term, Arg Term, Arg Term, Arg Term, Arg Term, Arg Term)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) TermPosition
Head
Def QName
q [Apply Arg Term
_, Apply Arg Term
s, Apply Arg Term
phi', Apply Arg Term
bT, Apply Arg Term
bA]
| QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mHComp, Sort (Type Level' Term
la) <- Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
s -> do
ReduceM (Reduced MaybeReducedArgs Term)
-> (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Maybe Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe Term) -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KanOperation
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> ReduceM (Maybe Term)
forall (m :: * -> *).
PureTCM m =>
KanOperation
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
-> TermPosition
-> m (Maybe Term)
doHCompUKanOp
KanOperation
operation ((Level' Term -> Term
Level Level' Term
la Term -> Arg Term -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Term
s, Arg Term
phi', Arg Term
bT, Arg Term
bA) (Arg Term, Arg Term, Arg Term, Arg Term)
-> FamilyOrNot Term
-> FamilyOrNot (Arg Term, Arg Term, Arg Term, Arg Term)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) TermPosition
Head
Term
d | PathType Sort
_ QName
_ Arg Term
_ Arg Term
bA Arg Term
x Arg Term
y <- Type -> PathView
pathV (Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El Sort
HasCallStack => Sort
__DUMMY_SORT__ Term
d) -> do
if Nat
nelims Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
0 then KanOperation
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Reduced MaybeReducedArgs Term)
doPathPKanOp KanOperation
operation FamilyOrNot (Arg Term)
l ((Arg Term
bA, Arg Term
x, Arg Term
y) (Arg Term, Arg Term, Arg Term)
-> FamilyOrNot Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) else ReduceM (Reduced MaybeReducedArgs Term)
fallback
Def QName
q [Apply Arg Term
_ , Apply Arg Term
bA , Apply Arg Term
x , Apply Arg Term
y] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mId -> do
ReduceM (Reduced MaybeReducedArgs Term)
-> (Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe (Reduced MaybeReducedArgs Term)
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ReduceM (Reduced MaybeReducedArgs Term)
fallback Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Reduced MaybeReducedArgs Term)
-> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< KanOperation
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Maybe (Reduced MaybeReducedArgs Term))
forall t.
KanOperation
-> FamilyOrNot (Arg Term)
-> FamilyOrNot (Arg Term, Arg Term, Arg Term)
-> ReduceM (Maybe (Reduced t Term))
doIdKanOp KanOperation
operation FamilyOrNot (Arg Term)
l ((Arg Term
bA, Arg Term
x, Arg Term
y) (Arg Term, Arg Term, Arg Term)
-> FamilyOrNot Term -> FamilyOrNot (Arg Term, Arg Term, Arg Term)
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t)
Def QName
q [Elim]
es -> do
Definition
info <- QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
q
let
lam_i :: Term -> Term
lam_i = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Term -> Abs Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i"
doR :: Defn -> Bool
doR r :: Defn
r@Record{recEtaEquality' :: Defn -> EtaEquality
recEtaEquality' = EtaEquality
eta} = case EtaEquality -> HasEta
theEtaEquality EtaEquality
eta of
NoEta PatternOrCopattern
PatternMatching -> case Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0 of
Con{} -> Bool
True
Term
_ -> Bool
False
HasEta
_ -> Nat
nelims Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
0
doR Defn
_ = Bool
False
case Definition -> Defn
theDef Definition
info of
r :: Defn
r@Record{recComp :: Defn -> CompKit
recComp = CompKit
kit, recEtaEquality' :: Defn -> EtaEquality
recEtaEquality' = EtaEquality
eta}
| Defn -> Bool
doR Defn
r, Just [Arg Term]
as <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, Command
DoTransp <- Command
cmd, Just QName
transpR <- CompKit -> Maybe QName
nameOfTransp CompKit
kit ->
if Defn -> Nat
recPars Defn
r Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0
then Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0
else Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
transpR [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` ((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> Arg Term -> Arg Term
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) [Arg Term]
as [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi, Arg Term
u0])
| Defn -> Bool
doR Defn
r, Just [Arg Term]
as <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, Command
DoHComp <- Command
cmd, Just QName
hCompR <- CompKit -> Maybe QName
nameOfHComp CompKit
kit ->
Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
hCompR [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` ([Arg Term]
as [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ [Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi, Arg Term -> Maybe (Arg Term) -> Arg Term
forall a. a -> Maybe a -> a
fromMaybe Arg Term
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Term)
u,Arg Term
u0])
| Just [Arg Term]
as <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es, [] <- Defn -> [Dom QName]
recFields Defn
r -> Maybe QName
-> Bool
-> Nat
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall {a}.
(Eq a, Num a, Pretty a) =>
Maybe QName
-> Bool
-> a
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
compData Maybe QName
forall a. Maybe a
Nothing Bool
False (Defn -> Nat
recPars Defn
r) Command
cmd FamilyOrNot (Arg Term)
l ([Arg Term]
as [Arg Term] -> FamilyOrNot Term -> FamilyOrNot [Arg Term]
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) Blocked (FamilyOrNot (Arg Term))
sbA Blocked (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
u0
Datatype{dataPars :: Defn -> Nat
dataPars = Nat
pars, dataIxs :: Defn -> Nat
dataIxs = Nat
ixs, dataPathCons :: Defn -> [QName]
dataPathCons = [QName]
pcons, dataTransp :: Defn -> Maybe QName
dataTransp = Maybe QName
mtrD}
| [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [[QName] -> Bool
forall a. Null a => a -> Bool
null [QName]
pcons Bool -> Bool -> Bool
&& Nat
ixs Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0 | Command
DoHComp <- [Command
cmd]], Just [Arg Term]
as <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es ->
Maybe QName
-> Bool
-> Nat
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall {a}.
(Eq a, Num a, Pretty a) =>
Maybe QName
-> Bool
-> a
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
compData Maybe QName
mtrD ((Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [QName] -> Bool
forall a. Null a => a -> Bool
null ([QName] -> Bool) -> [QName] -> Bool
forall a b. (a -> b) -> a -> b
$ [QName]
pcons) Bool -> Bool -> Bool
|| Nat
ixs Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
0) (Nat
parsNat -> Nat -> Nat
forall a. Num a => a -> a -> a
+Nat
ixs) Command
cmd FamilyOrNot (Arg Term)
l ([Arg Term]
as [Arg Term] -> FamilyOrNot Term -> FamilyOrNot [Arg Term]
forall a b. a -> FamilyOrNot b -> FamilyOrNot a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ FamilyOrNot Term
t) Blocked (FamilyOrNot (Arg Term))
sbA Blocked (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
u0
Axiom Bool
constTransp | Bool
constTransp, [] <- [Elim]
es, Command
DoTransp <- Command
cmd -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u0
Defn
_ -> ReduceM (Reduced MaybeReducedArgs Term)
fallback
Term
_ -> ReduceM (Reduced MaybeReducedArgs Term)
fallback
where
allComponentsBack :: (IntervalView -> Term)
-> Term
-> Term
-> (Term -> a)
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
allComponentsBack IntervalView -> Term
unview Term
phi Term
u Term -> a
p = do
let
boolToI :: Bool -> Term
boolToI Bool
b = if Bool
b then IntervalView -> Term
unview IntervalView
IOne else IntervalView -> Term
unview IntervalView
IZero
lamlam :: Term -> Term
lamlam Term
t = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i" (ArgInfo -> Abs Term -> Term
Lam (Relevance -> ArgInfo -> ArgInfo
forall a. LensRelevance a => Relevance -> a -> a
setRelevance Relevance
Irrelevant ArgInfo
defaultArgInfo) (String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"o" Term
t)))
[(IntMap Bool, [Term])]
as <- Term -> ReduceM [(IntMap Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(IntMap Bool, [Term])]
decomposeInterval Term
phi
([a]
flags,[Maybe (Blocked' Term Term, IntMap Bool)]
t_alphas) <- ([(a, Maybe (Blocked' Term Term, IntMap Bool))]
-> ([a], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> ReduceM [(a, Maybe (Blocked' Term Term, IntMap Bool))]
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap [(a, Maybe (Blocked' Term Term, IntMap Bool))]
-> ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. [(a, b)] -> ([a], [b])
unzip (ReduceM [(a, Maybe (Blocked' Term Term, IntMap Bool))]
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> (((IntMap Bool, [Term])
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> ReduceM [(a, Maybe (Blocked' Term Term, IntMap Bool))])
-> ((IntMap Bool, [Term])
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [(IntMap Bool, [Term])]
-> ((IntMap Bool, [Term])
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> ReduceM [(a, Maybe (Blocked' Term Term, IntMap Bool))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(IntMap Bool, [Term])]
as (((IntMap Bool, [Term])
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> ((IntMap Bool, [Term])
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. (a -> b) -> a -> b
$ \ (IntMap Bool
bs,[Term]
ts) -> do
let u' :: Term
u' = [(Nat, Term)] -> Substitution' Term
forall a. EndoSubst a => [(Nat, a)] -> Substitution' a
listS [(Nat, Term)]
bs' Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
u
bs' :: [(Nat, Term)]
bs' = IntMap Term -> [(Nat, Term)]
forall a. IntMap a -> [(Nat, a)]
IntMap.toAscList (IntMap Term -> [(Nat, Term)]) -> IntMap Term -> [(Nat, Term)]
forall a b. (a -> b) -> a -> b
$ (Bool -> Term) -> IntMap Bool -> IntMap Term
forall a b. (a -> b) -> IntMap a -> IntMap b
IntMap.map Bool -> Term
boolToI IntMap Bool
bs
let weaken :: Substitution' Term
weaken = (Nat -> Substitution' Term -> Substitution' Term)
-> Substitution' Term -> [Nat] -> Substitution' Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ Nat
j Substitution' Term
s -> Substitution' Term
s Substitution' Term -> Substitution' Term -> Substitution' Term
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Nat -> Nat -> Substitution' Term
forall a. Nat -> Nat -> Substitution' a
raiseFromS Nat
j Nat
1) Substitution' Term
forall a. Substitution' a
idS (((Nat, Term) -> Nat) -> [(Nat, Term)] -> [Nat]
forall a b. (a -> b) -> [a] -> [b]
map (Nat, Term) -> Nat
forall a b. (a, b) -> a
fst [(Nat, Term)]
bs')
Blocked' Term Term
t <- Term -> ReduceM (Blocked' Term Term)
reduce2Lam Term
u'
(a, Maybe (Blocked' Term Term, IntMap Bool))
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((a, Maybe (Blocked' Term Term, IntMap Bool))
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool)))
-> (a, Maybe (Blocked' Term Term, IntMap Bool))
-> ReduceM (a, Maybe (Blocked' Term Term, IntMap Bool))
forall a b. (a -> b) -> a -> b
$ (Term -> a
p (Term -> a) -> Term -> a
forall a b. (a -> b) -> a -> b
$ Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term Term
t, [(Blocked' Term Term, IntMap Bool)]
-> Maybe (Blocked' Term Term, IntMap Bool)
forall a. [a] -> Maybe a
listToMaybe [ (Substitution' Term
Substitution' (SubstArg (Blocked' Term Term))
weaken Substitution' (SubstArg (Blocked' Term Term))
-> Blocked' Term Term -> Blocked' Term Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` (Term -> Term
lamlam (Term -> Term) -> Blocked' Term Term -> Blocked' Term Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked' Term Term
t),IntMap Bool
bs) | [Term] -> Bool
forall a. Null a => a -> Bool
null [Term]
ts ])
([a], [Maybe (Blocked' Term Term, IntMap Bool)])
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (([a], [Maybe (Blocked' Term Term, IntMap Bool)])
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. (a -> b) -> a -> b
$ ([a]
flags,[Maybe (Blocked' Term Term, IntMap Bool)]
t_alphas)
compData :: Maybe QName
-> Bool
-> a
-> Command
-> FamilyOrNot (Arg Term)
-> FamilyOrNot [Arg Term]
-> Blocked (FamilyOrNot (Arg Term))
-> Blocked (Arg Term)
-> Maybe (Arg Term)
-> Arg Term
-> ReduceM (Reduced MaybeReducedArgs Term)
compData Maybe QName
mtrD Bool
False a
_ cmd :: Command
cmd@Command
DoHComp (IsNot Arg Term
l) (IsNot [Arg Term]
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi (Just Arg Term
u) Arg Term
a0 = do
let getTermLocal :: IsBuiltin a => a -> ReduceM Term
getTermLocal :: forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal = String -> a -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (String -> a -> ReduceM Term) -> String -> a -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ String
"builtinHComp for data types"
let sc :: Blocked (Arg Term)
sc = FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
fsc
Term
tEmpty <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIsOneEmpty
Term
tPOr <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinPOr
Term
iO <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIOne
Term
iZ <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIZero
Term
tMin <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinIMin
Term
tNeg <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinINeg
let iNeg :: Term -> Term
iNeg Term
t = Term
tNeg Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
t]
iMin :: Term -> Term -> Term
iMin Term
t Term
u = Term
tMin Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
t, Term -> Arg Term
forall e. e -> Arg e
argN Term
u]
iz :: NamesT ReduceM Term
iz = Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iZ
Term -> Term
constrForm <- do
Maybe Term
mz <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinZero
Maybe Term
ms <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinSuc
(Term -> Term) -> ReduceM (Term -> Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Term) -> ReduceM (Term -> Term))
-> (Term -> Term) -> ReduceM (Term -> Term)
forall a b. (a -> b) -> a -> b
$ \ Term
t -> Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
t (Maybe Term -> Maybe Term -> Term -> Maybe Term
forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> Term -> m Term
constructorForm' Maybe Term
mz Maybe Term
ms Term
t)
Blocked (Arg Term)
su <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
u
Blocked (Arg Term)
sa0 <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
a0
Term -> IntervalView
view <- ReduceM (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
IntervalView -> Term
unview <- ReduceM (IntervalView -> Term)
forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
let f :: Blocked' t (Arg c) -> c
f = Arg c -> c
forall e. Arg e -> e
unArg (Arg c -> c)
-> (Blocked' t (Arg c) -> Arg c) -> Blocked' t (Arg c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg c) -> Arg c
forall t a. Blocked' t a -> a
ignoreBlocking
phi :: Term
phi = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sphi
a0 :: Term
a0 = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sa0
isLit :: Term -> Maybe Term
isLit t :: Term
t@(Lit Literal
lt) = Term -> Maybe Term
forall a. a -> Maybe a
Just Term
t
isLit Term
_ = Maybe Term
forall a. Maybe a
Nothing
isCon :: Term -> Maybe ConHead
isCon (Con ConHead
h ConInfo
_ [Elim]
_) = ConHead -> Maybe ConHead
forall a. a -> Maybe a
Just ConHead
h
isCon Term
_ = Maybe ConHead
forall a. Maybe a
Nothing
combine :: NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
combine NamesT ReduceM Term
l NamesT ReduceM Term
ty NamesT ReduceM Term
d [] = NamesT ReduceM Term
d
combine NamesT ReduceM Term
l NamesT ReduceM Term
ty NamesT ReduceM Term
d [(NamesT ReduceM Term
psi,NamesT ReduceM Term
u)] = NamesT ReduceM Term
u
combine NamesT ReduceM Term
l NamesT ReduceM Term
ty NamesT ReduceM Term
d ((NamesT ReduceM Term
psi,NamesT ReduceM Term
u):[(NamesT ReduceM Term, NamesT ReduceM Term)]
xs)
= Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
psi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> ((NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). HasBuiltins m => m Term -> m Term -> m Term
imax (NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term)
-> ((NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term, NamesT ReduceM Term)
-> NamesT ReduceM Term
-> NamesT ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamesT ReduceM Term, NamesT ReduceM Term) -> NamesT ReduceM Term
forall a b. (a, b) -> a
fst) NamesT ReduceM Term
iz [(NamesT ReduceM Term, NamesT ReduceM Term)]
xs
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT ReduceM Term
_ -> NamesT ReduceM Term
ty)
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
combine NamesT ReduceM Term
l NamesT ReduceM Term
ty NamesT ReduceM Term
d [(NamesT ReduceM Term, NamesT ReduceM Term)]
xs)
noRed' :: Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
noRed' Blocked (Arg Term)
su = Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
l,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sc, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
su', Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sa0]
where
su' :: Blocked (Arg Term)
su' = case Term -> IntervalView
view Term
phi of
IntervalView
IZero -> Arg Term -> Blocked (Arg Term)
forall a t. a -> Blocked' t a
notBlocked (Arg Term -> Blocked (Arg Term)) -> Arg Term -> Blocked (Arg Term)
forall a b. (a -> b) -> a -> b
$ Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Names -> NamesT Fail Term -> Term
forall a. Names -> NamesT Fail a -> a
runNames [] (NamesT Fail Term -> Term) -> NamesT Fail Term -> Term
forall a b. (a -> b) -> a -> b
$ do
[NamesT Fail Term
l,NamesT Fail Term
c] <- (Arg Term -> NamesT Fail (NamesT Fail Term))
-> [Arg Term] -> NamesT Fail [NamesT Fail Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT Fail (NamesT Fail Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT Fail (NamesT Fail Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT Fail (NamesT Fail Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc]
String
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term)
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall a b. (a -> b) -> a -> b
$ \ NamesT Fail Term
i -> Term -> NamesT Fail Term
forall a. a -> NamesT Fail a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tEmpty NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT Fail Term
l
NamesT Fail Term -> NamesT Fail Term -> NamesT Fail Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> String
-> (NamesT Fail Term -> NamesT Fail Term) -> NamesT Fail Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" (\ NamesT Fail Term
_ -> NamesT Fail Term
c)
IntervalView
_ -> Blocked (Arg Term)
su
sameConHeadBack :: Maybe Term
-> Maybe ConHead
-> Blocked (Arg Term)
-> (ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
sameConHeadBack Maybe Term
Nothing Maybe ConHead
Nothing Blocked (Arg Term)
su ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
k = Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
noRed' Blocked (Arg Term)
su
sameConHeadBack Maybe Term
lt Maybe ConHead
h Blocked (Arg Term)
su ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
k = do
let u :: Term
u = Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term)
-> (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Term) -> Blocked (Arg Term) -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
su
([(Bool, Bool)]
b, [Maybe (Blocked' Term Term, IntMap Bool)]
ts) <- (IntervalView -> Term)
-> Term
-> Term
-> (Term -> (Bool, Bool))
-> ReduceM
([(Bool, Bool)], [Maybe (Blocked' Term Term, IntMap Bool)])
forall {a}.
(IntervalView -> Term)
-> Term
-> Term
-> (Term -> a)
-> ReduceM ([a], [Maybe (Blocked' Term Term, IntMap Bool)])
allComponentsBack IntervalView -> Term
unview Term
phi Term
u ((Term -> (Bool, Bool))
-> ReduceM
([(Bool, Bool)], [Maybe (Blocked' Term Term, IntMap Bool)]))
-> (Term -> (Bool, Bool))
-> ReduceM
([(Bool, Bool)], [Maybe (Blocked' Term Term, IntMap Bool)])
forall a b. (a -> b) -> a -> b
$ \ Term
t ->
(Term -> Maybe Term
isLit Term
t Maybe Term -> Maybe Term -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Term
lt, Term -> Maybe ConHead
isCon (Term -> Term
constrForm Term
t) Maybe ConHead -> Maybe ConHead -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe ConHead
h)
let
([Bool]
lit,[Bool]
hd) = [(Bool, Bool)] -> ([Bool], [Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Bool, Bool)]
b
if Maybe Term -> Bool
forall a. Maybe a -> Bool
isJust Maybe Term
lt Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
lit then Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
a0 else do
Blocked (Arg Term)
su <- Maybe [(Blocked' Term Term, IntMap Bool)]
-> ReduceM (Blocked (Arg Term))
-> ([(Blocked' Term Term, IntMap Bool)]
-> ReduceM (Blocked (Arg Term)))
-> ReduceM (Blocked (Arg Term))
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe ([Maybe (Blocked' Term Term, IntMap Bool)]
-> Maybe [(Blocked' Term Term, IntMap Bool)]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [Maybe (Blocked' Term Term, IntMap Bool)]
ts) (Blocked (Arg Term) -> ReduceM (Blocked (Arg Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocked (Arg Term)
su) (([(Blocked' Term Term, IntMap Bool)]
-> ReduceM (Blocked (Arg Term)))
-> ReduceM (Blocked (Arg Term)))
-> ([(Blocked' Term Term, IntMap Bool)]
-> ReduceM (Blocked (Arg Term)))
-> ReduceM (Blocked (Arg Term))
forall a b. (a -> b) -> a -> b
$ \ [(Blocked' Term Term, IntMap Bool)]
ts -> do
let ([Blocked' Term Term]
us,[IntMap Bool]
bools) = [(Blocked' Term Term, IntMap Bool)]
-> ([Blocked' Term Term], [IntMap Bool])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Blocked' Term Term, IntMap Bool)]
ts
(Term -> Blocked (Arg Term))
-> ReduceM Term -> ReduceM (Blocked (Arg Term))
forall a b. (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Blocked' Term Term] -> Blocked' Term ()
forall (t :: * -> *) (f :: * -> *) a.
(Foldable t, Applicative f) =>
t (f a) -> f ()
sequenceA_ [Blocked' Term Term]
us Blocked' Term () -> Arg Term -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) (Arg Term -> Blocked (Arg Term))
-> (Term -> Arg Term) -> Term -> Blocked (Arg Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Arg Term
forall e. e -> Arg e
argN) (ReduceM Term -> ReduceM (Blocked (Arg Term)))
-> ReduceM Term -> ReduceM (Blocked (Arg Term))
forall a b. (a -> b) -> a -> b
$ do
let
phis :: [Term]
phis :: [Term]
phis = [IntMap Bool] -> (IntMap Bool -> Term) -> [Term]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [IntMap Bool]
bools ((IntMap Bool -> Term) -> [Term])
-> (IntMap Bool -> Term) -> [Term]
forall a b. (a -> b) -> a -> b
$ \ IntMap Bool
m ->
((Nat, Bool) -> Term -> Term) -> Term -> [(Nat, Bool)] -> Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (Term -> Term -> Term
iMin (Term -> Term -> Term)
-> ((Nat, Bool) -> Term) -> (Nat, Bool) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\(Nat
i,Bool
b) -> Bool -> (Term -> Term) -> Term -> Term
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyUnless Bool
b Term -> Term
iNeg (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Nat -> Term
var Nat
i)) Term
iO (IntMap Bool -> [(Nat, Bool)]
forall a. IntMap a -> [(Nat, a)]
IntMap.toList IntMap Bool
m)
Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ do
NamesT ReduceM Term
u <- Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
u
[NamesT ReduceM Term
l,NamesT ReduceM Term
c] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc]
[NamesT ReduceM Term]
phis <- (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Term]
phis
[NamesT ReduceM Term]
us <- (Blocked' Term Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Blocked' Term Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Blocked' Term Term -> Term)
-> Blocked' Term Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking) [Blocked' Term Term]
us
String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
i -> do
NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
combine NamesT ReduceM Term
l NamesT ReduceM Term
c (NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) ([(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term)
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ [NamesT ReduceM Term]
-> [NamesT ReduceM Term]
-> [(NamesT ReduceM Term, NamesT ReduceM Term)]
forall a b. [a] -> [b] -> [(a, b)]
zip [NamesT ReduceM Term]
phis ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> [NamesT ReduceM Term] -> [NamesT ReduceM Term]
forall a b. (a -> b) -> [a] -> [b]
map (\ NamesT ReduceM Term
t -> NamesT ReduceM Term
t NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
i) [NamesT ReduceM Term]
us)
if Maybe ConHead -> Bool
forall a. Maybe a -> Bool
isJust Maybe ConHead
h Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and [Bool]
hd then ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
k (ConHead -> Maybe ConHead -> ConHead
forall a. a -> Maybe a -> a
fromMaybe ConHead
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe ConHead
h) Blocked (Arg Term)
su
else Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
noRed' Blocked (Arg Term)
su
Maybe Term
-> Maybe ConHead
-> Blocked (Arg Term)
-> (ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
sameConHeadBack (Term -> Maybe Term
isLit Term
a0) (Term -> Maybe ConHead
isCon Term
a0) Blocked (Arg Term)
su ((ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term))
-> (ConHead
-> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ \ ConHead
h Blocked (Arg Term)
su -> do
let u :: Term
u = Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term)
-> (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Term) -> Blocked (Arg Term) -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
su
Constructor{ conComp :: Defn -> CompKit
conComp = CompKit
cm } <- Definition -> Defn
theDef (Definition -> Defn) -> ReduceM Definition -> ReduceM Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
h)
case CompKit -> Maybe QName
nameOfHComp CompKit
cm of
Just QName
hcompD -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
hcompD [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply`
([Arg Term]
ps [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Term
phi,Term
u,Term
a0])
Maybe QName
Nothing -> Blocked (Arg Term) -> ReduceM (Reduced MaybeReducedArgs Term)
noRed' Blocked (Arg Term)
su
compData Maybe QName
mtrD Bool
_ a
0 Command
DoTransp (IsFam Arg Term
l) (IsFam [Arg Term]
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi Maybe (Arg Term)
Nothing Arg Term
a0 = Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a0
compData (Just QName
trD) Bool
isHIT a
_ cmd :: Command
cmd@Command
DoTransp (IsFam Arg Term
l) (IsFam [Arg Term]
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi Maybe (Arg Term)
Nothing Arg Term
a0 = do
let sc :: Blocked (Arg Term)
sc = FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
fsc
let f :: Blocked' t (Arg c) -> c
f = Arg c -> c
forall e. Arg e -> e
unArg (Arg c -> c)
-> (Blocked' t (Arg c) -> Arg c) -> Blocked' t (Arg c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg c) -> Arg c
forall t a. Blocked' t a -> a
ignoreBlocking
phi :: Term
phi :: Term
phi = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f (Blocked (Arg Term) -> Term) -> Blocked (Arg Term) -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi
let lam_i :: Term -> Term
lam_i = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Term -> Abs Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i"
Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
trD [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` ((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> Arg Term -> Arg Term
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) [Arg Term]
ps [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Term
phi,Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a0])
compData Maybe QName
mtrD Bool
isHIT a
_ cmd :: Command
cmd@Command
DoTransp (IsFam Arg Term
l) (IsFam [Arg Term]
ps) Blocked (FamilyOrNot (Arg Term))
fsc Blocked (Arg Term)
sphi Maybe (Arg Term)
Nothing Arg Term
a0 = do
let getTermLocal :: IsBuiltin a => a -> ReduceM Term
getTermLocal :: forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal = String -> a -> ReduceM Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (String -> a -> ReduceM Term) -> String -> a -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ PrimitiveId -> String
forall a. IsBuiltin a => a -> String
getBuiltinId PrimitiveId
builtinTrans String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" for data types"
let sc :: Blocked (Arg Term)
sc = FamilyOrNot (Arg Term) -> Arg Term
forall a. FamilyOrNot a -> a
famThing (FamilyOrNot (Arg Term) -> Arg Term)
-> Blocked (FamilyOrNot (Arg Term)) -> Blocked (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Blocked (FamilyOrNot (Arg Term))
fsc
Maybe QName
mhcompName <- PrimitiveId -> ReduceM (Maybe QName)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe QName)
getName' PrimitiveId
builtinHComp
Term -> Term
constrForm <- do
Maybe Term
mz <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinZero
Maybe Term
ms <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinSuc
(Term -> Term) -> ReduceM (Term -> Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term -> Term) -> ReduceM (Term -> Term))
-> (Term -> Term) -> ReduceM (Term -> Term)
forall a b. (a -> b) -> a -> b
$ \ Term
t -> Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
t (Maybe Term -> Maybe Term -> Term -> Maybe Term
forall (m :: * -> *).
Applicative m =>
m Term -> m Term -> Term -> m Term
constructorForm' Maybe Term
mz Maybe Term
ms Term
t)
Blocked (Arg Term)
sa0 <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
a0
let f :: Blocked' t (Arg c) -> c
f = Arg c -> c
forall e. Arg e -> e
unArg (Arg c -> c)
-> (Blocked' t (Arg c) -> Arg c) -> Blocked' t (Arg c) -> c
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked' t (Arg c) -> Arg c
forall t a. Blocked' t a -> a
ignoreBlocking
phi :: Term
phi = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sphi
a0 :: Term
a0 = Blocked (Arg Term) -> Term
forall {t} {c}. Blocked' t (Arg c) -> c
f Blocked (Arg Term)
sa0
noRed :: ReduceM (Reduced MaybeReducedArgs Term)
noRed = Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Arg Term -> MaybeReduced (Arg Term)
forall a. a -> MaybeReduced a
notReduced Arg Term
l,Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sc, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi, Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sa0]
let lam_i :: Term -> Term
lam_i = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Term -> Abs Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i"
case Term -> Term
constrForm Term
a0 of
Con ConHead
h ConInfo
_ [Elim]
args -> do
Constructor{ conComp :: Defn -> CompKit
conComp = CompKit
cm } <- Definition -> Defn
theDef (Definition -> Defn) -> ReduceM Definition -> ReduceM Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ReduceM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
h)
case CompKit -> Maybe QName
nameOfTransp CompKit
cm of
Just QName
transpD -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Term
Def QName
transpD [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply`
((Arg Term -> Arg Term) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map ((Term -> Term) -> Arg Term -> Arg Term
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Term
lam_i) [Arg Term]
ps [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Term
phi,Term
a0])
Maybe QName
Nothing -> ReduceM (Reduced MaybeReducedArgs Term)
noRed
Def QName
q [Elim]
es | Bool
isHIT, QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mhcompName, Just [Arg Term
_l0,Arg Term
_c0,Arg Term
psi,Arg Term
u,Arg Term
u0] <- [Elim] -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims [Elim]
es -> do
let bC :: Arg Term
bC = Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sc
Term
hcomp <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinHComp
Term
transp <- PrimitiveId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal PrimitiveId
builtinTrans
Term
io <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIOne
Term
iz <- BuiltinId -> ReduceM Term
forall a. IsBuiltin a => a -> ReduceM Term
getTermLocal BuiltinId
builtinIZero
Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
[NamesT ReduceM Term
l,NamesT ReduceM Term
bC,NamesT ReduceM Term
phi,NamesT ReduceM Term
psi,NamesT ReduceM Term
u,NamesT ReduceM Term
u0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
bC,Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi,Arg Term
psi,Arg Term
u,Arg Term
u0]
Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
hcomp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT ReduceM Term
bC NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
psi
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" (\ NamesT ReduceM Term
j -> String
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term)
-> (NamesT ReduceM Term -> NamesT ReduceM Term)
-> NamesT ReduceM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT ReduceM Term
o ->
Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
transp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
bC NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT ReduceM Term
u NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
j NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT ReduceM Term
o))
NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT ReduceM Term
forall a. a -> NamesT ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
transp NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT ReduceM Term
l NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
bC NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
phi NamesT ReduceM Term -> NamesT ReduceM Term -> NamesT ReduceM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT ReduceM Term
u0)
Term
_ -> ReduceM (Reduced MaybeReducedArgs Term)
noRed
compData Maybe QName
mtrX Bool
isHITorIx a
nargs Command
cmd FamilyOrNot (Arg Term)
l FamilyOrNot [Arg Term]
t Blocked (FamilyOrNot (Arg Term))
sbA Blocked (Arg Term)
sphi Maybe (Arg Term)
u Arg Term
u0 = do
() <- String -> Nat -> TCMT IO Doc -> ReduceM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
"impossible" Nat
10 (TCMT IO Doc -> ReduceM ()) -> TCMT IO Doc -> ReduceM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"compData" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc)
-> ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat)
[ TCMT IO Doc
"mtrX: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Maybe QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Maybe QName
mtrX
, TCMT IO Doc
"isHITorIx: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Bool -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Bool
isHITorIx
, TCMT IO Doc
"nargs: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty a
nargs
, TCMT IO Doc
"cmd: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (Command -> String
forall a. Show a => a -> String
show Command
cmd)
, TCMT IO Doc
"l: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> FamilyOrNot (Arg Term) -> TCMT IO Doc
forall p a. IsString p => FamilyOrNot a -> p
familyOrNot FamilyOrNot (Arg Term)
l
, TCMT IO Doc
"t: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> FamilyOrNot [Arg Term] -> TCMT IO Doc
forall p a. IsString p => FamilyOrNot a -> p
familyOrNot FamilyOrNot [Arg Term]
t TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Arg Term] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (FamilyOrNot [Arg Term] -> [Arg Term]
forall a. FamilyOrNot a -> a
famThing FamilyOrNot [Arg Term]
t)
, TCMT IO Doc
"sbA: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> FamilyOrNot (Arg Term) -> TCMT IO Doc
forall p a. IsString p => FamilyOrNot a -> p
familyOrNot (Blocked (FamilyOrNot (Arg Term)) -> FamilyOrNot (Arg Term)
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (FamilyOrNot (Arg Term)) -> FamilyOrNot (Arg Term))
-> Blocked (FamilyOrNot (Arg Term)) -> FamilyOrNot (Arg Term)
forall a b. (a -> b) -> a -> b
$ Blocked (FamilyOrNot (Arg Term))
sbA)
, TCMT IO Doc
"sphi: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi)
, TCMT IO Doc
"isJust u: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Bool -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Maybe (Arg Term) -> Bool
forall a. Maybe a -> Bool
isJust Maybe (Arg Term)
u)
, TCMT IO Doc
"u0: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Arg Term
u0
]
ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
primComp :: TCM PrimitiveImpl
primComp :: TCM PrimitiveImpl
primComp = do
Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
Type
t <- Names -> NamesT (TCMT IO) Type -> TCMT IO Type
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Type -> TCMT IO Type)
-> NamesT (TCMT IO) Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"a" (NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Sort
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Sort -> m Term -> m Type
els (Sort -> NamesT (TCMT IO) Sort
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Sort
forall t. Sort' t
LevelUniv) (TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primLevel)) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
a ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"A" (String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
i -> (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i))) ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
bA ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
hPi' String
"φ" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
phi ->
String
-> NamesT (TCMT IO) Type
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadFail m, MonadAddContext m, MonadDebug m) =>
String
-> NamesT m Type
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
nPi' String
"i" NamesT (TCMT IO) Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType (\ NamesT (TCMT IO) Term
i -> String
-> NamesT (TCMT IO) Term
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall (m :: * -> *).
(MonadAddContext m, HasBuiltins m, MonadDebug m) =>
String
-> NamesT m Term
-> (NamesT m Term -> NamesT m Type)
-> NamesT m Type
pPi' String
"o" NamesT (TCMT IO) Term
phi ((NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type)
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type)
-> NamesT (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ \ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i) (NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i)) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
-->
(NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) (NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero) NamesT (TCMT IO) Type
-> NamesT (TCMT IO) Type -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne) (NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne))
Term
one <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
Term
io <- TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne
PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> [Occurrence]
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
PrimFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
5 [] (([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun)
-> ([Arg Term] -> Nat -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \[Arg Term]
ts Nat
nelims -> do
case [Arg Term]
ts of
[Arg Term
l,Arg Term
c,Arg Term
phi,Arg Term
u,Arg Term
a0] -> do
Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
IntervalView
vphi <- Term -> ReduceM IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> ReduceM IntervalView) -> Term -> ReduceM IntervalView
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked (Arg Term)
sphi
case IntervalView
vphi of
IntervalView
IOne -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
io, Term -> Arg Term
forall e. e -> Arg e
argN Term
one])
IntervalView
_ -> do
Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturnNoSimpl (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> (NamesT ReduceM Term -> ReduceM Term)
-> NamesT ReduceM Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Names -> NamesT ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> NamesT ReduceM Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ do
NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp <- String
-> NamesT
ReduceM
(NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term)
forall (m :: * -> *).
HasBuiltins m =>
String
-> NamesT
m
(NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term)
mkComp (PrimitiveId -> String
forall a. IsBuiltin a => a -> String
getBuiltinId PrimitiveId
PrimComp)
[NamesT ReduceM Term
l,NamesT ReduceM Term
c,NamesT ReduceM Term
phi,NamesT ReduceM Term
u,NamesT ReduceM Term
a0] <- (Arg Term -> NamesT ReduceM (NamesT ReduceM Term))
-> [Arg Term] -> NamesT ReduceM [NamesT ReduceM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT ReduceM (NamesT ReduceM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT ReduceM (NamesT ReduceM Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT ReduceM (NamesT ReduceM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
l,Arg Term
c,Arg Term
phi,Arg Term
u,Arg Term
a0]
NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
-> NamesT ReduceM Term
comp NamesT ReduceM Term
l NamesT ReduceM Term
c NamesT ReduceM Term
phi NamesT ReduceM Term
u NamesT ReduceM Term
a0
[Arg Term]
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
primFaceForall' :: TCM PrimitiveImpl
primFaceForall' :: TCM PrimitiveImpl
primFaceForall' = do
Cubical -> String -> TCM ()
requireCubical Cubical
CErased String
""
Type
t <- (TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType TCMT IO Type -> TCMT IO Type -> TCMT IO Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType) TCMT IO Type -> TCMT IO Type -> TCMT IO Type
forall (m :: * -> *). Applicative m => m Type -> m Type -> m Type
--> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
PrimitiveImpl -> TCM PrimitiveImpl
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (PrimitiveImpl -> TCM PrimitiveImpl)
-> PrimitiveImpl -> TCM PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ Type -> PrimFun -> PrimitiveImpl
PrimImpl Type
t (PrimFun -> PrimitiveImpl) -> PrimFun -> PrimitiveImpl
forall a b. (a -> b) -> a -> b
$ QName
-> Nat
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
primFun QName
forall a. HasCallStack => a
__IMPOSSIBLE__ Nat
1 (([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun)
-> ([Arg Term] -> ReduceM (Reduced MaybeReducedArgs Term))
-> PrimFun
forall a b. (a -> b) -> a -> b
$ \case
[Arg Term
phi] -> do
Blocked (Arg Term)
sphi <- Arg Term -> ReduceM (Blocked (Arg Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg Term
phi
case Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> Term) -> Arg Term -> Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term) -> Arg Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked (Arg Term) -> Arg Term) -> Blocked (Arg Term) -> Arg Term
forall a b. (a -> b) -> a -> b
$ Blocked (Arg Term)
sphi of
Lam ArgInfo
_ Abs Term
t -> do
Abs Term
t <- Abs Term -> ReduceM (Abs Term)
forall t. Reduce t => t -> ReduceM t
reduce' Abs Term
t
case Abs Term
t of
NoAbs String
_ Term
t -> Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn Term
t
Abs String
_ Term
t ->
ReduceM (Reduced MaybeReducedArgs Term)
-> (Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> Maybe Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term))
-> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a b. (a -> b) -> a -> b
$ MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi]) Term -> ReduceM (Reduced MaybeReducedArgs Term)
forall a a'. a -> ReduceM (Reduced a' a)
redReturn
(Maybe Term -> ReduceM (Reduced MaybeReducedArgs Term))
-> ReduceM (Maybe Term) -> ReduceM (Reduced MaybeReducedArgs Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> ReduceM (Maybe Term)
forall {m :: * -> *}. HasBuiltins m => Term -> m (Maybe Term)
toFaceMapsPrim Term
t
Term
_ -> Reduced MaybeReducedArgs Term
-> ReduceM (Reduced MaybeReducedArgs Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (MaybeReducedArgs -> Reduced MaybeReducedArgs Term
forall no yes. no -> Reduced no yes
NoReduction [Blocked (Arg Term) -> MaybeReduced (Arg Term)
reduced Blocked (Arg Term)
sphi])
[Arg Term]
_ -> ReduceM (Reduced MaybeReducedArgs Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
where
toFaceMapsPrim :: Term -> m (Maybe Term)
toFaceMapsPrim Term
t = do
Term -> IntervalView
view <- m (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView'
IntervalView -> Term
unview <- m (IntervalView -> Term)
forall (m :: * -> *). HasBuiltins m => m (IntervalView -> Term)
intervalUnview'
[(IntMap Bool, [Term])]
us' <- Term -> m [(IntMap Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(IntMap Bool, [Term])]
decomposeInterval Term
t
Term
fr <- String -> PrimitiveId -> m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm (PrimitiveId -> String
forall a. IsBuiltin a => a -> String
getBuiltinId PrimitiveId
PrimFaceForall) PrimitiveId
PrimFaceForall
let
v :: IntervalView
v = Term -> IntervalView
view Term
t
us :: [[Either (Int, Bool) Term]]
us :: [[Either (Nat, Bool) Term]]
us = [ ((Nat, Bool) -> Either (Nat, Bool) Term)
-> [(Nat, Bool)] -> [Either (Nat, Bool) Term]
forall a b. (a -> b) -> [a] -> [b]
map (Nat, Bool) -> Either (Nat, Bool) Term
forall a b. a -> Either a b
Left (IntMap Bool -> [(Nat, Bool)]
forall a. IntMap a -> [(Nat, a)]
IntMap.toList IntMap Bool
bsm) [Either (Nat, Bool) Term]
-> [Either (Nat, Bool) Term] -> [Either (Nat, Bool) Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Either (Nat, Bool) Term)
-> [Term] -> [Either (Nat, Bool) Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Either (Nat, Bool) Term
forall a b. b -> Either a b
Right [Term]
ts
| (IntMap Bool
bsm, [Term]
ts) <- [(IntMap Bool, [Term])]
us', Nat
0 Nat -> IntMap Bool -> Bool
forall a. Nat -> IntMap a -> Bool
`IntMap.notMember` IntMap Bool
bsm
]
fm :: (Nat, Bool) -> Term
fm (Nat
i, Bool
b) = if Bool
b then Nat -> Term
var (Nat
i Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1) else IntervalView -> Term
unview (Arg Term -> IntervalView
INeg (Term -> Arg Term
forall e. e -> Arg e
argN (Nat -> Term
var (Nat -> Term) -> Nat -> Term
forall a b. (a -> b) -> a -> b
$ Nat
i Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1)))
ffr :: Term -> Term
ffr Term
t = Term
fr Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i" Term
t]
conjuncts :: [Either (Int, Bool) Term] -> Term
conjuncts :: [Either (Nat, Bool) Term] -> Term
conjuncts [] = IntervalView -> Term
unview IntervalView
IOne
conjuncts [Either (Nat, Bool) Term
x] = ((Nat, Bool) -> Term)
-> (Term -> Term) -> Either (Nat, Bool) Term -> Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Nat, Bool) -> Term
fm Term -> Term
ffr Either (Nat, Bool) Term
x
conjuncts (Either (Nat, Bool) Term
x:[Either (Nat, Bool) Term]
xs) =
(Either (Nat, Bool) Term -> Term -> Term)
-> Term -> [Either (Nat, Bool) Term] -> Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\Either (Nat, Bool) Term
x Term
r -> IntervalView -> Term
unview (Arg Term -> Arg Term -> IntervalView
IMin (Term -> Arg Term
forall e. e -> Arg e
argN (((Nat, Bool) -> Term)
-> (Term -> Term) -> Either (Nat, Bool) Term -> Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Nat, Bool) -> Term
fm Term -> Term
ffr Either (Nat, Bool) Term
x)) (Term -> Arg Term
forall e. e -> Arg e
argN Term
r)))
(((Nat, Bool) -> Term)
-> (Term -> Term) -> Either (Nat, Bool) Term -> Term
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (Nat, Bool) -> Term
fm Term -> Term
ffr Either (Nat, Bool) Term
x)
[Either (Nat, Bool) Term]
xs
disjuncts :: Term
disjuncts = ([Either (Nat, Bool) Term] -> Term -> Term)
-> Term -> [[Either (Nat, Bool) Term]] -> Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr
(\[Either (Nat, Bool) Term]
conj Term
rest -> IntervalView -> Term
unview (Arg Term -> Arg Term -> IntervalView
IMax (Term -> Arg Term
forall e. e -> Arg e
argN ([Either (Nat, Bool) Term] -> Term
conjuncts [Either (Nat, Bool) Term]
conj)) (Term -> Arg Term
forall e. e -> Arg e
argN Term
rest)))
(IntervalView -> Term
unview IntervalView
IZero)
[[Either (Nat, Bool) Term]]
us
Maybe Term -> m (Maybe Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Term -> m (Maybe Term)) -> Maybe Term -> m (Maybe Term)
forall a b. (a -> b) -> a -> b
$ case [(IntMap Bool, [Term])]
us' of
[(IntMap Bool
m, [Term
_])] | IntMap Bool -> Bool
forall a. Null a => a -> Bool
null IntMap Bool
m -> Maybe Term
forall a. Maybe a
Nothing
[(IntMap Bool, [Term])]
_ -> Term -> Maybe Term
forall a. a -> Maybe a
Just Term
disjuncts
transpTel :: Abs Telescope
-> Term
-> Args
-> ExceptT (Closure (Abs Type)) TCM Args
transpTel :: Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
transpTel = Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpTel' Bool
False
transpTel' :: (PureTCM m, MonadError TCErr m) =>
Bool -> Abs Telescope
-> Term
-> Args
-> ExceptT (Closure (Abs Type)) m Args
transpTel' :: forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpTel' Bool
flag Abs Telescope
delta Term
phi [Arg Term]
args = Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpSysTel' Bool
flag Abs Telescope
delta [] Term
phi [Arg Term]
args
type LM m a = NamesT (ExceptT (Closure (Abs Type)) m) a
transpSysTel' :: forall m. (PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term,Abs [Term])]
-> Term
-> Args
-> ExceptT (Closure (Abs Type)) m Args
transpSysTel' :: forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpSysTel' Bool
flag Abs Telescope
delta [(Term, Abs [Term])]
us Term
phi [Arg Term]
args = do
String -> Nat -> TCMT IO Doc -> ExceptT (Closure (Abs Type)) m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
"cubical.prim.transpTel" Nat
20 (TCMT IO Doc -> ExceptT (Closure (Abs Type)) m ())
-> TCMT IO Doc -> ExceptT (Closure (Abs Type)) m ()
forall a b. (a -> b) -> a -> b
$
[TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"transpSysTel'"
, (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"delta =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>) (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (String, Dom' Term Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
(String, Dom' Term Type) -> m a -> m a
addContext (String
"i" :: String, Dom' Term Type
HasCallStack => Dom' Term Type
__DUMMY_DOM__) (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM (Abs Telescope -> Telescope
forall a. Abs a -> a
unAbs Abs Telescope
delta)
, (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"phi =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>) (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
phi
, (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"args =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>) (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (Arg Term -> TCMT IO Doc) -> [Arg Term] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM [Arg Term]
args
]
let getTermLocal :: IsBuiltin a => a -> ExceptT e m Term
getTermLocal :: forall a e. IsBuiltin a => a -> ExceptT e m Term
getTermLocal = String -> a -> ExceptT e m Term
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
String -> a -> m Term
getTerm String
"transpSys"
Term
tTransp <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primTrans
Term
tComp <- PrimitiveId -> ExceptT (Closure (Abs Type)) m Term
forall a e. IsBuiltin a => a -> ExceptT e m Term
getTermLocal PrimitiveId
builtinComp
Term
tPOr <- PrimitiveId -> ExceptT (Closure (Abs Type)) m Term
forall a e. IsBuiltin a => a -> ExceptT e m Term
getTermLocal PrimitiveId
builtinPOr
Term
iz <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
Term
imin <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin
Term
imax <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax
Term
ineg <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
let
noTranspError :: Abs a -> t m b
noTranspError Abs a
t = do
String -> Nat -> TCMT IO Doc -> t m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
"cubical.prim.transpTel" Nat
20 (TCMT IO Doc -> t m ()) -> TCMT IO Doc -> t m ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"error type =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>) (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
(String, Dom' Term Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
(String, Dom' Term Type) -> m a -> m a
addContext (String
"i" :: String, Dom' Term Type
HasCallStack => Dom' Term Type
__DUMMY_DOM__) (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM (a -> TCMT IO Doc) -> a -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Abs a -> a
forall a. Abs a -> a
unAbs Abs a
t
m b -> t m b
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m b -> t m b)
-> (Closure (Abs a) -> m b) -> Closure (Abs a) -> t m b
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Abs a) -> m b
forall a. Closure (Abs a) -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Closure (Abs a) -> t m b) -> t m (Closure (Abs a)) -> t m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Abs a -> t m (Closure (Abs a))
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Abs a
t
bapp :: forall m a. (Applicative m, Subst a) => m (Abs a) -> m (SubstArg a) -> m a
bapp :: forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
bapp m (Abs a)
t m (SubstArg a)
u = Abs a -> SubstArg a -> a
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs a -> SubstArg a -> a) -> m (Abs a) -> m (SubstArg a -> a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m (Abs a)
t m (SubstArg a -> a) -> m (SubstArg a) -> m a
forall a b. m (a -> b) -> m a -> m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> m (SubstArg a)
u
doGTransp :: NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
doGTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
us NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a | [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> Bool
forall a. Null a => a -> Bool
null [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
us = Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Abs Type -> Abs Term) -> Abs Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Term) -> Abs Type -> Abs Term
forall a b. (a -> b) -> Abs a -> Abs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Term
forall t a. Type'' t a -> a
unEl (Abs Type -> Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t) NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
a
| Bool
otherwise = Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tComp NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Abs Type -> Abs Term) -> Abs Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> Term) -> Abs Type -> Abs Term
forall a b. (a -> b) -> Abs a -> Abs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Term
forall t a. Type'' t a -> a
unEl (Abs Type -> Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t) NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) m) Term
face NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
uphi NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
a
where
face :: NamesT (ExceptT (Closure (Abs Type)) m) Term
face = (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ NamesT (ExceptT (Closure (Abs Type)) m) Term
x NamesT (ExceptT (Closure (Abs Type)) m) Term
y -> Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imax NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
x NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
y) (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) (NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
forall a. a -> [a] -> [a]
: ((NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
forall a b. (a -> b) -> [a] -> [b]
map (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a, b) -> a
fst [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
us)
uphi :: NamesT (ExceptT (Closure (Abs Type)) m) Term
uphi = String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
i -> String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
o -> do
let sys' :: [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
sys' = (NamesT (ExceptT (Closure (Abs Type)) m) Term
phi , NamesT (ExceptT (Closure (Abs Type)) m) Term
a) (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
forall a. a -> [a] -> [a]
: ((NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
forall a b. (a -> b) -> [a] -> [b]
map ((NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Term)
i)) [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
us
sys :: [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
sys = ((NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
forall a b. (a -> b) -> [a] -> [b]
map ((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall b d a. (b -> d) -> (a, b) -> (a, d)
mapSnd ((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a b. (a -> b) -> a -> b
$ String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. a -> b -> a
const) [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
sys'
NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
combine (NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
i) (Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
bapp NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
i) NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. HasCallStack => a
__IMPOSSIBLE__ [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
sys NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (ExceptT (Closure (Abs Type)) m) Term
o
combine :: NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
combine NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
ty NamesT (ExceptT (Closure (Abs Type)) m) Term
d [] = NamesT (ExceptT (Closure (Abs Type)) m) Term
d
combine NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
ty NamesT (ExceptT (Closure (Abs Type)) m) Term
d [(NamesT (ExceptT (Closure (Abs Type)) m) Term
psi,NamesT (ExceptT (Closure (Abs Type)) m) Term
u)] = NamesT (ExceptT (Closure (Abs Type)) m) Term
u
combine NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
ty NamesT (ExceptT (Closure (Abs Type)) m) Term
d ((NamesT (ExceptT (Closure (Abs Type)) m) Term
psi,NamesT (ExceptT (Closure (Abs Type)) m) Term
u):[(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
xs)
= Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
psi NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> ((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (\ NamesT (ExceptT (Closure (Abs Type)) m) Term
x NamesT (ExceptT (Closure (Abs Type)) m) Term
y -> Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imax NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
x NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
y) (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) (((NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> [NamesT (ExceptT (Closure (Abs Type)) m) Term]
forall a b. (a -> b) -> [a] -> [b]
map (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a, b) -> a
fst [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
xs))
NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
_ -> NamesT (ExceptT (Closure (Abs Type)) m) Term
ty)
NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
u NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
combine NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
ty NamesT (ExceptT (Closure (Abs Type)) m) Term
d [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) Term)]
xs)
gTransp :: Maybe (LM m Term) -> LM m (Abs Type) -> [(LM m Term,LM m (Abs Term))] -> LM m Term -> LM m Term -> LM m Term
gTransp :: Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
gTransp (Just NamesT (ExceptT (Closure (Abs Type)) m) Term
l) NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a
| Bool
flag = do
Abs Type
t' <- NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t
[Abs Term]
us' <- ((NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) [Abs Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall a b. (a, b) -> b
snd [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u
case ( Nat
0 Nat -> Type -> Bool
forall a. Free a => Nat -> a -> Bool
`freeIn` (Nat -> Abs Type -> Abs Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Type
t' Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0)
, Nat
0 Nat -> [Term] -> Bool
forall a. Free a => Nat -> a -> Bool
`freeIn` (Abs Term -> Term) -> [Abs Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (\ Abs Term
u -> Nat -> Abs Term -> Abs Term
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Term
u Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0) [Abs Term]
us'
) of
(Bool
False,Bool
False) -> NamesT (ExceptT (Closure (Abs Type)) m) Term
a
(Bool
False,Bool
True) -> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
doGTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a
(Bool
True,Bool
_) -> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
doGTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a
| Bool
otherwise = NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
doGTransp NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a
gTransp Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
Nothing NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
sys NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a = do
let ([NamesT (ExceptT (Closure (Abs Type)) m) Term]
psis,[NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
us) = [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> ([NamesT (ExceptT (Closure (Abs Type)) m) Term],
[NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)])
forall a b. [(a, b)] -> ([a], [b])
unzip [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
sys
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi <- (Abs Telescope
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Telescope
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)))
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)))
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
forall a b. (a -> b) -> a -> b
$ do
String
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> do
TelV Telescope
xi Type
_ <- (ExceptT (Closure (Abs Type)) m (TelV Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type)
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) m (TelV Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type))
-> (Type -> ExceptT (Closure (Abs Type)) m (TelV Type))
-> Type
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> ExceptT (Closure (Abs Type)) m (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView (Type -> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type))
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (ExceptT (Closure (Abs Type)) m) Type
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type))
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
-> NamesT (ExceptT (Closure (Abs Type)) m) (TelV Type)
forall a b. (a -> b) -> a -> b
$ NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
Telescope -> NamesT (ExceptT (Closure (Abs Type)) m) Telescope
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Telescope
xi
[Arg String]
argnames <- do
Telescope -> [Arg String]
teleArgNames (Telescope -> [Arg String])
-> (Abs Telescope -> Telescope) -> Abs Telescope -> [Arg String]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs Telescope -> Telescope
forall a. Abs a -> a
unAbs (Abs Telescope -> [Arg String])
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) [Arg String]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi
[Arg String]
-> (NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
(Functor m, MonadFail m) =>
[Arg String]
-> (NamesT m [Arg Term] -> NamesT m Term) -> NamesT m Term
glamN [Arg String]
argnames ((NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
xi_args -> do
Abs Type
b' <- String
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> do
Type
ti <- NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
Abs Telescope
xin <- String
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i)
[Arg Term]
xi_args <- NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
xi_args
Term
ni <- Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
Term
phi <- NamesT (ExceptT (Closure (Abs Type)) m) Term
phi
ExceptT (Closure (Abs Type)) m Type
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) m Type
-> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> ExceptT (Closure (Abs Type)) m Type
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall a b. (a -> b) -> a -> b
$ Type -> [Arg Term] -> ExceptT (Closure (Abs Type)) m Type
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
forall (m :: * -> *).
(MonadReduce m, HasBuiltins m) =>
Type -> [Arg Term] -> m Type
piApplyM Type
ti ([Arg Term] -> ExceptT (Closure (Abs Type)) m Type)
-> ExceptT (Closure (Abs Type)) m [Arg Term]
-> ExceptT (Closure (Abs Type)) m Type
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
trFillTel' Bool
flag Abs Telescope
xin Term
phi [Arg Term]
xi_args Term
ni
[Abs Term]
usxi <- [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
-> (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) [Abs Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
us ((NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) [Abs Term])
-> (NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) [Abs Term]
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
u -> String
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> do
Term
ui <- NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
u NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` NamesT (ExceptT (Closure (Abs Type)) m) Term
NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Term)
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
Abs Telescope
xin <- String
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i)
[Arg Term]
xi_args <- NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
xi_args
Term
ni <- Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i
Term
phi <- NamesT (ExceptT (Closure (Abs Type)) m) Term
phi
ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
ui ([Arg Term] -> Term)
-> ExceptT (Closure (Abs Type)) m [Arg Term]
-> ExceptT (Closure (Abs Type)) m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
trFillTel' Bool
flag Abs Telescope
xin Term
phi [Arg Term]
xi_args Term
ni
Term
axi <- do
Term
a <- NamesT (ExceptT (Closure (Abs Type)) m) Term
a
Abs Telescope
xif <- String
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope))
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
xi NamesT (ExceptT (Closure (Abs Type)) m) (Abs Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Telescope)
-> NamesT (ExceptT (Closure (Abs Type)) m) Telescope
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i)
Term
phi <- NamesT (ExceptT (Closure (Abs Type)) m) Term
phi
[Arg Term]
xi_args <- NamesT (ExceptT (Closure (Abs Type)) m) [Arg Term]
xi_args
ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> ExceptT (Closure (Abs Type)) m Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
a ([Arg Term] -> Term)
-> ExceptT (Closure (Abs Type)) m [Arg Term]
-> ExceptT (Closure (Abs Type)) m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpTel' Bool
flag Abs Telescope
xif Term
phi [Arg Term]
xi_args
Sort
s <- Sort -> NamesT (ExceptT (Closure (Abs Type)) m) Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> NamesT (ExceptT (Closure (Abs Type)) m) Sort)
-> Sort -> NamesT (ExceptT (Closure (Abs Type)) m) Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort (Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody Abs Type
b')
String
-> Nat -> TCMT IO Doc -> NamesT (ExceptT (Closure (Abs Type)) m) ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
"cubical.transp" Nat
20 (TCMT IO Doc -> NamesT (ExceptT (Closure (Abs Type)) m) ())
-> TCMT IO Doc -> NamesT (ExceptT (Closure (Abs Type)) m) ()
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Nat -> Abs Type -> Abs Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Type
b' Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0)
let noTranspSort :: NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort = if Nat
0 Nat -> Type -> Bool
forall a. Free a => Nat -> a -> Bool
`freeIn` (Nat -> Abs Type -> Abs Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Type
b' Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0) Bool -> Bool -> Bool
|| Nat
0 Nat -> [Term] -> Bool
forall a. Free a => Nat -> a -> Bool
`freeIn` ((Abs Term -> Term) -> [Abs Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Abs Term -> SubstArg Term -> Term
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` Nat -> Term
var Nat
0) (Nat -> [Abs Term] -> [Abs Term]
forall a. Subst a => Nat -> a -> a
raise Nat
1 [Abs Term]
usxi))
then Abs Type -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadDebug (t m), PrettyTCM a, MonadTrans t,
MonadError (Closure (Abs a)) m, MonadTCEnv (t m),
ReadTCState (t m)) =>
Abs a -> t m b
noTranspError Abs Type
b'
else Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
axi
case Sort
s of
Type Level' Term
l -> do
NamesT (ExceptT (Closure (Abs Type)) m) Term
l <- Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a b. (a -> b) -> a -> b
$ Term -> Term
lam_i (Level' Term -> Term
Level Level' Term
l)
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
b' <- Abs Type
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Abs Type
b'
NamesT (ExceptT (Closure (Abs Type)) m) Term
axi <- Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
axi
[NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
usxi <- (Abs Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> [Abs Term]
-> NamesT
(ExceptT (Closure (Abs Type)) m)
[NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Abs Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Abs Term]
usxi
Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
gTransp (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. a -> Maybe a
Just NamesT (ExceptT (Closure (Abs Type)) m) Term
l) NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
b' ([NamesT (ExceptT (Closure (Abs Type)) m) Term]
-> [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
forall a b. [a] -> [b] -> [(a, b)]
zip [NamesT (ExceptT (Closure (Abs Type)) m) Term]
psis [NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)]
usxi) NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
axi
Inf Univ
_ Integer
_ -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
SSet Level' Term
_ -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
Sort
SizeUniv -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
Sort
LockUniv -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
Sort
IntervalUniv -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
Prop{} -> NamesT (ExceptT (Closure (Abs Type)) m) Term
noTranspSort
Sort
_ -> Abs Type -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadDebug (t m), PrettyTCM a, MonadTrans t,
MonadError (Closure (Abs a)) m, MonadTCEnv (t m),
ReadTCState (t m)) =>
Abs a -> t m b
noTranspError Abs Type
b'
lam_i :: Term -> Term
lam_i = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> (Term -> Abs Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i"
go :: Telescope -> [[(Term,Term)]] -> Term -> Args -> ExceptT (Closure (Abs Type)) m Args
go :: Telescope
-> [[(Term, Term)]]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
go Telescope
EmptyTel [] Term
_ [] = [Arg Term] -> ExceptT (Closure (Abs Type)) m [Arg Term]
forall a. a -> ExceptT (Closure (Abs Type)) m a
forall (m :: * -> *) a. Monad m => a -> m a
return []
go (ExtendTel Dom' Term Type
t Abs Telescope
delta) ([(Term, Term)]
u:[[(Term, Term)]]
us) Term
phi (Arg Term
a:[Arg Term]
args) = do
Sort
s <- Sort -> ExceptT (Closure (Abs Type)) m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> ExceptT (Closure (Abs Type)) m Sort)
-> Sort -> ExceptT (Closure (Abs Type)) m Sort
forall a b. (a -> b) -> a -> b
$ Dom' Term Type -> Sort
forall a. LensSort a => a -> Sort
getSort Dom' Term Type
t
(Term
b,Term
bf) <- Names
-> NamesT (ExceptT (Closure (Abs Type)) m) (Term, Term)
-> ExceptT (Closure (Abs Type)) m (Term, Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT (ExceptT (Closure (Abs Type)) m) (Term, Term)
-> ExceptT (Closure (Abs Type)) m (Term, Term))
-> NamesT (ExceptT (Closure (Abs Type)) m) (Term, Term)
-> ExceptT (Closure (Abs Type)) m (Term, Term)
forall a b. (a -> b) -> a -> b
$ do
Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
l <- case Sort
s of
SSet Level' Term
_ -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
Sort
IntervalUniv -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
Sort
SizeUniv -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
Sort
LockUniv -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
Inf Univ
_ Integer
_ -> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. Maybe a
Nothing
Type Level' Term
l -> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a. a -> Maybe a
Just (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> Term
lam_i (Level' Term -> Term
Level Level' Term
l))
Sort
_ -> Abs Type
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
forall {t :: (* -> *) -> * -> *} {m :: * -> *} {a} {b}.
(MonadDebug (t m), PrettyTCM a, MonadTrans t,
MonadError (Closure (Abs a)) m, MonadTCEnv (t m),
ReadTCState (t m)) =>
Abs a -> t m b
noTranspError (String -> Type -> Abs Type
forall a. String -> a -> Abs a
Abs String
"i" (Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom Dom' Term Type
t))
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t <- Abs Type
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Type
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)))
-> Abs Type
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
forall a b. (a -> b) -> a -> b
$ String -> Type -> Abs Type
forall a. String -> a -> Abs a
Abs String
"i" (Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom Dom' Term Type
t)
[(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u <- [(Term, Term)]
-> ((Term, Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> NamesT
(ExceptT (Closure (Abs Type)) m)
[(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Term, Term)]
u (((Term, Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> NamesT
(ExceptT (Closure (Abs Type)) m)
[(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))])
-> ((Term, Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> NamesT
(ExceptT (Closure (Abs Type)) m)
[(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
forall a b. (a -> b) -> a -> b
$ \ (Term
psi,Term
upsi) -> do
(,) (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open Term
psi NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)))
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
forall a b.
NamesT (ExceptT (Closure (Abs Type)) m) (a -> b)
-> NamesT (ExceptT (Closure (Abs Type)) m) a
-> NamesT (ExceptT (Closure (Abs Type)) m) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Abs Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i" Term
upsi)
[NamesT (ExceptT (Closure (Abs Type)) m) Term
phi,NamesT (ExceptT (Closure (Abs Type)) m) Term
a] <- (Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> [Term]
-> NamesT
(ExceptT (Closure (Abs Type)) m)
[NamesT (ExceptT (Closure (Abs Type)) m) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term
-> NamesT
(ExceptT (Closure (Abs Type)) m)
(NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [Term
phi, Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a]
Term
b <- Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
gTransp Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
l NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u NamesT (ExceptT (Closure (Abs Type)) m) Term
phi NamesT (ExceptT (Closure (Abs Type)) m) Term
a
Abs Term
bf <- String
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i -> do
Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> [(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
gTransp (((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
l) ((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term))
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> Maybe (NamesT (ExceptT (Closure (Abs Type)) m) Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
l -> String
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"j" ((NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> (NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a b. (a -> b) -> a -> b
$ \ NamesT (ExceptT (Closure (Abs Type)) m) Term
j -> NamesT (ExceptT (Closure (Abs Type)) m) Term
l NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imin NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
j))
(String
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" (((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type))
-> ((forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
forall a b. (a -> b) -> a -> b
$ \ forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
j -> NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
t NamesT (ExceptT (Closure (Abs Type)) m) (Abs Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) (SubstArg Type)
-> NamesT (ExceptT (Closure (Abs Type)) m) Type
forall (m :: * -> *) a.
(Applicative m, Subst a) =>
m (Abs a) -> m (SubstArg a) -> m a
`bapp` (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imin NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
j))
[(NamesT (ExceptT (Closure (Abs Type)) m) Term,
NamesT (ExceptT (Closure (Abs Type)) m) (Abs Term))]
u
(Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
imax NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
ineg NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall {b}.
(Subst b, DeBruijn b) =>
NamesT (ExceptT (Closure (Abs Type)) m) b
i) NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
-> NamesT (ExceptT (Closure (Abs Type)) m) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (ExceptT (Closure (Abs Type)) m) Term
phi)
NamesT (ExceptT (Closure (Abs Type)) m) Term
a
(Term, Term)
-> NamesT (ExceptT (Closure (Abs Type)) m) (Term, Term)
forall a. a -> NamesT (ExceptT (Closure (Abs Type)) m) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term
b, Abs Term -> Term
forall a. Subst a => Abs a -> a
absBody Abs Term
bf)
(:) (Term
b Term -> Arg Term -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg Term
a) ([Arg Term] -> [Arg Term])
-> ExceptT (Closure (Abs Type)) m [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope
-> [[(Term, Term)]]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
go (Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp Abs Telescope
delta Term
SubstArg Telescope
bf) [[(Term, Term)]]
us Term
phi [Arg Term]
args
go Telescope
EmptyTel [[(Term, Term)]]
_ Term
_ [Arg Term]
_ = ExceptT (Closure (Abs Type)) m [Arg Term]
forall a. HasCallStack => a
__IMPOSSIBLE__
go (ExtendTel Dom' Term Type
t Abs Telescope
delta) [[(Term, Term)]]
_ Term
_ [Arg Term]
_ = ExceptT (Closure (Abs Type)) m [Arg Term]
forall a. HasCallStack => a
__IMPOSSIBLE__
let ([Term]
psis,[Abs [Term]]
uss) = [(Term, Abs [Term])] -> ([Term], [Abs [Term]])
forall a b. [(a, b)] -> ([a], [b])
unzip [(Term, Abs [Term])]
us
us' :: [[(Term, Term)]]
us' | [(Term, Abs [Term])] -> Bool
forall a. Null a => a -> Bool
null [(Term, Abs [Term])]
us = Nat -> [(Term, Term)] -> [[(Term, Term)]]
forall a. Nat -> a -> [a]
replicate ([Arg Term] -> Nat
forall a. [a] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [Arg Term]
args) []
| Bool
otherwise = ([Term] -> [(Term, Term)]) -> [[Term]] -> [[(Term, Term)]]
forall a b. (a -> b) -> [a] -> [b]
map ([Term] -> [Term] -> [(Term, Term)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
psis) ([[Term]] -> [[(Term, Term)]]) -> [[Term]] -> [[(Term, Term)]]
forall a b. (a -> b) -> a -> b
$ [[Term]] -> [[Term]]
forall a. [[a]] -> [[a]]
List.transpose ((Abs [Term] -> [Term]) -> [Abs [Term]] -> [[Term]]
forall a b. (a -> b) -> [a] -> [b]
map Abs [Term] -> [Term]
forall a. Subst a => Abs a -> a
absBody [Abs [Term]]
uss)
Telescope
-> [[(Term, Term)]]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
go (Abs Telescope -> Telescope
forall a. Subst a => Abs a -> a
absBody Abs Telescope
delta) [[(Term, Term)]]
us' Term
phi [Arg Term]
args
trFillTel :: Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) TCM Args
trFillTel :: Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
trFillTel = Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
trFillTel' Bool
False
trFillTel' :: (PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> Args
-> Term
-> ExceptT (Closure (Abs Type)) m Args
trFillTel' :: forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> Term
-> ExceptT (Closure (Abs Type)) m [Arg Term]
trFillTel' Bool
flag Abs Telescope
delta Term
phi [Arg Term]
args Term
r = do
Term
imin <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin
Term
imax <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax
Term
ineg <- m Term -> ExceptT (Closure (Abs Type)) m Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (Closure (Abs Type)) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpTel' Bool
flag (String -> Telescope -> Abs Telescope
forall a. String -> a -> Abs a
Abs String
"j" (Telescope -> Abs Telescope) -> Telescope -> Abs Telescope
forall a b. (a -> b) -> a -> b
$ Nat -> Abs Telescope -> Abs Telescope
forall a. Subst a => Nat -> a -> a
raise Nat
1 Abs Telescope
delta Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
`lazyAbsApp` (Term
imin Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` ((Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [Nat -> Term
var Nat
0, Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise Nat
1 Term
r])))
(Term
imax Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Term
ineg Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Term -> Arg Term
forall e. e -> Arg e
argN Term
r], Term -> Arg Term
forall e. e -> Arg e
argN Term
phi])
[Arg Term]
args
pathTelescope
:: forall m. (PureTCM m, MonadError TCErr m) =>
Telescope
-> [Arg Term]
-> [Arg Term]
-> m Telescope
pathTelescope :: forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
pathTelescope Telescope
tel [Arg Term]
lhs [Arg Term]
rhs = do
Either (Closure Type) Telescope
x <- ExceptT (Closure Type) m Telescope
-> m (Either (Closure Type) Telescope)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Telescope
-> [Arg Term] -> [Arg Term] -> ExceptT (Closure Type) m Telescope
forall (m :: * -> *).
(PureTCM m, MonadError (Closure Type) m) =>
Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
pathTelescope' Telescope
tel [Arg Term]
lhs [Arg Term]
rhs)
case Either (Closure Type) Telescope
x of
Left Closure Type
t -> do
Closure Type -> (Type -> m Telescope) -> m Telescope
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure Closure Type
t ((Type -> m Telescope) -> m Telescope)
-> (Type -> m Telescope) -> m Telescope
forall a b. (a -> b) -> a -> b
$ \ Type
t ->
TypeError -> m Telescope
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m Telescope)
-> (Doc -> TypeError) -> Doc -> m Telescope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> m Telescope) -> m Doc -> m Telescope
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
(String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"The sort of" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> m Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type
t m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"should be of the form \"Set l\"")
Right Telescope
tel -> Telescope -> m Telescope
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Telescope
tel
pathTelescope'
:: forall m. (PureTCM m, MonadError (Closure Type) m) =>
Telescope
-> [Arg Term]
-> [Arg Term]
-> m Telescope
pathTelescope' :: forall (m :: * -> *).
(PureTCM m, MonadError (Closure Type) m) =>
Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
pathTelescope' Telescope
tel [Arg Term]
lhs [Arg Term]
rhs = do
Term
pathp <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> m (Maybe Term) -> m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> BuiltinId -> m (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' BuiltinId
builtinPathP
Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
go Term
pathp (Nat -> Telescope -> Telescope
forall a. Subst a => Nat -> a -> a
raise Nat
1 Telescope
tel) [Arg Term]
lhs [Arg Term]
rhs
where
go :: Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
go :: Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
go Term
pathp (ExtendTel Dom' Term Type
a Abs Telescope
tel) (Arg Term
u : [Arg Term]
lhs) (Arg Term
v : [Arg Term]
rhs) = do
let t :: Type
t = Dom' Term Type -> Type
forall t e. Dom' t e -> e
unDom Dom' Term Type
a
Level' Term
l <- Nat -> SubstArg (Level' Term) -> Level' Term -> Level' Term
forall a. Subst a => Nat -> SubstArg a -> a -> a
subst Nat
0 Term
SubstArg (Level' Term)
HasCallStack => Term
__DUMMY_TERM__ (Level' Term -> Level' Term) -> m (Level' Term) -> m (Level' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> m (Level' Term)
getLevel Type
t
let a' :: Type
a' = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El (Level' Term -> Sort
forall t. Level' t -> Sort' t
Type Level' Term
l) (Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
apply Term
pathp ([Arg Term] -> Term) -> [Arg Term] -> Term
forall a b. (a -> b) -> a -> b
$ [Term -> Arg Term
forall e. e -> Arg e
argH (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Level' Term -> Term
Level Level' Term
l] [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++ (Term -> Arg Term) -> [Term] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> Arg Term
forall e. e -> Arg e
argN [ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
"i" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ Type -> Term
forall t a. Type'' t a -> a
unEl Type
t), Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
u, Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
v])
(Dom' Term Type -> Abs Telescope -> Telescope
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type
a' Type -> Dom' Term Type -> Dom' Term Type
forall a b. a -> Dom' Term b -> Dom' Term a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Dom' Term Type
a) (Abs Telescope -> Telescope) -> m (Abs Telescope) -> m Telescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>) (m (Abs Telescope) -> m Telescope)
-> (NamesT m (Abs Telescope) -> m (Abs Telescope))
-> NamesT m (Abs Telescope)
-> m Telescope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Names -> NamesT m (Abs Telescope) -> m (Abs Telescope)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT m (Abs Telescope) -> m Telescope)
-> NamesT m (Abs Telescope) -> m Telescope
forall a b. (a -> b) -> a -> b
$ do
let nm :: String
nm = (Abs Telescope -> String
forall a. Abs a -> String
absName Abs Telescope
tel)
NamesT m (Abs (Abs Telescope))
tel <- Abs (Abs Telescope) -> NamesT m (NamesT m (Abs (Abs Telescope)))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs (Abs Telescope) -> NamesT m (NamesT m (Abs (Abs Telescope))))
-> Abs (Abs Telescope) -> NamesT m (NamesT m (Abs (Abs Telescope)))
forall a b. (a -> b) -> a -> b
$ String -> Abs Telescope -> Abs (Abs Telescope)
forall a. String -> a -> Abs a
Abs String
"i" Abs Telescope
tel
[NamesT m Term
u,NamesT m Term
v] <- (Arg Term -> NamesT m (NamesT m Term))
-> [Arg Term] -> NamesT m [NamesT m Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> (Arg Term -> Term) -> Arg Term -> NamesT m (NamesT m Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg) [Arg Term
u,Arg Term
v]
[NamesT m [Arg Term]
lhs,NamesT m [Arg Term]
rhs] <- ([Arg Term] -> NamesT m (NamesT m [Arg Term]))
-> [[Arg Term]] -> NamesT m [NamesT m [Arg Term]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM [Arg Term] -> NamesT m (NamesT m [Arg Term])
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open [[Arg Term]
lhs,[Arg Term]
rhs]
String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
-> NamesT m Telescope)
-> NamesT m (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
nm (((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
-> NamesT m Telescope)
-> NamesT m (Abs Telescope))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
-> NamesT m Telescope)
-> NamesT m (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT m b
eq -> do
[Arg Term]
lhs <- NamesT m [Arg Term]
lhs
[Arg Term]
rhs <- NamesT m [Arg Term]
rhs
Abs Telescope
tel' <- String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
-> NamesT m Telescope)
-> NamesT m (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
-> NamesT m Telescope)
-> NamesT m (Abs Telescope))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
-> NamesT m Telescope)
-> NamesT m (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT m b
i ->
Abs Telescope -> Term -> Telescope
Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs Telescope -> Term -> Telescope)
-> NamesT m (Abs Telescope) -> NamesT m (Term -> Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Abs (Abs Telescope) -> Term -> Abs Telescope
Abs (Abs Telescope) -> SubstArg (Abs Telescope) -> Abs Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs (Abs Telescope) -> Term -> Abs Telescope)
-> NamesT m (Abs (Abs Telescope))
-> NamesT m (Term -> Abs Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT m (Abs (Abs Telescope))
tel NamesT m (Term -> Abs Telescope)
-> NamesT m Term -> NamesT m (Abs Telescope)
forall a b. NamesT m (a -> b) -> NamesT m a -> NamesT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT m Term
forall {b}. (Subst b, DeBruijn b) => NamesT m b
i) NamesT m (Term -> Telescope) -> NamesT m Term -> NamesT m Telescope
forall a b. NamesT m (a -> b) -> NamesT m a -> NamesT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (NamesT m Term
forall {b}. (Subst b, DeBruijn b) => NamesT m b
eq NamesT m Term
-> (NamesT m Term, NamesT m Term, NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
Applicative m =>
m Term -> (m Term, m Term, m Term) -> m Term
<@@> (NamesT m Term
u, NamesT m Term
v, NamesT m Term
forall {b}. (Subst b, DeBruijn b) => NamesT m b
i))
m Telescope -> NamesT m Telescope
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m Telescope -> NamesT m Telescope)
-> m Telescope -> NamesT m Telescope
forall a b. (a -> b) -> a -> b
$ Term -> Telescope -> [Arg Term] -> [Arg Term] -> m Telescope
go Term
pathp (Abs Telescope -> Telescope
forall a. Subst a => Abs a -> a
absBody Abs Telescope
tel') [Arg Term]
lhs [Arg Term]
rhs
go Term
_ Telescope
EmptyTel [] [] = Telescope -> m Telescope
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Telescope
forall a. Tele a
EmptyTel
go Term
_ Telescope
_ [Arg Term]
_ [Arg Term]
_ = m Telescope
forall a. HasCallStack => a
__IMPOSSIBLE__
getLevel :: Type -> m Level
getLevel :: Type -> m (Level' Term)
getLevel Type
t = do
Sort
s <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort Type
t
case Sort
s of
Type Level' Term
l -> Level' Term -> m (Level' Term)
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Level' Term
l
Sort
s -> Closure Type -> m (Level' Term)
forall a. Closure Type -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (Closure Type -> m (Level' Term))
-> m (Closure Type) -> m (Level' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> m (Closure Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Type
t
data TranspError = CannotTransp {TranspError -> Closure (Abs Type)
errorType :: (Closure (Abs Type)) }
instance Exception TranspError
instance Show TranspError where
show :: TranspError -> String
show TranspError
_ = String
"TranspError"
tryTranspError :: TCM a -> TCM (Either (Closure (Abs Type)) a)
tryTranspError :: forall a. TCM a -> TCM (Either (Closure (Abs Type)) a)
tryTranspError (TCM IORef TCState -> TCEnv -> IO a
m) = (IORef TCState -> TCEnv -> IO (Either (Closure (Abs Type)) a))
-> TCMT IO (Either (Closure (Abs Type)) a)
forall (m :: * -> *) a. (IORef TCState -> TCEnv -> m a) -> TCMT m a
TCM ((IORef TCState -> TCEnv -> IO (Either (Closure (Abs Type)) a))
-> TCMT IO (Either (Closure (Abs Type)) a))
-> (IORef TCState -> TCEnv -> IO (Either (Closure (Abs Type)) a))
-> TCMT IO (Either (Closure (Abs Type)) a)
forall a b. (a -> b) -> a -> b
$ \ IORef TCState
s TCEnv
env -> do
(TranspError -> Closure (Abs Type))
-> Either TranspError a -> Either (Closure (Abs Type)) a
forall a c b. (a -> c) -> Either a b -> Either c b
mapLeft TranspError -> Closure (Abs Type)
errorType (Either TranspError a -> Either (Closure (Abs Type)) a)
-> IO (Either TranspError a) -> IO (Either (Closure (Abs Type)) a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (IO a -> IO (Either TranspError a)
forall e a. Exception e => IO a -> IO (Either e a)
try (IORef TCState -> TCEnv -> IO a
m IORef TCState
s TCEnv
env))
transpPathPTel' ::
NamesT TCM (Abs (Abs Telescope))
-> [NamesT TCM Term]
-> [NamesT TCM Term]
-> NamesT TCM Term
-> [NamesT TCM Term]
-> NamesT TCM [Arg Term]
transpPathPTel' :: NamesT (TCMT IO) (Abs (Abs Telescope))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathPTel' NamesT (TCMT IO) (Abs (Abs Telescope))
theTel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
y NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p = do
let neg :: NamesT m Term -> NamesT m Term
neg NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
NamesT (TCMT IO) [Arg Term]
qs <- ([Arg Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Arg Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term]))
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term]))
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall a b. (a -> b) -> a -> b
$ (Abs [Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Abs (Arg Term) -> Arg Term) -> [Abs (Arg Term)] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Abs String
n (Arg ArgInfo
i Term
t)) -> ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
n Term
t)) ([Abs (Arg Term)] -> [Arg Term])
-> (Abs [Arg Term] -> [Abs (Arg Term)])
-> Abs [Arg Term]
-> [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs [Arg Term] -> [Abs (Arg Term)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Abs (f a) -> f (Abs a)
sequenceA)
(NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> do
Abs Telescope
theTel <- Abs (Abs Telescope) -> Term -> Abs Telescope
Abs (Abs Telescope) -> SubstArg (Abs Telescope) -> Abs Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Abs Telescope) -> Term -> Abs Telescope)
-> NamesT (TCMT IO) (Abs (Abs Telescope))
-> NamesT (TCMT IO) (Term -> Abs Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Abs Telescope))
theTel NamesT (TCMT IO) (Term -> Abs Telescope)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Abs Telescope)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j
[Term]
faces <- [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence [NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j, NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j]
[Abs [Term]]
us <- [[NamesT (TCMT IO) Term]]
-> ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[NamesT (TCMT IO) Term]
x,[NamesT (TCMT IO) Term]
y] (([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]])
-> ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]]
forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term]
z -> do
String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
z (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i)
let sys :: [(Term, Abs [Term])]
sys = [Term] -> [Abs [Term]] -> [(Term, Abs [Term])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
faces [Abs [Term]]
us
Term
phi <- NamesT (TCMT IO) Term
phi
[Term]
p0 <- (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j) [NamesT (TCMT IO) Term]
p
let toArgs :: [Term] -> [Arg Term]
toArgs = (Arg String -> Term -> Arg Term)
-> [Arg String] -> [Term] -> [Arg Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Arg String
a Term
t -> Term
t Term -> Arg String -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg String
a) (Telescope -> [Arg String]
teleArgNames (Abs Telescope -> Telescope
forall a. Abs a -> a
unAbs (Abs Telescope -> Telescope) -> Abs Telescope -> Telescope
forall a b. (a -> b) -> a -> b
$ Abs Telescope
theTel))
Either (Closure (Abs Type)) [Arg Term]
eq <- TCM (Either (Closure (Abs Type)) [Arg Term])
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM (Either (Closure (Abs Type)) [Arg Term])
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term]))
-> (ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> TCM (Either (Closure (Abs Type)) [Arg Term]))
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> TCM (Either (Closure (Abs Type)) [Arg Term])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term]))
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall a b. (a -> b) -> a -> b
$ Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpSysTel' Bool
False Abs Telescope
theTel [(Term, Abs [Term])]
sys Term
phi ([Term] -> [Arg Term]
toArgs [Term]
p0)
(Closure (Abs Type) -> NamesT (TCMT IO) [Arg Term])
-> ([Arg Term] -> NamesT (TCMT IO) [Arg Term])
-> Either (Closure (Abs Type)) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TCM [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM [Arg Term] -> NamesT (TCMT IO) [Arg Term])
-> (Closure (Abs Type) -> TCM [Arg Term])
-> Closure (Abs Type)
-> NamesT (TCMT IO) [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [Arg Term] -> TCM [Arg Term]
forall (m :: * -> *) a. Monad m => m a -> TCMT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [Arg Term] -> TCM [Arg Term])
-> (Closure (Abs Type) -> IO [Arg Term])
-> Closure (Abs Type)
-> TCM [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranspError -> IO [Arg Term]
forall a e. Exception e => e -> a
throw (TranspError -> IO [Arg Term])
-> (Closure (Abs Type) -> TranspError)
-> Closure (Abs Type)
-> IO [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Abs Type) -> TranspError
CannotTransp) [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either (Closure (Abs Type)) [Arg Term]
eq
NamesT (TCMT IO) [Arg Term]
qs
transpPathTel' ::
NamesT TCM (Abs Telescope)
-> [NamesT TCM Term]
-> [NamesT TCM Term]
-> NamesT TCM Term
-> [NamesT TCM Term]
-> NamesT TCM [Arg Term]
transpPathTel' :: NamesT (TCMT IO) (Abs Telescope)
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathTel' NamesT (TCMT IO) (Abs Telescope)
theTel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
y NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p = do
let neg :: NamesT m Term -> NamesT m Term
neg NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
NamesT (TCMT IO) [Arg Term]
qs <- ([Arg Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Arg Term] -> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term]))
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term]))
-> NamesT (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (NamesT (TCMT IO) [Arg Term])
forall a b. (a -> b) -> a -> b
$ (Abs [Arg Term] -> [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Abs (Arg Term) -> Arg Term) -> [Abs (Arg Term)] -> [Arg Term]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (\ (Abs String
n (Arg ArgInfo
i Term
t)) -> ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
i (ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term) -> Abs Term -> Term
forall a b. (a -> b) -> a -> b
$ String -> Term -> Abs Term
forall a. String -> a -> Abs a
Abs String
n Term
t)) ([Abs (Arg Term)] -> [Arg Term])
-> (Abs [Arg Term] -> [Abs (Arg Term)])
-> Abs [Arg Term]
-> [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Abs [Arg Term] -> [Abs (Arg Term)]
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a. Applicative f => Abs (f a) -> f (Abs a)
sequenceA)
(NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]) -> NamesT (TCMT IO) [Arg Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Arg Term])
-> NamesT (TCMT IO) (Abs [Arg Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> do
Abs Telescope
theTel <- NamesT (TCMT IO) (Abs Telescope)
theTel
[Term]
faces <- [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a.
(Traversable t, Monad m) =>
t (m a) -> m (t a)
forall (m :: * -> *) a. Monad m => [m a] -> m [a]
sequence ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term])
-> [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ [NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j, NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j]
[Abs [Term]]
us <- [[NamesT (TCMT IO) Term]]
-> ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [[NamesT (TCMT IO) Term]
x,[NamesT (TCMT IO) Term]
y] (([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]])
-> ([NamesT (TCMT IO) Term] -> NamesT (TCMT IO) (Abs [Term]))
-> NamesT (TCMT IO) [Abs [Term]]
forall a b. (a -> b) -> a -> b
$ \ [NamesT (TCMT IO) Term]
z -> do
String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
z (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i)
let sys :: [(Term, Abs [Term])]
sys = [Term] -> [Abs [Term]] -> [(Term, Abs [Term])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Term]
faces [Abs [Term]]
us
Term
phi <- NamesT (TCMT IO) Term
phi
[Term]
p0 <- (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> [NamesT (TCMT IO) Term] -> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j) [NamesT (TCMT IO) Term]
p
let toArgs :: [Term] -> [Arg Term]
toArgs = (Arg String -> Term -> Arg Term)
-> [Arg String] -> [Term] -> [Arg Term]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (\ Arg String
a Term
t -> Term
t Term -> Arg String -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg String
a) (Telescope -> [Arg String]
teleArgNames (Abs Telescope -> Telescope
forall a. Abs a -> a
unAbs Abs Telescope
theTel))
Either (Closure (Abs Type)) [Arg Term]
eq <- TCM (Either (Closure (Abs Type)) [Arg Term])
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM (Either (Closure (Abs Type)) [Arg Term])
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term]))
-> (ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> TCM (Either (Closure (Abs Type)) [Arg Term]))
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> TCM (Either (Closure (Abs Type)) [Arg Term])
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term]))
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
-> NamesT (TCMT IO) (Either (Closure (Abs Type)) [Arg Term])
forall a b. (a -> b) -> a -> b
$ Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) (TCMT IO) [Arg Term]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m) =>
Bool
-> Abs Telescope
-> [(Term, Abs [Term])]
-> Term
-> [Arg Term]
-> ExceptT (Closure (Abs Type)) m [Arg Term]
transpSysTel' Bool
False Abs Telescope
theTel [(Term, Abs [Term])]
sys Term
phi ([Term] -> [Arg Term]
toArgs [Term]
p0)
(Closure (Abs Type) -> NamesT (TCMT IO) [Arg Term])
-> ([Arg Term] -> NamesT (TCMT IO) [Arg Term])
-> Either (Closure (Abs Type)) [Arg Term]
-> NamesT (TCMT IO) [Arg Term]
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either (TCM [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM [Arg Term] -> NamesT (TCMT IO) [Arg Term])
-> (Closure (Abs Type) -> TCM [Arg Term])
-> Closure (Abs Type)
-> NamesT (TCMT IO) [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. IO [Arg Term] -> TCM [Arg Term]
forall (m :: * -> *) a. Monad m => m a -> TCMT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (IO [Arg Term] -> TCM [Arg Term])
-> (Closure (Abs Type) -> IO [Arg Term])
-> Closure (Abs Type)
-> TCM [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TranspError -> IO [Arg Term]
forall a e. Exception e => e -> a
throw (TranspError -> IO [Arg Term])
-> (Closure (Abs Type) -> TranspError)
-> Closure (Abs Type)
-> IO [Arg Term]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Abs Type) -> TranspError
CannotTransp) [Arg Term] -> NamesT (TCMT IO) [Arg Term]
forall a. a -> NamesT (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Either (Closure (Abs Type)) [Arg Term]
eq
NamesT (TCMT IO) [Arg Term]
qs
trFillPathTel' ::
NamesT TCM (Abs Telescope)
-> [NamesT TCM Term]
-> [NamesT TCM Term]
-> NamesT TCM Term
-> [NamesT TCM Term]
-> NamesT TCM Term
-> NamesT TCM [Arg Term]
trFillPathTel' :: NamesT (TCMT IO) (Abs Telescope)
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) [Arg Term]
trFillPathTel' NamesT (TCMT IO) (Abs Telescope)
tel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
y NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p NamesT (TCMT IO) Term
r = do
let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
let min :: NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
let neg :: NamesT m Term -> NamesT m Term
neg NamesT m Term
i = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i
[NamesT (TCMT IO) Term]
x' <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
x (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i))
[NamesT (TCMT IO) Term]
y' <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
y (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i))
NamesT (TCMT IO) (Abs Telescope)
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathTel' (String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> Abs Telescope -> Term -> Telescope
Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Telescope -> Term -> Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
-> NamesT (TCMT IO) (Term -> Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs Telescope)
tel NamesT (TCMT IO) (Term -> Telescope)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Telescope
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i)
[NamesT (TCMT IO) Term]
x'
[NamesT (TCMT IO) Term]
y'
(NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT (TCMT IO) Term
phi (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg NamesT (TCMT IO) Term
r))
[NamesT (TCMT IO) Term]
p
trFillPathPTel' ::
NamesT TCM (Abs (Abs Telescope))
-> [NamesT TCM Term]
-> [NamesT TCM Term]
-> NamesT TCM Term
-> [NamesT TCM Term]
-> NamesT TCM Term
-> NamesT TCM [Arg Term]
trFillPathPTel' :: NamesT (TCMT IO) (Abs (Abs Telescope))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) [Arg Term]
trFillPathPTel' NamesT (TCMT IO) (Abs (Abs Telescope))
tel [NamesT (TCMT IO) Term]
x [NamesT (TCMT IO) Term]
y NamesT (TCMT IO) Term
phi [NamesT (TCMT IO) Term]
p NamesT (TCMT IO) Term
r = do
let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
let min :: NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
let neg :: NamesT m Term -> NamesT m Term
neg NamesT m Term
i = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i
[NamesT (TCMT IO) Term]
x' <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
x (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i))
[NamesT (TCMT IO) Term]
y' <- ((Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> [Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open ([Term] -> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term])
-> NamesT (TCMT IO) [Term]
-> NamesT (TCMT IO) [NamesT (TCMT IO) Term]
forall a b. (a -> b) -> a -> b
$ NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall (m :: * -> *).
Monad m =>
NamesT m (Abs [Term]) -> NamesT m [Term]
lamTel (NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]) -> NamesT (TCMT IO) [Term]
forall a b. (a -> b) -> a -> b
$ String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term]))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) [Term])
-> NamesT (TCMT IO) (Abs [Term])
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> [NamesT (TCMT IO) Term]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [NamesT (TCMT IO) Term]
y (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i))
NamesT (TCMT IO) (Abs (Abs Telescope))
-> [NamesT (TCMT IO) Term]
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) Term
-> [NamesT (TCMT IO) Term]
-> NamesT (TCMT IO) [Arg Term]
transpPathPTel' (String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) (Abs Telescope))
-> NamesT (TCMT IO) (Abs (Abs Telescope))
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"j" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) (Abs Telescope))
-> NamesT (TCMT IO) (Abs (Abs Telescope)))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) (Abs Telescope))
-> NamesT (TCMT IO) (Abs (Abs Telescope))
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j -> String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b)
-> NamesT (TCMT IO) Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i -> Abs Telescope -> Term -> Telescope
Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Telescope -> Term -> Telescope)
-> NamesT (TCMT IO) (Abs Telescope)
-> NamesT (TCMT IO) (Term -> Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Abs (Abs Telescope) -> Term -> Abs Telescope
Abs (Abs Telescope) -> SubstArg (Abs Telescope) -> Abs Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs (Abs Telescope) -> Term -> Abs Telescope)
-> NamesT (TCMT IO) (Abs (Abs Telescope))
-> NamesT (TCMT IO) (Term -> Abs Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT (TCMT IO) (Abs (Abs Telescope))
tel NamesT (TCMT IO) (Term -> Abs Telescope)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) (Abs Telescope)
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
j) NamesT (TCMT IO) (Term -> Telescope)
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Telescope
forall a b.
NamesT (TCMT IO) (a -> b)
-> NamesT (TCMT IO) a -> NamesT (TCMT IO) b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
min NamesT (TCMT IO) Term
r NamesT (TCMT IO) Term
forall {b}. (Subst b, DeBruijn b) => NamesT (TCMT IO) b
i)
[NamesT (TCMT IO) Term]
x'
[NamesT (TCMT IO) Term]
y'
(NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT (TCMT IO) Term
phi (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term
neg NamesT (TCMT IO) Term
r))
[NamesT (TCMT IO) Term]
p
expTelescope :: Type -> Telescope -> Telescope
expTelescope :: Type -> Telescope -> Telescope
expTelescope Type
int Telescope
tel = Names -> [Dom' Term Type] -> Telescope
unflattenTel Names
names [Dom' Term Type]
ys
where
stel :: Nat
stel = Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel
xs :: [Dom' Term Type]
xs = Telescope -> [Dom' Term Type]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel Telescope
tel
names :: Names
names = Telescope -> Names
teleNames Telescope
tel
t :: Telescope
t = Dom' Term Type -> Abs Telescope -> Telescope
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Type -> Dom' Term Type
forall a. a -> Dom a
defaultDom (Type -> Dom' Term Type) -> Type -> Dom' Term Type
forall a b. (a -> b) -> a -> b
$ Nat -> Type -> Type
forall a. Subst a => Nat -> a -> a
raise Nat
stel Type
int) (String -> Telescope -> Abs Telescope
forall a. String -> a -> Abs a
Abs String
"i" Telescope
forall a. Tele a
EmptyTel)
s :: Substitution' Term
s = Nat -> Substitution' Term
expS Nat
stel
ys :: [Dom' Term Type]
ys = (Dom' Term Type -> Dom' Term Type)
-> [Dom' Term Type] -> [Dom' Term Type]
forall a b. (a -> b) -> [a] -> [b]
map ((Type -> Type) -> Dom' Term Type -> Dom' Term Type
forall a b. (a -> b) -> Dom' Term a -> Dom' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Telescope -> Type -> Type
forall t. Abstract t => Telescope -> t -> t
abstract Telescope
t) (Dom' Term Type -> Dom' Term Type)
-> (Dom' Term Type -> Dom' Term Type)
-> Dom' Term Type
-> Dom' Term Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution' (SubstArg (Dom' Term Type))
-> Dom' Term Type -> Dom' Term Type
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' Term
Substitution' (SubstArg (Dom' Term Type))
s) [Dom' Term Type]
xs
expS :: Nat -> Substitution
expS :: Nat -> Substitution' Term
expS Nat
stel = Impossible
-> [Maybe Term] -> Substitution' Term -> Substitution' Term
forall a.
DeBruijn a =>
Impossible -> [Maybe a] -> Substitution' a -> Substitution' a
prependS Impossible
forall a. HasCallStack => a
__IMPOSSIBLE__
[ Term -> Maybe Term
forall a. a -> Maybe a
Just (Nat -> Term
var Nat
n Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Nat -> Term
var Nat
0]) | Nat
n <- [Nat
1..Nat
stel] ]
(Nat -> Substitution' Term
forall a. Nat -> Substitution' a
raiseS (Nat
stel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
1))
data LType = LEl Level Term deriving (LType -> LType -> Bool
(LType -> LType -> Bool) -> (LType -> LType -> Bool) -> Eq LType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: LType -> LType -> Bool
== :: LType -> LType -> Bool
$c/= :: LType -> LType -> Bool
/= :: LType -> LType -> Bool
Eq,Nat -> LType -> String -> String
[LType] -> String -> String
LType -> String
(Nat -> LType -> String -> String)
-> (LType -> String) -> ([LType] -> String -> String) -> Show LType
forall a.
(Nat -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Nat -> LType -> String -> String
showsPrec :: Nat -> LType -> String -> String
$cshow :: LType -> String
show :: LType -> String
$cshowList :: [LType] -> String -> String
showList :: [LType] -> String -> String
Show)
fromLType :: LType -> Type
fromLType :: LType -> Type
fromLType (LEl Level' Term
l Term
t) = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El (Level' Term -> Sort
forall t. Level' t -> Sort' t
Type Level' Term
l) Term
t
lTypeLevel :: LType -> Level
lTypeLevel :: LType -> Level' Term
lTypeLevel (LEl Level' Term
l Term
t) = Level' Term
l
toLType :: MonadReduce m => Type -> m (Maybe LType)
toLType :: forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType Type
ty = do
Sort
sort <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort Type
ty
case Sort
sort of
Type Level' Term
l -> Maybe LType -> m (Maybe LType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LType -> m (Maybe LType)) -> Maybe LType -> m (Maybe LType)
forall a b. (a -> b) -> a -> b
$ LType -> Maybe LType
forall a. a -> Maybe a
Just (LType -> Maybe LType) -> LType -> Maybe LType
forall a b. (a -> b) -> a -> b
$ Level' Term -> Term -> LType
LEl Level' Term
l (Type -> Term
forall t a. Type'' t a -> a
unEl Type
ty)
Sort
_ -> Maybe LType -> m (Maybe LType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe LType -> m (Maybe LType)) -> Maybe LType -> m (Maybe LType)
forall a b. (a -> b) -> a -> b
$ Maybe LType
forall a. Maybe a
Nothing
instance Subst LType where
type SubstArg LType = Term
applySubst :: Substitution' (SubstArg LType) -> LType -> LType
applySubst Substitution' (SubstArg LType)
rho (LEl Level' Term
l Term
t) = Level' Term -> Term -> LType
LEl (Substitution' (SubstArg (Level' Term))
-> Level' Term -> Level' Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg (Level' Term))
Substitution' (SubstArg LType)
rho Level' Term
l) (Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg Term)
Substitution' (SubstArg LType)
rho Term
t)
data CType = ClosedType Sort QName | LType LType deriving (CType -> CType -> Bool
(CType -> CType -> Bool) -> (CType -> CType -> Bool) -> Eq CType
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: CType -> CType -> Bool
== :: CType -> CType -> Bool
$c/= :: CType -> CType -> Bool
/= :: CType -> CType -> Bool
Eq,Nat -> CType -> String -> String
[CType] -> String -> String
CType -> String
(Nat -> CType -> String -> String)
-> (CType -> String) -> ([CType] -> String -> String) -> Show CType
forall a.
(Nat -> a -> String -> String)
-> (a -> String) -> ([a] -> String -> String) -> Show a
$cshowsPrec :: Nat -> CType -> String -> String
showsPrec :: Nat -> CType -> String -> String
$cshow :: CType -> String
show :: CType -> String
$cshowList :: [CType] -> String -> String
showList :: [CType] -> String -> String
Show)
instance P.Pretty CType where
pretty :: CType -> Doc
pretty = Type -> Doc
forall a. Pretty a => a -> Doc
P.pretty (Type -> Doc) -> (CType -> Type) -> CType -> Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CType -> Type
fromCType
fromCType :: CType -> Type
fromCType :: CType -> Type
fromCType (ClosedType Sort
s QName
q) = Sort -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El Sort
s (QName -> [Elim] -> Term
Def QName
q [])
fromCType (LType LType
t) = LType -> Type
fromLType LType
t
toCType :: MonadReduce m => Type -> m (Maybe CType)
toCType :: forall (m :: * -> *). MonadReduce m => Type -> m (Maybe CType)
toCType Type
ty = do
Sort
sort <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort Type
ty
case Sort
sort of
Type Level' Term
l -> Maybe CType -> m (Maybe CType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CType -> m (Maybe CType)) -> Maybe CType -> m (Maybe CType)
forall a b. (a -> b) -> a -> b
$ CType -> Maybe CType
forall a. a -> Maybe a
Just (CType -> Maybe CType) -> CType -> Maybe CType
forall a b. (a -> b) -> a -> b
$ LType -> CType
LType (Level' Term -> Term -> LType
LEl Level' Term
l (Type -> Term
forall t a. Type'' t a -> a
unEl Type
ty))
SSet{} -> do
Term
t <- Term -> m Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Type -> Term
forall t a. Type'' t a -> a
unEl Type
ty)
case Term
t of
Def QName
q [] -> Maybe CType -> m (Maybe CType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CType -> m (Maybe CType)) -> Maybe CType -> m (Maybe CType)
forall a b. (a -> b) -> a -> b
$ CType -> Maybe CType
forall a. a -> Maybe a
Just (CType -> Maybe CType) -> CType -> Maybe CType
forall a b. (a -> b) -> a -> b
$ Sort -> QName -> CType
ClosedType Sort
sort QName
q
Term
_ -> Maybe CType -> m (Maybe CType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CType -> m (Maybe CType)) -> Maybe CType -> m (Maybe CType)
forall a b. (a -> b) -> a -> b
$ Maybe CType
forall a. Maybe a
Nothing
Sort
_ -> Maybe CType -> m (Maybe CType)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe CType -> m (Maybe CType)) -> Maybe CType -> m (Maybe CType)
forall a b. (a -> b) -> a -> b
$ Maybe CType
forall a. Maybe a
Nothing
instance Subst CType where
type SubstArg CType = Term
applySubst :: Substitution' (SubstArg CType) -> CType -> CType
applySubst Substitution' (SubstArg CType)
rho (ClosedType Sort
s QName
q) = Sort -> QName -> CType
ClosedType (Substitution' (SubstArg Sort) -> Sort -> Sort
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg Sort)
Substitution' (SubstArg CType)
rho Sort
s) QName
q
applySubst Substitution' (SubstArg CType)
rho (LType LType
t) = LType -> CType
LType (LType -> CType) -> LType -> CType
forall a b. (a -> b) -> a -> b
$ Substitution' (SubstArg LType) -> LType -> LType
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg CType)
Substitution' (SubstArg LType)
rho LType
t
hcomp
:: (HasBuiltins m, MonadError TCErr m, MonadReduce m, MonadPretty m)
=> NamesT m Type
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
hcomp :: forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m,
MonadPretty m) =>
NamesT m Type
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
hcomp NamesT m Type
ty [(NamesT m Term, NamesT m Term)]
sys NamesT m Term
u0 = do
Term
iz <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
Term
tHComp <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primHComp
let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
Type
ty <- NamesT m Type
ty
(Level' Term
l, Term
ty) <- Type -> NamesT m (Maybe LType)
forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType Type
ty NamesT m (Maybe LType)
-> (Maybe LType -> NamesT m (Level' Term, Term))
-> NamesT m (Level' Term, Term)
forall a b. NamesT m a -> (a -> NamesT m b) -> NamesT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (LEl Level' Term
l Term
ty) -> (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall a. a -> NamesT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level' Term
l, Term
ty)
Maybe LType
Nothing -> m (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (m (Level' Term, Term) -> NamesT m (Level' Term, Term))
-> m (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall a b. (a -> b) -> a -> b
$ do
TypeError -> m (Level' Term, Term)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m (Level' Term, Term))
-> (Doc -> TypeError) -> Doc -> m (Level' Term, Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> m (Level' Term, Term)) -> m Doc -> m (Level' Term, Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [m Doc] -> m Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ String -> m Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"Cubical Agda: cannot generate hcomp clauses at type", Type -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
ty ]
NamesT m Term
l <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ Level' Term -> Term
Level Level' Term
l
NamesT m Term
ty <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ Term
ty
Term
face <- ((NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m Term -> [NamesT m Term] -> NamesT m Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NamesT m Term -> NamesT m Term -> NamesT m Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max (Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) ([NamesT m Term] -> NamesT m Term)
-> [NamesT m Term] -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ ((NamesT m Term, NamesT m Term) -> NamesT m Term)
-> [(NamesT m Term, NamesT m Term)] -> [NamesT m Term]
forall a b. (a -> b) -> [a] -> [b]
map (NamesT m Term, NamesT m Term) -> NamesT m Term
forall a b. (a, b) -> a
fst ([(NamesT m Term, NamesT m Term)] -> [NamesT m Term])
-> [(NamesT m Term, NamesT m Term)] -> [NamesT m Term]
forall a b. (a -> b) -> a -> b
$ [(NamesT m Term, NamesT m Term)]
sys)
Term
sys <- String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i'" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
forall (m :: * -> *).
HasBuiltins m =>
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
combineSys NamesT m Term
l NamesT m Term
ty [(NamesT m Term
phi, NamesT m Term
u NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i) | (NamesT m Term
phi,NamesT m Term
u) <- [(NamesT m Term, NamesT m Term)]
sys]
Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
l NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
ty NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
face NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
sys NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u0
transpSys :: (HasBuiltins m, MonadError TCErr m, MonadReduce m) =>
NamesT m (Abs Type)
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpSys :: forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadReduce m) =>
NamesT m (Abs Type)
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
-> NamesT m Term
-> NamesT m Term
transpSys NamesT m (Abs Type)
ty [(NamesT m Term, NamesT m Term)]
sys NamesT m Term
phi NamesT m Term
u = do
let max :: NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
i NamesT m Term
j = m Term -> NamesT m Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMax NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
j
Term
iz <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
Term
tTransp <- NamesT m Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primTrans
Term
tComp <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> NamesT m (Maybe Term) -> NamesT m Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrimitiveId -> NamesT m (Maybe Term)
forall (m :: * -> *) a.
(HasBuiltins m, IsBuiltin a) =>
a -> m (Maybe Term)
getTerm' PrimitiveId
builtinComp
Abs (Level' Term, Term)
l_ty <- String
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
-> NamesT m (Level' Term, Term))
-> NamesT m (Abs (Level' Term, Term))
forall (m :: * -> *) a.
MonadFail m =>
String
-> ((forall b. (Subst b, DeBruijn b) => NamesT m b) -> NamesT m a)
-> NamesT m (Abs a)
bind String
"i" (((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
-> NamesT m (Level' Term, Term))
-> NamesT m (Abs (Level' Term, Term)))
-> ((forall {b}. (Subst b, DeBruijn b) => NamesT m b)
-> NamesT m (Level' Term, Term))
-> NamesT m (Abs (Level' Term, Term))
forall a b. (a -> b) -> a -> b
$ \ forall {b}. (Subst b, DeBruijn b) => NamesT m b
i -> do
Type
ty <- Abs Type -> Term -> Type
Abs Type -> SubstArg Type -> Type
forall a. Subst a => Abs a -> SubstArg a -> a
absApp (Abs Type -> Term -> Type)
-> NamesT m (Abs Type) -> NamesT m (Term -> Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT m (Abs Type)
ty NamesT m (Term -> Type) -> NamesT m Term -> NamesT m Type
forall a b. NamesT m (a -> b) -> NamesT m a -> NamesT m b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> NamesT m Term
forall {b}. (Subst b, DeBruijn b) => NamesT m b
i
Type -> NamesT m (Maybe LType)
forall (m :: * -> *). MonadReduce m => Type -> m (Maybe LType)
toLType Type
ty NamesT m (Maybe LType)
-> (Maybe LType -> NamesT m (Level' Term, Term))
-> NamesT m (Level' Term, Term)
forall a b. NamesT m a -> (a -> NamesT m b) -> NamesT m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Just (LEl Level' Term
l Term
ty) -> (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall a. a -> NamesT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level' Term
l,Term
ty)
Maybe LType
Nothing -> (Level' Term, Term) -> NamesT m (Level' Term, Term)
forall a. a -> NamesT m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Level' Term
HasCallStack => Level' Term
__DUMMY_LEVEL__, Type -> Term
forall t a. Type'' t a -> a
unEl Type
ty)
NamesT m Term
l <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term)
-> (Abs (Level' Term, Term) -> Abs Term)
-> Abs (Level' Term, Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Level' Term, Term) -> Term)
-> Abs (Level' Term, Term) -> Abs Term
forall a b. (a -> b) -> Abs a -> Abs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Level' Term -> Term
Level (Level' Term -> Term)
-> ((Level' Term, Term) -> Level' Term)
-> (Level' Term, Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Level' Term, Term) -> Level' Term
forall a b. (a, b) -> a
fst) (Abs (Level' Term, Term) -> Term)
-> Abs (Level' Term, Term) -> Term
forall a b. (a -> b) -> a -> b
$ Abs (Level' Term, Term)
l_ty
NamesT m Term
ty <- Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo (Abs Term -> Term)
-> (Abs (Level' Term, Term) -> Abs Term)
-> Abs (Level' Term, Term)
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((Level' Term, Term) -> Term)
-> Abs (Level' Term, Term) -> Abs Term
forall a b. (a -> b) -> Abs a -> Abs b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Level' Term, Term) -> Term
forall a b. (a, b) -> b
snd (Abs (Level' Term, Term) -> Term)
-> Abs (Level' Term, Term) -> Term
forall a b. (a -> b) -> a -> b
$ Abs (Level' Term, Term)
l_ty
if [(NamesT m Term, NamesT m Term)] -> Bool
forall a. Null a => a -> Bool
null [(NamesT m Term, NamesT m Term)]
sys then Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTransp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
l NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
ty NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
phi NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u else do
let face :: NamesT m Term
face = NamesT m Term -> NamesT m Term -> NamesT m Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max NamesT m Term
phi ((NamesT m Term -> NamesT m Term -> NamesT m Term)
-> NamesT m Term -> [NamesT m Term] -> NamesT m Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr NamesT m Term -> NamesT m Term -> NamesT m Term
forall {m :: * -> *}.
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
NamesT m Term -> NamesT m Term -> NamesT m Term
max (Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) ([NamesT m Term] -> NamesT m Term)
-> [NamesT m Term] -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ ((NamesT m Term, NamesT m Term) -> NamesT m Term)
-> [(NamesT m Term, NamesT m Term)] -> [NamesT m Term]
forall a b. (a -> b) -> [a] -> [b]
map (NamesT m Term, NamesT m Term) -> NamesT m Term
forall a b. (a, b) -> a
fst ([(NamesT m Term, NamesT m Term)] -> [NamesT m Term])
-> [(NamesT m Term, NamesT m Term)] -> [NamesT m Term]
forall a b. (a -> b) -> a -> b
$ [(NamesT m Term, NamesT m Term)]
sys)
NamesT m Term
sys <- (Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT m (NamesT m Term))
-> NamesT m Term -> NamesT m (NamesT m Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT m Term -> NamesT m (NamesT m Term))
-> NamesT m Term -> NamesT m (NamesT m Term)
forall a b. (a -> b) -> a -> b
$ String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam String
"i'" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
i -> do
let base :: (NamesT m Term, NamesT m Term)
base = (NamesT m Term
phi, String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall (m :: * -> *).
MonadFail m =>
String -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam String
"o" ((NamesT m Term -> NamesT m Term) -> NamesT m Term)
-> (NamesT m Term -> NamesT m Term) -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ \ NamesT m Term
_ -> NamesT m Term
u)
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
forall (m :: * -> *).
HasBuiltins m =>
NamesT m Term
-> NamesT m Term
-> [(NamesT m Term, NamesT m Term)]
-> NamesT m Term
combineSys NamesT m Term
l NamesT m Term
ty ([(NamesT m Term, NamesT m Term)] -> NamesT m Term)
-> [(NamesT m Term, NamesT m Term)] -> NamesT m Term
forall a b. (a -> b) -> a -> b
$ (NamesT m Term, NamesT m Term)
base (NamesT m Term, NamesT m Term)
-> [(NamesT m Term, NamesT m Term)]
-> [(NamesT m Term, NamesT m Term)]
forall a. a -> [a] -> [a]
: [(NamesT m Term
phi, NamesT m Term
u NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
i) | (NamesT m Term
phi,NamesT m Term
u) <- [(NamesT m Term, NamesT m Term)]
sys]
Term -> NamesT m Term
forall a. a -> NamesT m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tComp NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
l NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
ty NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT m Term
face NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
sys NamesT m Term -> NamesT m Term -> NamesT m Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT m Term
u
debugClause :: String -> Clause -> TCM ()
debugClause :: String -> Clause -> TCM ()
debugClause String
s Clause
c = do
String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$
TCMT IO Doc
"gamma:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
gamma
String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
gamma (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
TCMT IO Doc
"ps :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Elim] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Elim] -> m Doc
prettyTCM ([NamedArg DeBruijnPattern] -> [Elim]
patternsToElims [NamedArg DeBruijnPattern]
ps)
String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
gamma (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
TCMT IO Doc
"type :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
-> (Arg Type -> TCMT IO Doc) -> Maybe (Arg Type) -> TCMT IO Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO Doc
"nothing" Arg Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Type -> m Doc
prettyTCM Maybe (Arg Type)
rhsTy
String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
20 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
gamma (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
TCMT IO Doc
"body :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc -> (Term -> TCMT IO Doc) -> Maybe Term -> TCMT IO Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO Doc
"nothing" Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Maybe Term
rhs
String -> Nat -> TCMT IO Doc -> TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Nat -> TCMT IO Doc -> m ()
reportSDoc String
s Nat
30 (TCMT IO Doc -> TCM ()) -> TCMT IO Doc -> TCM ()
forall a b. (a -> b) -> a -> b
$
Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
gamma (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"c:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Clause -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Clause
c
where
gamma :: Telescope
gamma = Clause -> Telescope
clauseTel Clause
c
ps :: [NamedArg DeBruijnPattern]
ps = Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
c
rhsTy :: Maybe (Arg Type)
rhsTy = Clause -> Maybe (Arg Type)
clauseType Clause
c
rhs :: Maybe Term
rhs = Clause -> Maybe Term
clauseBody Clause
c