{-# LANGUAGE NondecreasingIndentation #-}
-- {-# OPTIONS_GHC -ddump-simpl -dsuppress-all -dno-suppress-type-signatures -ddump-to-file -dno-typeable-binds #-}

module Agda.TypeChecking.Reduce
 -- Meta instantiation
 ( Instantiate, instantiate', instantiate, instantiateWhen
 -- Recursive meta instantiation
 , InstantiateFull, instantiateFull', instantiateFull
 -- Check for meta (no reduction)
 , IsMeta, isMeta
 -- Reduction and blocking
 , Reduce, reduce', reduceB', reduce, reduceB, reduceWithBlocker, reduceIApply'
 , reduceDefCopy, reduceDefCopyTCM
 , reduceHead
 , slowReduceTerm
 , unfoldCorecursion, unfoldCorecursionE
 , unfoldDefinitionE, unfoldDefinitionStep
 , unfoldInlined
 , appDefE_, appDef', appDefE'
 , abortIfBlocked, ifBlocked, isBlocked, fromBlocked, blockOnError
 -- Simplification
 , Simplify, simplify, simplifyBlocked'
 -- Normalization
 , Normalise, normalise', normalise
 , slowNormaliseArgs
 ) where

import Control.Monad.Except ( MonadError(..) )

import Data.List ( intercalate )
import Data.Maybe
import Data.Map (Map)
import qualified Data.Map as Map
import Data.Foldable
import Data.Traversable
import Data.HashMap.Strict (HashMap)
import qualified Data.Set as Set

import Agda.Interaction.Options

import Agda.Syntax.Position
import Agda.Syntax.Common
import Agda.Syntax.Common.Pretty (prettyShow)
import Agda.Syntax.Internal
import Agda.Syntax.Internal.MetaVars
import Agda.Syntax.Scope.Base (Scope)
import Agda.Syntax.Literal

import {-# SOURCE #-} Agda.TypeChecking.Irrelevance (isPropM)
import Agda.TypeChecking.Free.Base
import {-# SOURCE #-} Agda.TypeChecking.Free.Reduce (forceNoAbsSort)
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.CompiledClause
import Agda.TypeChecking.EtaContract

import {-# SOURCE #-} Agda.TypeChecking.CompiledClause.Match
import {-# SOURCE #-} Agda.TypeChecking.Patterns.Match
import {-# SOURCE #-} Agda.TypeChecking.Pretty
import {-# SOURCE #-} Agda.TypeChecking.Rewriting
import {-# SOURCE #-} Agda.TypeChecking.Reduce.Fast
import {-# SOURCE #-} Agda.TypeChecking.Opacity

import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.List1 (List1, pattern (:|))
import qualified Agda.Utils.Maybe.Strict as Strict
import Agda.Utils.Monad
import Agda.Utils.Size
import Agda.Utils.Tuple
import Agda.Utils.ExpandCase
import qualified Agda.Utils.SmallSet as SmallSet
import Agda.Utils.ExpandCase

import Agda.Utils.Impossible

instantiate :: (Instantiate a, MonadReduce m) => a -> m a
instantiate :: forall a (m :: * -> *). (Instantiate a, MonadReduce m) => a -> m a
instantiate = ReduceM a -> m a
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM a -> m a) -> (a -> ReduceM a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReduceM a
forall t. Instantiate t => t -> ReduceM t
instantiate'

instantiateFull :: (InstantiateFull a, MonadReduce m) => a -> m a
instantiateFull :: forall a (m :: * -> *).
(InstantiateFull a, MonadReduce m) =>
a -> m a
instantiateFull = ReduceM a -> m a
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM a -> m a) -> (a -> ReduceM a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull'

-- | A variant of 'instantiateFull' that only instantiates those
-- meta-variables that satisfy the predicate.

instantiateWhen ::
  (InstantiateFull a, MonadReduce m) =>
  (MetaId -> ReduceM Bool) ->
  a -> m a
instantiateWhen :: forall a (m :: * -> *).
(InstantiateFull a, MonadReduce m) =>
(MetaId -> ReduceM Bool) -> a -> m a
instantiateWhen MetaId -> ReduceM Bool
p =
  ReduceM a -> m a
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM a -> m a) -> (a -> ReduceM a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a
forall a. (ReduceEnv -> ReduceEnv) -> ReduceM a -> ReduceM a
localR (\ReduceEnv
env -> ReduceEnv
env { redPred = Just p }) (ReduceM a -> ReduceM a) -> (a -> ReduceM a) -> a -> ReduceM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
  a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull'

{-# INLINE reduce #-}
reduce :: (Reduce a, MonadReduce m) => a -> m a
reduce :: forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce = ReduceM a -> m a
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM a -> m a) -> (a -> ReduceM a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReduceM a
forall t. Reduce t => t -> ReduceM t
reduce'

{-# INLINE reduceB #-}
reduceB :: (Reduce a, MonadReduce m) => a -> m (Blocked a)
reduceB :: forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB = ReduceM (Blocked a) -> m (Blocked a)
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM (Blocked a) -> m (Blocked a))
-> (a -> ReduceM (Blocked a)) -> a -> m (Blocked a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReduceM (Blocked a)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB'

-- Reduce a term and also produce a blocker signifying when
-- this reduction should be retried.
reduceWithBlocker :: (Reduce a, IsMeta a, MonadReduce m) => a -> m (Blocker, a)
reduceWithBlocker :: forall a (m :: * -> *).
(Reduce a, IsMeta a, MonadReduce m) =>
a -> m (Blocker, a)
reduceWithBlocker a
a = a
-> (Blocker -> a -> m (Blocker, a))
-> (NotBlocked -> a -> m (Blocker, a))
-> m (Blocker, a)
forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked a
a
  (\Blocker
b a
a' -> (Blocker, a) -> m (Blocker, a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocker
b, a
a'))
  (\NotBlocked
_ a
a' -> (Blocker, a) -> m (Blocker, a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocker
neverUnblock, a
a'))

{-# INLINE normalise #-}
normalise :: (Normalise a, MonadReduce m) => a -> m a
normalise :: forall a (m :: * -> *). (Normalise a, MonadReduce m) => a -> m a
normalise = ReduceM a -> m a
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM a -> m a) -> (a -> ReduceM a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReduceM a
forall t. Normalise t => t -> ReduceM t
normalise'

-- UNUSED
-- -- | Normalise the given term but also preserve blocking tags
-- --   TODO: implement a more efficient version of this.
-- normaliseB :: (MonadReduce m, Reduce t, Normalise t) => t -> m (Blocked t)
-- normaliseB = normalise >=> reduceB

{-# INLINE simplify #-}
simplify :: (Simplify a, MonadReduce m) => a -> m a
simplify :: forall a (m :: * -> *). (Simplify a, MonadReduce m) => a -> m a
simplify = ReduceM a -> m a
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM a -> m a) -> (a -> ReduceM a) -> a -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> ReduceM a
forall t. Simplify t => t -> ReduceM t
simplify'

-- | Meaning no metas left in the instantiation.
isFullyInstantiatedMeta :: MetaId -> TCM Bool
isFullyInstantiatedMeta :: MetaId -> TCM Bool
isFullyInstantiatedMeta MetaId
m = do
  inst <- MetaId -> TCMT IO MetaInstantiation
forall (m :: * -> *).
ReadTCState m =>
MetaId -> m MetaInstantiation
lookupMetaInstantiation MetaId
m
  case inst of
    InstV Instantiation
inst -> Term -> Bool
forall a. AllMetas a => a -> Bool
noMetas (Term -> Bool) -> TCMT IO Term -> TCM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> TCMT IO Term
forall a (m :: * -> *).
(InstantiateFull a, MonadReduce m) =>
a -> m a
instantiateFull (Instantiation -> Term
instBody Instantiation
inst)
    MetaInstantiation
_ -> Bool -> TCM Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

{-# INLINABLE blockAll #-}
-- | Blocking on all blockers.
blockAll :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a)
blockAll :: forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Blocked a) -> Blocked (f a)
blockAll f (Blocked a)
bs = Blocker -> f a -> Blocked' Term (f a)
forall a t. Blocker -> a -> Blocked' t a
blockedOn Blocker
block (f a -> Blocked' Term (f a)) -> f a -> Blocked' Term (f a)
forall a b. (a -> b) -> a -> b
$ (Blocked a -> a) -> f (Blocked a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Blocked a -> a
forall t a. Blocked' t a -> a
ignoreBlocking f (Blocked a)
bs
  where block :: Blocker
block = Set Blocker -> Blocker
unblockOnAll (Set Blocker -> Blocker) -> Set Blocker -> Blocker
forall a b. (a -> b) -> a -> b
$ (Blocked a -> Set Blocker) -> f (Blocked a) -> Set Blocker
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (Blocker -> Set Blocker
forall a. a -> Set a
Set.singleton (Blocker -> Set Blocker)
-> (Blocked a -> Blocker) -> Blocked a -> Set Blocker
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocked a -> Blocker
forall {t} {a}. Blocked' t a -> Blocker
blocker) f (Blocked a)
bs
        blocker :: Blocked' t a -> Blocker
blocker NotBlocked{}  = Blocker
alwaysUnblock
        blocker (Blocked Blocker
b a
_) = Blocker
b

{-# INLINABLE blockAny #-}
-- | Blocking on any blockers.
blockAny :: (Functor f, Foldable f) => f (Blocked a) -> Blocked (f a)
blockAny :: forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Blocked a) -> Blocked (f a)
blockAny f (Blocked a)
bs = Blocker -> f a -> Blocked' Term (f a)
forall a t. Blocker -> a -> Blocked' t a
blockedOn Blocker
block (f a -> Blocked' Term (f a)) -> f a -> Blocked' Term (f a)
forall a b. (a -> b) -> a -> b
$ (Blocked a -> a) -> f (Blocked a) -> f a
forall a b. (a -> b) -> f a -> f b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Blocked a -> a
forall t a. Blocked' t a -> a
ignoreBlocking f (Blocked a)
bs
  where block :: Blocker
block = case (Blocked a -> [Blocker]) -> f (Blocked a) -> [Blocker]
forall m a. Monoid m => (a -> m) -> f a -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap Blocked a -> [Blocker]
forall {t} {a}. Blocked' t a -> [Blocker]
blocker f (Blocked a)
bs of
                  [] -> Blocker
alwaysUnblock -- no blockers
                  [Blocker]
bs -> Set Blocker -> Blocker
unblockOnAny (Set Blocker -> Blocker) -> Set Blocker -> Blocker
forall a b. (a -> b) -> a -> b
$ [Blocker] -> Set Blocker
forall a. Ord a => [a] -> Set a
Set.fromList [Blocker]
bs
        blocker :: Blocked' t a -> [Blocker]
blocker NotBlocked{}  = []
        blocker (Blocked Blocker
b a
_) = [Blocker
b]

{-# NOINLINE blockOnError' #-}
blockOnError' :: Blocker -> TCErr -> TCM a
blockOnError' :: forall a. Blocker -> TCErr -> TCM a
blockOnError' Blocker
blocker = \case
  TypeError{}         -> TCErr -> TCM a
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TCErr -> TCM a) -> TCErr -> TCM a
forall a b. (a -> b) -> a -> b
$ Blocker -> TCErr
PatternErr Blocker
blocker
  PatternErr Blocker
blocker' -> TCErr -> TCM a
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TCErr -> TCM a) -> TCErr -> TCM a
forall a b. (a -> b) -> a -> b
$ Blocker -> TCErr
PatternErr (Blocker -> TCErr) -> Blocker -> TCErr
forall a b. (a -> b) -> a -> b
$ Blocker -> Blocker -> Blocker
unblockOnEither Blocker
blocker Blocker
blocker'
  GenericException{}  -> TCM a
forall a. HasCallStack => a
__IMPOSSIBLE__
  err :: TCErr
err@IOException{}   -> TCErr -> TCM a
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
  ParserError{}       -> TCM a
forall a. HasCallStack => a
__IMPOSSIBLE__

{-# INLINE blockOnError #-}
-- | Run the given computation but turn any errors into blocked computations with the given blocker
blockOnError :: Blocker -> TCM a -> TCM a
blockOnError :: forall a. Blocker -> TCM a -> TCM a
blockOnError !Blocker
blocker !TCMT IO a
f = ((TCMT IO a -> Result (TCMT IO a)) -> Result (TCMT IO a))
-> TCMT IO a
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \TCMT IO a -> Result (TCMT IO a)
ret ->
  if Blocker
blocker Blocker -> Blocker -> Bool
forall a. Eq a => a -> a -> Bool
== Blocker
neverUnblock then TCMT IO a -> Result (TCMT IO a)
ret TCMT IO a
f
                             else TCMT IO a -> Result (TCMT IO a)
ret (TCMT IO a -> Result (TCMT IO a))
-> TCMT IO a -> Result (TCMT IO a)
forall a b. (a -> b) -> a -> b
$ TCMT IO a
f TCMT IO a -> (TCErr -> TCMT IO a) -> TCMT IO a
forall a. TCMT IO a -> (TCErr -> TCMT IO a) -> TCMT IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` Blocker -> TCErr -> TCMT IO a
forall a. Blocker -> TCErr -> TCM a
blockOnError' Blocker
blocker

-- | Instantiate something.
--   Results in an open meta variable or a non meta.
--   Doesn't do any reduction, and preserves blocking tags (when blocking meta
--   is uninstantiated).
class Instantiate t where
  instantiate' :: t -> ReduceM t

  default instantiate' :: (t ~ f a, Traversable f, Instantiate a) => t -> ReduceM t
  instantiate' = (a -> ReduceM a) -> f a -> ReduceM (f a)
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) -> f a -> f (f b)
traverse a -> ReduceM a
forall t. Instantiate t => t -> ReduceM t
instantiate'

instance Instantiate t => Instantiate [t]
instance Instantiate t => Instantiate (List1 t)
instance Instantiate t => Instantiate (Map k t)
instance Instantiate t => Instantiate (Maybe t)
instance Instantiate t => Instantiate (Strict.Maybe t)

instance Instantiate t => Instantiate (Abs t)
instance Instantiate t => Instantiate (Arg t)
instance Instantiate t => Instantiate (Elim' t)
instance Instantiate t => Instantiate (Tele t)
instance Instantiate t => Instantiate (IPBoundary' t)

instance Instantiate () where
    instantiate' :: () -> ReduceM ()
instantiate' () = () -> ReduceM ()
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

instance (Instantiate a, Instantiate b) => Instantiate (a,b) where
    instantiate' :: (a, b) -> ReduceM (a, b)
instantiate' (a
x,b
y) = (,) (a -> b -> (a, b)) -> ReduceM a -> ReduceM (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Instantiate t => t -> ReduceM t
instantiate' a
x ReduceM (b -> (a, b)) -> ReduceM b -> ReduceM (a, b)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> ReduceM b
forall t. Instantiate t => t -> ReduceM t
instantiate' b
y

instance (Instantiate a, Instantiate b,Instantiate c) => Instantiate (a,b,c) where
    instantiate' :: (a, b, c) -> ReduceM (a, b, c)
instantiate' (a
x,b
y,c
z) = (,,) (a -> b -> c -> (a, b, c))
-> ReduceM a -> ReduceM (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Instantiate t => t -> ReduceM t
instantiate' a
x ReduceM (b -> c -> (a, b, c))
-> ReduceM b -> ReduceM (c -> (a, b, c))
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> ReduceM b
forall t. Instantiate t => t -> ReduceM t
instantiate' b
y ReduceM (c -> (a, b, c)) -> ReduceM c -> ReduceM (a, b, c)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> c -> ReduceM c
forall t. Instantiate t => t -> ReduceM t
instantiate' c
z

-- | Run the second computation if the 'redPred' predicate holds for
-- the given meta-variable (or if the predicate is not defined), and
-- otherwise the first computation.

ifPredicateDoesNotHoldFor ::
  MetaId -> ReduceM a -> ReduceM a -> ReduceM a
ifPredicateDoesNotHoldFor :: forall a. MetaId -> ReduceM a -> ReduceM a -> ReduceM a
ifPredicateDoesNotHoldFor MetaId
m ReduceM a
doesNotHold ReduceM a
holds = do
  pred <- ReduceEnv -> Maybe (MetaId -> ReduceM Bool)
redPred (ReduceEnv -> Maybe (MetaId -> ReduceM Bool))
-> ReduceM ReduceEnv -> ReduceM (Maybe (MetaId -> ReduceM Bool))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReduceM ReduceEnv
askR
  case pred of
    Maybe (MetaId -> ReduceM Bool)
Nothing -> ReduceM a
holds
    Just MetaId -> ReduceM Bool
p  -> ReduceM Bool -> ReduceM a -> ReduceM a -> ReduceM a
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (MetaId -> ReduceM Bool
p MetaId
m) ReduceM a
holds ReduceM a
doesNotHold

instance Instantiate Term where
  instantiate' :: Term -> ReduceM Term
instantiate' t :: Term
t@(MetaV MetaId
x [Elim]
es) = MetaId -> ReduceM Term -> ReduceM Term -> ReduceM Term
forall a. MetaId -> ReduceM a -> ReduceM a -> ReduceM a
ifPredicateDoesNotHoldFor MetaId
x (Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t) (ReduceM Term -> ReduceM Term) -> ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ do
    blocking <- Getting Bool TCState Bool -> TCState -> Bool
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting Bool TCState Bool
Lens' TCState Bool
stInstantiateBlocking (TCState -> Bool) -> ReduceM TCState -> ReduceM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReduceM TCState
forall (m :: * -> *). ReadTCState m => m TCState
getTCState

    m <- lookupMeta x
    case m of
      Just (Left RemoteMetaVariable
rmv) -> Instantiation -> ReduceM Term
cont (RemoteMetaVariable -> Instantiation
rmvInstantiation RemoteMetaVariable
rmv)

      Just (Right MetaVariable
mv) -> case MetaVariable -> MetaInstantiation
mvInstantiation MetaVariable
mv of
         InstV Instantiation
inst -> Instantiation -> ReduceM Term
cont Instantiation
inst

         MetaInstantiation
_ | Just MetaId
m' <- MetaVariable -> Maybe MetaId
mvTwin MetaVariable
mv, Bool
blocking ->
           Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' (MetaId -> [Elim] -> Term
MetaV MetaId
m' [Elim]
es)

         OpenMeta MetaKind
_ -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t

         BlockedConst Term
u
           | Bool
blocking  -> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' (Term -> ReduceM Term)
-> (BraveTerm -> Term) -> BraveTerm -> ReduceM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BraveTerm -> Term
unBrave (BraveTerm -> ReduceM Term) -> BraveTerm -> ReduceM Term
forall a b. (a -> b) -> a -> b
$
                          Term -> BraveTerm
BraveTerm Term
u BraveTerm -> [Elim] -> BraveTerm
forall t. Apply t => t -> [Elim] -> t
`applyE` [Elim]
es
           | Bool
otherwise -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t

         PostponedTypeCheckingProblem Closure TypeCheckingProblem
_ -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t

      Maybe (Either RemoteMetaVariable MetaVariable)
Nothing -> [Char] -> ReduceM Term
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
[Char] -> m a
__IMPOSSIBLE_VERBOSE__
                   ([Char]
"Meta-variable not found: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! MetaId -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow MetaId
x)
    where
    cont :: Instantiation -> ReduceM Term
cont Instantiation
i = Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' (Term -> ReduceM Term) -> Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ Substitution -> [Arg [Char]] -> [Elim] -> Term
go (Int -> Substitution
forall a. Int -> Substitution' a
raiseS Int
arity) [Arg [Char]]
tel [Elim]
es
      where
      -- A slight complication here is that the meta might be underapplied,
      -- in which case we have to build the lambda abstraction before
      -- applying the substitution, or overapplied in which case we need to
      -- fall back to applyE.
      !tel :: [Arg [Char]]
tel = Instantiation -> [Arg [Char]]
instTel Instantiation
i
      !arity :: Int
arity = [Arg [Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg [Char]]
tel

      go :: Substitution -> [Arg ArgName] -> Elims -> Term
      go :: Substitution -> [Arg [Char]] -> [Elim] -> Term
go !Substitution
rho [Arg [Char]]
args [Elim]
es = case ([Arg [Char]]
args, [Elim]
es) of
        (Arg [Char]
arg:[Arg [Char]]
args, (Elim -> Arg Term
forall a. Elim' a -> Arg a
mustApplyElim -> Arg ArgInfo
_ Term
e):[Elim]
es) -> Substitution -> [Arg [Char]] -> [Elim] -> Term
go (Term -> Substitution -> Substitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS Term
e Substitution
rho) [Arg [Char]]
args [Elim]
es
        ([Arg [Char]]
args, [Elim]
es) -> Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg Term)
rho ((Arg [Char] -> Term -> Term) -> Term -> [Arg [Char]] -> Term
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr' Arg [Char] -> Term -> Term
mkLam (Instantiation -> Term
instBody Instantiation
i) [Arg [Char]]
args) Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [Elim]
es

  instantiate' (Level Level' Term
l) = Level' Term -> Term
levelTm (Level' Term -> Term) -> ReduceM (Level' Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level' Term -> ReduceM (Level' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Level' Term
l
  instantiate' (Sort Sort' Term
s)  = Sort' Term -> Term
Sort (Sort' Term -> Term) -> ReduceM (Sort' Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Sort' Term
s
  instantiate' Term
t         = Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t

instance Instantiate t => Instantiate (Type' t) where
  instantiate' :: Type' t -> ReduceM (Type' t)
instantiate' (El Sort' Term
s t
t) = Sort' Term -> t -> Type' t
forall t a. Sort' t -> a -> Type'' t a
El (Sort' Term -> t -> Type' t)
-> ReduceM (Sort' Term) -> ReduceM (t -> Type' t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Sort' Term
s ReduceM (t -> Type' t) -> ReduceM t -> ReduceM (Type' t)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> ReduceM t
forall t. Instantiate t => t -> ReduceM t
instantiate' t
t

instance Instantiate Level where
  instantiate' :: Level' Term -> ReduceM (Level' Term)
instantiate' (Max Integer
m [PlusLevel]
as) = Integer -> [PlusLevel] -> Level' Term
levelMax Integer
m ([PlusLevel] -> Level' Term)
-> ReduceM [PlusLevel] -> ReduceM (Level' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PlusLevel] -> ReduceM [PlusLevel]
forall t. Instantiate t => t -> ReduceM t
instantiate' [PlusLevel]
as

-- Use Traversable instance
instance Instantiate t => Instantiate (PlusLevel' t)

instance Instantiate a => Instantiate (Blocked a) where
  instantiate' :: Blocked a -> ReduceM (Blocked a)
instantiate' v :: Blocked a
v@NotBlocked{} = Blocked a -> ReduceM (Blocked a)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocked a
v
  instantiate' v :: Blocked a
v@(Blocked Blocker
b a
u) = Blocker -> ReduceM Blocker
forall t. Instantiate t => t -> ReduceM t
instantiate' Blocker
b ReduceM Blocker
-> (Blocker -> ReduceM (Blocked a)) -> ReduceM (Blocked a)
forall a b. ReduceM a -> (a -> ReduceM b) -> ReduceM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
    Blocker
b | Blocker
b Blocker -> Blocker -> Bool
forall a. Eq a => a -> a -> Bool
== Blocker
alwaysUnblock -> a -> Blocked a
forall a t. a -> Blocked' t a
notBlocked (a -> Blocked a) -> ReduceM a -> ReduceM (Blocked a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Instantiate t => t -> ReduceM t
instantiate' a
u
      | Bool
otherwise          -> Blocked a -> ReduceM (Blocked a)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked a -> ReduceM (Blocked a))
-> Blocked a -> ReduceM (Blocked a)
forall a b. (a -> b) -> a -> b
$ Blocker -> a -> Blocked a
forall t a. Blocker -> a -> Blocked' t a
Blocked Blocker
b a
u

instance Instantiate Blocker where
  instantiate' :: Blocker -> ReduceM Blocker
instantiate' (UnblockOnAll Set Blocker
bs) = Set Blocker -> Blocker
unblockOnAll (Set Blocker -> Blocker)
-> ([Blocker] -> Set Blocker) -> [Blocker] -> Blocker
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Blocker] -> Set Blocker
forall a. Ord a => [a] -> Set a
Set.fromList ([Blocker] -> Blocker) -> ReduceM [Blocker] -> ReduceM Blocker
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Blocker -> ReduceM Blocker) -> [Blocker] -> ReduceM [Blocker]
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 Blocker -> ReduceM Blocker
forall t. Instantiate t => t -> ReduceM t
instantiate' (Set Blocker -> [Blocker]
forall a. Set a -> [a]
Set.toList Set Blocker
bs)
  instantiate' (UnblockOnAny Set Blocker
bs) = Set Blocker -> Blocker
unblockOnAny (Set Blocker -> Blocker)
-> ([Blocker] -> Set Blocker) -> [Blocker] -> Blocker
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Blocker] -> Set Blocker
forall a. Ord a => [a] -> Set a
Set.fromList ([Blocker] -> Blocker) -> ReduceM [Blocker] -> ReduceM Blocker
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Blocker -> ReduceM Blocker) -> [Blocker] -> ReduceM [Blocker]
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 Blocker -> ReduceM Blocker
forall t. Instantiate t => t -> ReduceM t
instantiate' (Set Blocker -> [Blocker]
forall a. Set a -> [a]
Set.toList Set Blocker
bs)
  instantiate' b :: Blocker
b@(UnblockOnMeta MetaId
x) =
    ReduceM Bool
-> ReduceM Blocker -> ReduceM Blocker -> ReduceM Blocker
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (MetaId -> ReduceM Bool
forall a (m :: * -> *).
(IsInstantiatedMeta a, ReadTCState m) =>
a -> m Bool
forall (m :: * -> *). ReadTCState m => MetaId -> m Bool
isInstantiatedMeta MetaId
x) (Blocker -> ReduceM Blocker
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocker
alwaysUnblock) (Blocker -> ReduceM Blocker
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocker
b)
  instantiate' (UnblockOnProblem ProblemId
pi) =
    ReduceM Bool
-> ReduceM Blocker -> ReduceM Blocker -> ReduceM Blocker
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (ProblemId -> ReduceM Bool
forall (m :: * -> *).
(MonadTCEnv m, ReadTCState m) =>
ProblemId -> m Bool
isProblemSolved ProblemId
pi) (Blocker -> ReduceM Blocker
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocker
alwaysUnblock) (Blocker -> ReduceM Blocker
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocker -> ReduceM Blocker) -> Blocker -> ReduceM Blocker
forall a b. (a -> b) -> a -> b
$ ProblemId -> Blocker
UnblockOnProblem ProblemId
pi)
  instantiate' b :: Blocker
b@UnblockOnDef{} = Blocker -> ReduceM Blocker
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocker
b

instance Instantiate Sort where
  instantiate' :: Sort' Term -> ReduceM (Sort' Term)
instantiate' = \case
    MetaS MetaId
x [Elim]
es -> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' (MetaId -> [Elim] -> Term
MetaV MetaId
x [Elim]
es) ReduceM Term
-> (Term -> ReduceM (Sort' Term)) -> ReduceM (Sort' Term)
forall a b. ReduceM a -> (a -> ReduceM b) -> ReduceM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Sort Sort' Term
s'      -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s'
      MetaV MetaId
x' [Elim]
es' -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort' Term -> ReduceM (Sort' Term))
-> Sort' Term -> ReduceM (Sort' Term)
forall a b. (a -> b) -> a -> b
$ MetaId -> [Elim] -> Sort' Term
forall t. MetaId -> [Elim' t] -> Sort' t
MetaS MetaId
x' [Elim]
es'
      Def QName
d [Elim]
es'    -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort' Term -> ReduceM (Sort' Term))
-> Sort' Term -> ReduceM (Sort' Term)
forall a b. (a -> b) -> a -> b
$ QName -> [Elim] -> Sort' Term
forall t. QName -> [Elim' t] -> Sort' t
DefS QName
d [Elim]
es'
      Term
_            -> ReduceM (Sort' Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
    Sort' Term
s -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s

instance Instantiate e => Instantiate (Dom e) where
    instantiate' :: Dom e -> ReduceM (Dom e)
instantiate' (Dom ArgInfo
i Maybe NamedName
n Bool
b Maybe Term
tac Maybe (RewDom' Term)
rew e
x) = ArgInfo
-> Maybe NamedName
-> Bool
-> Maybe Term
-> Maybe (RewDom' Term)
-> e
-> Dom e
forall t e.
ArgInfo
-> Maybe NamedName
-> Bool
-> Maybe t
-> Maybe (RewDom' t)
-> e
-> Dom' t e
Dom ArgInfo
i Maybe NamedName
n Bool
b (Maybe Term -> Maybe (RewDom' Term) -> e -> Dom e)
-> ReduceM (Maybe Term)
-> ReduceM (Maybe (RewDom' Term) -> e -> Dom e)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe Term -> ReduceM (Maybe Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Maybe Term
tac ReduceM (Maybe (RewDom' Term) -> e -> Dom e)
-> ReduceM (Maybe (RewDom' Term)) -> ReduceM (e -> Dom e)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe (RewDom' Term) -> ReduceM (Maybe (RewDom' Term))
forall t. Instantiate t => t -> ReduceM t
instantiate' Maybe (RewDom' Term)
rew ReduceM (e -> Dom e) -> ReduceM e -> ReduceM (Dom e)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> e -> ReduceM e
forall t. Instantiate t => t -> ReduceM t
instantiate' e
x

instance Instantiate a => Instantiate (Closure a) where
    instantiate' :: Closure a -> ReduceM (Closure a)
instantiate' Closure a
cl = do
        x <- Closure a -> (a -> ReduceM a) -> ReduceM a
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure Closure a
cl a -> ReduceM a
forall t. Instantiate t => t -> ReduceM t
instantiate'
        return $ cl { clValue = x }

instance Instantiate ProblemConstraint where
  instantiate' :: ProblemConstraint -> ReduceM ProblemConstraint
instantiate' (PConstr Set ProblemId
p Blocker
u Closure Constraint
c) = Set ProblemId -> Blocker -> Closure Constraint -> ProblemConstraint
PConstr Set ProblemId
p Blocker
u (Closure Constraint -> ProblemConstraint)
-> ReduceM (Closure Constraint) -> ReduceM ProblemConstraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure Constraint -> ReduceM (Closure Constraint)
forall t. Instantiate t => t -> ReduceM t
instantiate' Closure Constraint
c

instance Instantiate Constraint where
  instantiate' :: Constraint -> ReduceM Constraint
instantiate' (ValueCmp Comparison
cmp CompareAs
t Term
u Term
v) = do
    (t,u,v) <- (CompareAs, Term, Term) -> ReduceM (CompareAs, Term, Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' (CompareAs
t,Term
u,Term
v)
    return $ ValueCmp cmp t u v
  instantiate' (ValueCmpOnFace Comparison
cmp Term
p Type
t Term
u Term
v) = do
    ((p,t),u,v) <- ((Term, Type), Term, Term) -> ReduceM ((Term, Type), Term, Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' ((Term
p,Type
t),Term
u,Term
v)
    return $ ValueCmpOnFace cmp p t u v
  instantiate' (ElimCmp [Polarity]
cmp [IsForced]
fs Type
t Term
v [Elim]
as [Elim]
bs) =
    [Polarity]
-> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> Constraint
ElimCmp [Polarity]
cmp [IsForced]
fs (Type -> Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Type -> ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
t ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Term -> ReduceM ([Elim] -> [Elim] -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
v ReduceM ([Elim] -> [Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM ([Elim] -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Elim] -> ReduceM [Elim]
forall t. Instantiate t => t -> ReduceM t
instantiate' [Elim]
as ReduceM ([Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Elim] -> ReduceM [Elim]
forall t. Instantiate t => t -> ReduceM t
instantiate' [Elim]
bs
  instantiate' (LevelCmp Comparison
cmp Level' Term
u Level' Term
v)   = (Level' Term -> Level' Term -> Constraint)
-> (Level' Term, Level' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Level' Term -> Level' Term -> Constraint
LevelCmp Comparison
cmp) ((Level' Term, Level' Term) -> Constraint)
-> ReduceM (Level' Term, Level' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Level' Term, Level' Term) -> ReduceM (Level' Term, Level' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' (Level' Term
u,Level' Term
v)
  instantiate' (SortCmp Comparison
cmp Sort' Term
a Sort' Term
b)    = (Sort' Term -> Sort' Term -> Constraint)
-> (Sort' Term, Sort' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Sort' Term -> Sort' Term -> Constraint
SortCmp Comparison
cmp) ((Sort' Term, Sort' Term) -> Constraint)
-> ReduceM (Sort' Term, Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sort' Term, Sort' Term) -> ReduceM (Sort' Term, Sort' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' (Sort' Term
a,Sort' Term
b)
  instantiate' (UnBlock MetaId
m)          = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ MetaId -> Constraint
UnBlock MetaId
m
  instantiate' (FindInstance Range
r MetaId
m Maybe [Candidate]
cs)   = Range -> MetaId -> Maybe [Candidate] -> Constraint
FindInstance Range
r MetaId
m (Maybe [Candidate] -> Constraint)
-> ReduceM (Maybe [Candidate]) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Candidate] -> ReduceM [Candidate])
-> Maybe [Candidate] -> ReduceM (Maybe [Candidate])
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) -> Maybe a -> m (Maybe b)
mapM [Candidate] -> ReduceM [Candidate]
forall t. Instantiate t => t -> ReduceM t
instantiate' Maybe [Candidate]
cs
  instantiate' (ResolveInstanceHead KwRange
kwr QName
q) = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ KwRange -> QName -> Constraint
ResolveInstanceHead KwRange
kwr QName
q
  instantiate' (IsEmpty Range
r Type
t)        = Range -> Type -> Constraint
IsEmpty Range
r (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
t
  instantiate' (CheckSizeLtSat Term
t)   = Term -> Constraint
CheckSizeLtSat (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
t
  instantiate' c :: Constraint
c@CheckFunDef{}      = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
  instantiate' (HasBiggerSort Sort' Term
a)    = Sort' Term -> Constraint
HasBiggerSort (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Sort' Term
a
  instantiate' (HasPTSRule Dom' Term Type
a Abs (Sort' Term)
b)     = (Dom' Term Type -> Abs (Sort' Term) -> Constraint)
-> (Dom' Term Type, Abs (Sort' Term)) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Dom' Term Type -> Abs (Sort' Term) -> Constraint
HasPTSRule ((Dom' Term Type, Abs (Sort' Term)) -> Constraint)
-> ReduceM (Dom' Term Type, Abs (Sort' Term)) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dom' Term Type, Abs (Sort' Term))
-> ReduceM (Dom' Term Type, Abs (Sort' Term))
forall t. Instantiate t => t -> ReduceM t
instantiate' (Dom' Term Type
a,Abs (Sort' Term)
b)
  instantiate' (CheckLockedVars Term
a Type
b Arg Term
c Type
d) =
    Term -> Type -> Arg Term -> Type -> Constraint
CheckLockedVars (Term -> Type -> Arg Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Arg Term -> Type -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
a ReduceM (Type -> Arg Term -> Type -> Constraint)
-> ReduceM Type -> ReduceM (Arg Term -> Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
b ReduceM (Arg Term -> Type -> Constraint)
-> ReduceM (Arg Term) -> ReduceM (Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Arg Term
c ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
d
  instantiate' (UnquoteTactic Term
t Term
h Type
g) = Term -> Term -> Type -> Constraint
UnquoteTactic (Term -> Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Term -> Type -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
t ReduceM (Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
h ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
g
  instantiate' (CheckDataSort QName
q Sort' Term
s)  = QName -> Sort' Term -> Constraint
CheckDataSort QName
q (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Sort' Term
s
  instantiate' c :: Constraint
c@CheckMetaInst{}    = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
  instantiate' (CheckType Type
t)        = Type -> Constraint
CheckType (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
t
  instantiate' (UsableAtModality WhyCheckModality
cc Maybe (Sort' Term)
ms Modality
mod Term
t) = (Maybe (Sort' Term) -> Modality -> Term -> Constraint)
-> Modality -> Maybe (Sort' Term) -> Term -> Constraint
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WhyCheckModality
-> Maybe (Sort' Term) -> Modality -> Term -> Constraint
UsableAtModality WhyCheckModality
cc) Modality
mod (Maybe (Sort' Term) -> Term -> Constraint)
-> ReduceM (Maybe (Sort' Term)) -> ReduceM (Term -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Sort' Term) -> ReduceM (Maybe (Sort' Term))
forall t. Instantiate t => t -> ReduceM t
instantiate' Maybe (Sort' Term)
ms ReduceM (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
t
  instantiate' (RewConstraint LocalEquation' Term
e)    = LocalEquation' Term -> Constraint
RewConstraint (LocalEquation' Term -> Constraint)
-> ReduceM (LocalEquation' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalEquation' Term -> ReduceM (LocalEquation' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' LocalEquation' Term
e

instance Instantiate CompareAs where
  instantiate' :: CompareAs -> ReduceM CompareAs
instantiate' (AsTermsOf Type
a) = Type -> CompareAs
AsTermsOf (Type -> CompareAs) -> ReduceM Type -> ReduceM CompareAs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
a
  instantiate' CompareAs
AsSizes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsSizes
  instantiate' CompareAs
AsTypes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsTypes

instance Instantiate Candidate where
  instantiate' :: Candidate -> ReduceM Candidate
instantiate' (Candidate CandidateKind
q Term
u Type
t OverlapMode
ov) = CandidateKind -> Term -> Type -> OverlapMode -> Candidate
Candidate CandidateKind
q (Term -> Type -> OverlapMode -> Candidate)
-> ReduceM Term -> ReduceM (Type -> OverlapMode -> Candidate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
u ReduceM (Type -> OverlapMode -> Candidate)
-> ReduceM Type -> ReduceM (OverlapMode -> Candidate)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
t ReduceM (OverlapMode -> Candidate)
-> ReduceM OverlapMode -> ReduceM Candidate
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OverlapMode -> ReduceM OverlapMode
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OverlapMode
ov

instance Instantiate EqualityView where
  instantiate' :: EqualityView -> ReduceM EqualityView
instantiate' (OtherType Type
t)            = Type -> EqualityView
OtherType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
t
  instantiate' (IdiomType Type
t)            = Type -> EqualityView
IdiomType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
t
  instantiate' (EqualityType Range
r Sort' Term
s QName
eq Args
l Arg Term
t Arg Term
a Arg Term
b) = Range
-> Sort' Term
-> QName
-> Args
-> Arg Term
-> Arg Term
-> Arg Term
-> EqualityView
EqualityType Range
r
    (Sort' Term
 -> QName
 -> Args
 -> Arg Term
 -> Arg Term
 -> Arg Term
 -> EqualityView)
-> ReduceM (Sort' Term)
-> ReduceM
     (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Sort' Term
s
    ReduceM
  (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM QName
-> ReduceM
     (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QName -> ReduceM QName
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
eq
    ReduceM (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM Args
-> ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Arg Term -> ReduceM (Arg Term)) -> Args -> ReduceM Args
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 -> ReduceM (Arg Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Args
l
    ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term)
-> ReduceM (Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Arg Term
t
    ReduceM (Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM (Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Arg Term
a
    ReduceM (Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM EqualityView
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Arg Term
b

instance Instantiate LocalEquation where
  instantiate' :: LocalEquation' Term -> ReduceM (LocalEquation' Term)
instantiate' (LocalEquation Telescope
a Term
b Term
c Type
d) =
    Telescope -> Term -> Term -> Type -> LocalEquation' Term
forall t.
Tele (Dom' t (Type'' t t))
-> t -> t -> Type'' t t -> LocalEquation' t
LocalEquation
      (Telescope -> Term -> Term -> Type -> LocalEquation' Term)
-> ReduceM Telescope
-> ReduceM (Term -> Term -> Type -> LocalEquation' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> ReduceM Telescope
forall t. Instantiate t => t -> ReduceM t
instantiate' Telescope
a
      ReduceM (Term -> Term -> Type -> LocalEquation' Term)
-> ReduceM Term -> ReduceM (Term -> Type -> LocalEquation' Term)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
b
      ReduceM (Term -> Type -> LocalEquation' Term)
-> ReduceM Term -> ReduceM (Type -> LocalEquation' Term)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
c
      ReduceM (Type -> LocalEquation' Term)
-> ReduceM Type -> ReduceM (LocalEquation' Term)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
d

instance Instantiate RewriteRule where
  instantiate' :: RewriteRule -> ReduceM RewriteRule
instantiate' (RewriteRule Telescope
a RewriteHead
b PElims
c Term
d Type
e) =
    Telescope -> RewriteHead -> PElims -> Term -> Type -> RewriteRule
RewriteRule
      (Telescope -> RewriteHead -> PElims -> Term -> Type -> RewriteRule)
-> ReduceM Telescope
-> ReduceM (RewriteHead -> PElims -> Term -> Type -> RewriteRule)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> ReduceM Telescope
forall t. Instantiate t => t -> ReduceM t
instantiate' Telescope
a
      ReduceM (RewriteHead -> PElims -> Term -> Type -> RewriteRule)
-> ReduceM RewriteHead
-> ReduceM (PElims -> Term -> Type -> RewriteRule)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> RewriteHead -> ReduceM RewriteHead
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RewriteHead
b
      ReduceM (PElims -> Term -> Type -> RewriteRule)
-> ReduceM PElims -> ReduceM (Term -> Type -> RewriteRule)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> PElims -> ReduceM PElims
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure PElims
c
      ReduceM (Term -> Type -> RewriteRule)
-> ReduceM Term -> ReduceM (Type -> RewriteRule)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
d
      ReduceM (Type -> RewriteRule)
-> ReduceM Type -> ReduceM RewriteRule
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Instantiate t => t -> ReduceM t
instantiate' Type
e

instance Instantiate RewDom where
  instantiate' :: RewDom' Term -> ReduceM (RewDom' Term)
instantiate' (RewDom LocalEquation' Term
a Maybe RewriteRule
b) =
    LocalEquation' Term -> Maybe RewriteRule -> RewDom' Term
forall t. LocalEquation' t -> Maybe RewriteRule -> RewDom' t
RewDom
      (LocalEquation' Term -> Maybe RewriteRule -> RewDom' Term)
-> ReduceM (LocalEquation' Term)
-> ReduceM (Maybe RewriteRule -> RewDom' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalEquation' Term -> ReduceM (LocalEquation' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' LocalEquation' Term
a
      ReduceM (Maybe RewriteRule -> RewDom' Term)
-> ReduceM (Maybe RewriteRule) -> ReduceM (RewDom' Term)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Maybe RewriteRule -> ReduceM (Maybe RewriteRule)
forall t. Instantiate t => t -> ReduceM t
instantiate' Maybe RewriteRule
b

---------------------------------------------------------------------------
-- * Reduction to weak head normal form.
---------------------------------------------------------------------------

-- | Is something (an elimination of) a meta variable?
--   Does not perform any reductions.

class IsMeta a where
  isMeta :: a -> Maybe MetaId

instance IsMeta Term where
  isMeta :: Term -> Maybe MetaId
isMeta (MetaV MetaId
m [Elim]
_) = MetaId -> Maybe MetaId
forall a. a -> Maybe a
Just MetaId
m
  isMeta Term
_           = Maybe MetaId
forall a. Maybe a
Nothing

instance IsMeta (Sort' a) where
  isMeta :: Sort' a -> Maybe MetaId
isMeta (MetaS MetaId
m [Elim' a]
_) = MetaId -> Maybe MetaId
forall a. a -> Maybe a
Just MetaId
m
  isMeta Sort' a
_           = Maybe MetaId
forall a. Maybe a
Nothing

instance IsMeta a => IsMeta (Type'' t a) where
  isMeta :: Type'' t a -> Maybe MetaId
isMeta = a -> Maybe MetaId
forall a. IsMeta a => a -> Maybe MetaId
isMeta (a -> Maybe MetaId)
-> (Type'' t a -> a) -> Type'' t a -> Maybe MetaId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type'' t a -> a
forall t a. Type'' t a -> a
unEl

instance IsMeta a => IsMeta (Elim' a) where
  isMeta :: Elim' a -> Maybe MetaId
isMeta Proj{}    = Maybe MetaId
forall a. Maybe a
Nothing
  isMeta IApply{}  = Maybe MetaId
forall a. Maybe a
Nothing
  isMeta (Apply Arg a
a) = Arg a -> Maybe MetaId
forall a. IsMeta a => a -> Maybe MetaId
isMeta Arg a
a

instance IsMeta a => IsMeta (Arg a) where
  isMeta :: Arg a -> Maybe MetaId
isMeta = a -> Maybe MetaId
forall a. IsMeta a => a -> Maybe MetaId
isMeta (a -> Maybe MetaId) -> (Arg a -> a) -> Arg a -> Maybe MetaId
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg a -> a
forall e. Arg e -> e
unArg

instance IsMeta a => IsMeta (Level' a) where
  isMeta :: Level' a -> Maybe MetaId
isMeta (Max Integer
0 [PlusLevel' a
l]) = PlusLevel' a -> Maybe MetaId
forall a. IsMeta a => a -> Maybe MetaId
isMeta PlusLevel' a
l
  isMeta Level' a
_           = Maybe MetaId
forall a. Maybe a
Nothing

instance IsMeta a => IsMeta (PlusLevel' a) where
  isMeta :: PlusLevel' a -> Maybe MetaId
isMeta (Plus Integer
0 a
l)  = a -> Maybe MetaId
forall a. IsMeta a => a -> Maybe MetaId
isMeta a
l
  isMeta PlusLevel' a
_           = Maybe MetaId
forall a. Maybe a
Nothing

instance IsMeta CompareAs where
  isMeta :: CompareAs -> Maybe MetaId
isMeta (AsTermsOf Type
a) = Type -> Maybe MetaId
forall a. IsMeta a => a -> Maybe MetaId
isMeta Type
a
  isMeta CompareAs
AsSizes       = Maybe MetaId
forall a. Maybe a
Nothing
  isMeta CompareAs
AsTypes       = Maybe MetaId
forall a. Maybe a
Nothing

{-# INLINE ifBlocked #-}
-- | Case on whether a term is blocked on a meta (or is a meta).
--   That means it can change its shape when the meta is instantiated.
ifBlocked
  :: (Reduce t, IsMeta t, MonadReduce m)
  => t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked :: forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked t
t Blocker -> t -> m a
blocked NotBlocked -> t -> m a
unblocked = do
  t <- t -> m (Blocked t)
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB t
t
  case t of
    Blocked Blocker
m t
t     -> Blocker -> t -> m a
blocked Blocker
m t
t
    NotBlocked NotBlocked
nb t
t -> case t -> Maybe MetaId
forall a. IsMeta a => a -> Maybe MetaId
isMeta t
t of -- #4899: MetaS counts as NotBlocked at the moment
      Just MetaId
m    -> Blocker -> t -> m a
blocked (MetaId -> Blocker
unblockOnMeta MetaId
m) t
t
      Maybe MetaId
Nothing   -> NotBlocked -> t -> m a
unblocked NotBlocked
nb t
t

-- | Throw pattern violation if blocked or a meta.
abortIfBlocked :: (MonadReduce m, MonadBlock m, IsMeta t, Reduce t) => t -> m t
abortIfBlocked :: forall (m :: * -> *) t.
(MonadReduce m, MonadBlock m, IsMeta t, Reduce t) =>
t -> m t
abortIfBlocked t
t = t -> (Blocker -> t -> m t) -> (NotBlocked -> t -> m t) -> m t
forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked t
t (m t -> t -> m t
forall a b. a -> b -> a
const (m t -> t -> m t) -> (Blocker -> m t) -> Blocker -> t -> m t
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocker -> m t
forall a. Blocker -> m a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation) ((t -> m t) -> NotBlocked -> t -> m t
forall a b. a -> b -> a
const t -> m t
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return)

isBlocked
  :: (Reduce t, IsMeta t, MonadReduce m)
  => t -> m (Maybe Blocker)
isBlocked :: forall t (m :: * -> *).
(Reduce t, IsMeta t, MonadReduce m) =>
t -> m (Maybe Blocker)
isBlocked t
t = t
-> (Blocker -> t -> m (Maybe Blocker))
-> (NotBlocked -> t -> m (Maybe Blocker))
-> m (Maybe Blocker)
forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked t
t (\Blocker
m t
_ -> Maybe Blocker -> m (Maybe Blocker)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Blocker -> m (Maybe Blocker))
-> Maybe Blocker -> m (Maybe Blocker)
forall a b. (a -> b) -> a -> b
$ Blocker -> Maybe Blocker
forall a. a -> Maybe a
Just Blocker
m) (\NotBlocked
_ t
_ -> Maybe Blocker -> m (Maybe Blocker)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Blocker
forall a. Maybe a
Nothing)

-- | Throw a pattern violation if the argument is @Blocked@,
--   otherwise return the value embedded in the @NotBlocked@.
fromBlocked :: MonadBlock m => Blocked a -> m a
fromBlocked :: forall (m :: * -> *) a. MonadBlock m => Blocked a -> m a
fromBlocked (Blocked Blocker
b a
_) = Blocker -> m a
forall a. Blocker -> m a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
b
fromBlocked (NotBlocked NotBlocked
_ a
x) = a -> m a
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return a
x

class Reduce t where
  reduce'  :: t -> ReduceM t
  reduceB' :: t -> ReduceM (Blocked t)

  reduce'  t
t = Blocked t -> t
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked t -> t) -> ReduceM (Blocked t) -> ReduceM t
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> ReduceM (Blocked t)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' t
t
  reduceB' t
t = t -> Blocked t
forall a t. a -> Blocked' t a
notBlocked (t -> Blocked t) -> ReduceM t -> ReduceM (Blocked t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> ReduceM t
forall t. Reduce t => t -> ReduceM t
reduce' t
t

  {-# MINIMAL reduce' | reduceB' #-}

instance Reduce Type where
    reduce' :: Type -> ReduceM Type
reduce'  (El Sort' Term
s Term
t) = ReduceM Type -> ReduceM Type
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
workOnTypes (ReduceM Type -> ReduceM Type) -> ReduceM Type -> ReduceM Type
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El Sort' Term
s (Term -> Type) -> ReduceM Term -> ReduceM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
t
    reduceB' :: Type -> ReduceM (Blocked Type)
reduceB' (El Sort' Term
s Term
t) = ReduceM (Blocked Type) -> ReduceM (Blocked Type)
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
workOnTypes (ReduceM (Blocked Type) -> ReduceM (Blocked Type))
-> ReduceM (Blocked Type) -> ReduceM (Blocked Type)
forall a b. (a -> b) -> a -> b
$ (Term -> Type) -> Blocked' Term Term -> Blocked Type
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Sort' Term -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El Sort' Term
s) (Blocked' Term Term -> Blocked Type)
-> ReduceM (Blocked' Term Term) -> ReduceM (Blocked Type)
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' Term
t

instance Reduce Sort where
    -- Does not return a 'NotBlocked' 'PiSort', 'FunSort', or 'UnivSort'.
    reduceB' :: Sort' Term -> ReduceM (Blocked (Sort' Term))
reduceB' Sort' Term
s = do
      s <- Sort' Term -> ReduceM (Sort' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Sort' Term
s
      let done | MetaS MetaId
x [Elim]
_ <- Sort' Term
s = Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$ MetaId -> Sort' Term -> Blocked (Sort' Term)
forall a t. MetaId -> a -> Blocked' t a
blocked MetaId
x Sort' Term
s
               | Bool
otherwise      = Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Blocked (Sort' Term)
forall a t. a -> Blocked' t a
notBlocked Sort' Term
s
      case s of
        PiSort Dom' Term Term
a Sort' Term
s1 Abs (Sort' Term)
s2Abs -> (Sort' Term, Abs (Sort' Term))
-> ReduceM (Blocked (Sort' Term, Abs (Sort' Term)))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (Sort' Term
s1 , Abs (Sort' Term)
s2Abs) ReduceM (Blocked (Sort' Term, Abs (Sort' Term)))
-> (Blocked (Sort' Term, Abs (Sort' Term))
    -> ReduceM (Blocked (Sort' Term)))
-> ReduceM (Blocked (Sort' Term))
forall a b. ReduceM a -> (a -> ReduceM b) -> ReduceM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          -- If either the domain or codomain sort is blocked, there is no point
          -- in doing the free variable check since even if we manage to reduce
          -- to a FunSort, it would still be blocked. And normalizing anyway in
          -- this case leads to exponential behavior (see #8423).
          Blocked Blocker
b (Sort' Term
s1 , Abs (Sort' Term)
s2Abs) -> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$! Blocker -> Sort' Term -> Blocked (Sort' Term)
forall a t. Blocker -> a -> Blocked' t a
blockedOn Blocker
b (Sort' Term -> Blocked (Sort' Term))
-> Sort' Term -> Blocked (Sort' Term)
forall a b. (a -> b) -> a -> b
$ Dom' Term Term -> Sort' Term -> Abs (Sort' Term) -> Sort' Term
forall t. Dom' t t -> Sort' t -> Abs (Sort' t) -> Sort' t
PiSort Dom' Term Term
a Sort' Term
s1 Abs (Sort' Term)
s2Abs
          NotBlocked NotBlocked
_ (Sort' Term
s1 , Abs (Sort' Term)
s2Abs) -> do
            -- In theory we should just call piSort' here. However, we also want
            -- to reduce the codomain sort to make it non-dependent when
            -- possible. So we use forceNoAbs and in case we are dealing with a
            -- proper Abs we call piSortAbs directly.
            let dom :: Dom' Term Type
dom = Sort' Term -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El Sort' Term
s1 (Term -> Type) -> Dom' Term Term -> Dom' Term Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom' Term Term
a
            Dom' Term Type
-> Abs (Sort' Term)
-> ReduceM (Either (Abs (Sort' Term), FlexRig) (Sort' Term))
forceNoAbsSort Dom' Term Type
dom Abs (Sort' Term)
s2Abs ReduceM (Either (Abs (Sort' Term), FlexRig) (Sort' Term))
-> (Either (Abs (Sort' Term), FlexRig) (Sort' Term)
    -> ReduceM (Blocked (Sort' Term)))
-> ReduceM (Blocked (Sort' Term))
forall a b. ReduceM a -> (a -> ReduceM b) -> ReduceM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              -- If the codomain sort is non-dependent, we reduce to a FunSort
              Right Sort' Term
s2 -> Sort' Term -> ReduceM (Blocked (Sort' Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (Sort' Term -> ReduceM (Blocked (Sort' Term)))
-> Sort' Term -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Sort' Term -> Sort' Term
forall t. Sort' t -> Sort' t -> Sort' t
FunSort Sort' Term
s1 Sort' Term
s2
              -- For a (possibly) properly dependent PiSort, we call piSortAbs.
              Left (Abs (Sort' Term)
s2Abs, FlexRig
flexRig) -> do
                let blockOcc :: Blocker
blockOcc = FlexRig -> Blocker
flexRigToBlocker FlexRig
flexRig
                case Dom' Term Term
-> Sort' Term
-> Abs (Sort' Term)
-> FlexRig
-> IsCodomainNormalised
-> Either Blocker (Sort' Term)
piSortAbs Dom' Term Term
a Sort' Term
s1 Abs (Sort' Term)
s2Abs FlexRig
flexRig IsCodomainNormalised
CodomainNormalised of
                  -- We already know the sorts themselves are not blocked,
                  -- so the only possible blocker comes from the free variable check
                  Left Blocker
_ -> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$! Blocker -> Sort' Term -> Blocked (Sort' Term)
forall a t. Blocker -> a -> Blocked' t a
blockedOn Blocker
blockOcc (Sort' Term -> Blocked (Sort' Term))
-> Sort' Term -> Blocked (Sort' Term)
forall a b. (a -> b) -> a -> b
$ Dom' Term Term -> Sort' Term -> Abs (Sort' Term) -> Sort' Term
forall t. Dom' t t -> Sort' t -> Abs (Sort' t) -> Sort' t
PiSort Dom' Term Term
a Sort' Term
s1 Abs (Sort' Term)
s2Abs
                  -- The only sort that piSortAbs can reduce is Inf,
                  -- so there is no need to try reducing it further.
                  Right Sort' Term
s -> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$! Sort' Term -> Blocked (Sort' Term)
forall a t. a -> Blocked' t a
notBlocked Sort' Term
s
        FunSort Sort' Term
s1 Sort' Term
s2 -> (Sort' Term, Sort' Term)
-> ReduceM (Blocked (Sort' Term, Sort' Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (Sort' Term
s1 , Sort' Term
s2) ReduceM (Blocked (Sort' Term, Sort' Term))
-> (Blocked (Sort' Term, Sort' Term)
    -> ReduceM (Blocked (Sort' Term)))
-> ReduceM (Blocked (Sort' Term))
forall a b. ReduceM a -> (a -> ReduceM b) -> ReduceM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Blocked Blocker
b (Sort' Term
s1',Sort' Term
s2') -> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$ Blocker -> Sort' Term -> Blocked (Sort' Term)
forall t a. Blocker -> a -> Blocked' t a
Blocked Blocker
b (Sort' Term -> Blocked (Sort' Term))
-> Sort' Term -> Blocked (Sort' Term)
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Sort' Term -> Sort' Term
forall t. Sort' t -> Sort' t -> Sort' t
FunSort Sort' Term
s1' Sort' Term
s2'
          NotBlocked NotBlocked
_ (Sort' Term
s1',Sort' Term
s2') -> Sort' Term -> Sort' Term -> ReduceM (Either Blocker (Sort' Term))
forall (m :: * -> *).
HasOptions m =>
Sort' Term -> Sort' Term -> m (Either Blocker (Sort' Term))
funSortM' Sort' Term
s1' Sort' Term
s2' ReduceM (Either Blocker (Sort' Term))
-> (Either Blocker (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> ReduceM (Blocked (Sort' Term))
forall a b. ReduceM a -> (a -> ReduceM b) -> ReduceM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Left Blocker
b -> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$ Blocker -> Sort' Term -> Blocked (Sort' Term)
forall t a. Blocker -> a -> Blocked' t a
Blocked Blocker
b (Sort' Term -> Blocked (Sort' Term))
-> Sort' Term -> Blocked (Sort' Term)
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Sort' Term -> Sort' Term
forall t. Sort' t -> Sort' t -> Sort' t
FunSort Sort' Term
s1' Sort' Term
s2'
            Right Sort' Term
s -> Sort' Term -> ReduceM (Blocked (Sort' Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Sort' Term
s
        UnivSort Sort' Term
s1 -> Sort' Term -> ReduceM (Blocked (Sort' Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Sort' Term
s1 ReduceM (Blocked (Sort' Term))
-> (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> ReduceM (Blocked (Sort' Term))
forall a b. ReduceM a -> (a -> ReduceM b) -> ReduceM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
          Blocked Blocker
b Sort' Term
s1' -> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$ Blocker -> Sort' Term -> Blocked (Sort' Term)
forall t a. Blocker -> a -> Blocked' t a
Blocked Blocker
b (Sort' Term -> Blocked (Sort' Term))
-> Sort' Term -> Blocked (Sort' Term)
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Sort' Term
forall t. Sort' t -> Sort' t
UnivSort Sort' Term
s1'
          NotBlocked NotBlocked
_ Sort' Term
s1' -> case Sort' Term -> Either Blocker (Sort' Term)
univSort' Sort' Term
s1' of
            Left Blocker
b -> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$ Blocker -> Sort' Term -> Blocked (Sort' Term)
forall t a. Blocker -> a -> Blocked' t a
Blocked Blocker
b (Sort' Term -> Blocked (Sort' Term))
-> Sort' Term -> Blocked (Sort' Term)
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Sort' Term
forall t. Sort' t -> Sort' t
UnivSort Sort' Term
s1'
            Right Sort' Term
s -> Sort' Term -> ReduceM (Blocked (Sort' Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Sort' Term
s
        Univ Univ
u Level' Term
l   -> Sort' Term -> Blocked (Sort' Term)
forall a t. a -> Blocked' t a
notBlocked (Sort' Term -> Blocked (Sort' Term))
-> (Level' Term -> Sort' Term)
-> Level' Term
-> Blocked (Sort' Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Univ -> Level' Term -> Sort' Term
forall t. Univ -> Level' t -> Sort' t
Univ Univ
u (Level' Term -> Blocked (Sort' Term))
-> ReduceM (Level' Term) -> ReduceM (Blocked (Sort' Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level' Term -> ReduceM (Level' Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Level' Term
l
        Inf Univ
_ Integer
_    -> ReduceM (Blocked (Sort' Term))
done
        Sort' Term
SizeUniv   -> ReduceM (Blocked (Sort' Term))
done
        Sort' Term
LockUniv   -> ReduceM (Blocked (Sort' Term))
done
        Sort' Term
LevelUniv  -> ReduceM Bool
-> ReduceM (Blocked (Sort' Term))
-> ReduceM (Blocked (Sort' Term))
-> ReduceM (Blocked (Sort' Term))
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ReduceM Bool
forall (m :: * -> *). HasOptions m => m Bool
isLevelUniverseEnabled ReduceM (Blocked (Sort' Term))
done (ReduceM (Blocked (Sort' Term)) -> ReduceM (Blocked (Sort' Term)))
-> ReduceM (Blocked (Sort' Term)) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$
          Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term)))
-> Blocked (Sort' Term) -> ReduceM (Blocked (Sort' Term))
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Blocked (Sort' Term)
forall a t. a -> Blocked' t a
notBlocked (Integer -> Sort' Term
mkType Integer
0)
        Sort' Term
IntervalUniv -> ReduceM (Blocked (Sort' Term))
done
        MetaS MetaId
x [Elim]
es -> ReduceM (Blocked (Sort' Term))
done
        DefS QName
d [Elim]
es  -> ReduceM (Blocked (Sort' Term))
done -- postulated sorts do not reduce
        DummyS{}   -> ReduceM (Blocked (Sort' Term))
done

instance Reduce Elim where
  reduce' :: Elim -> ReduceM Elim
reduce' (Apply Arg Term
v) = Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Arg Term -> Elim) -> ReduceM (Arg Term) -> ReduceM Elim
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arg Term -> ReduceM (Arg Term)
forall t. Reduce t => t -> ReduceM t
reduce' Arg Term
v
  reduce' (Proj ProjOrigin
o QName
f)= Elim -> ReduceM Elim
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Elim -> ReduceM Elim) -> Elim -> ReduceM Elim
forall a b. (a -> b) -> a -> b
$ ProjOrigin -> QName -> Elim
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
o QName
f
  reduce' (IApply Term
x Term
y Term
v) = Term -> Term -> Term -> Elim
forall a. a -> a -> a -> Elim' a
IApply (Term -> Term -> Term -> Elim)
-> ReduceM Term -> ReduceM (Term -> Term -> Elim)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
x ReduceM (Term -> Term -> Elim)
-> ReduceM Term -> ReduceM (Term -> Elim)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
y ReduceM (Term -> Elim) -> ReduceM Term -> ReduceM Elim
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
v

instance Reduce Level where
  reduce' :: Level' Term -> ReduceM (Level' Term)
reduce'  (Max Integer
m [PlusLevel]
as) = Integer -> [PlusLevel] -> Level' Term
levelMax Integer
m ([PlusLevel] -> Level' Term)
-> ReduceM [PlusLevel] -> ReduceM (Level' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PlusLevel -> ReduceM PlusLevel)
-> [PlusLevel] -> ReduceM [PlusLevel]
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 PlusLevel -> ReduceM PlusLevel
forall t. Reduce t => t -> ReduceM t
reduce' [PlusLevel]
as
  reduceB' :: Level' Term -> ReduceM (Blocked (Level' Term))
reduceB' (Max Integer
m [PlusLevel]
as) = ([PlusLevel] -> Level' Term)
-> Blocked' Term [PlusLevel] -> Blocked (Level' 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 (Integer -> [PlusLevel] -> Level' Term
levelMax Integer
m) (Blocked' Term [PlusLevel] -> Blocked (Level' Term))
-> ([Blocked PlusLevel] -> Blocked' Term [PlusLevel])
-> [Blocked PlusLevel]
-> Blocked (Level' Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Blocked PlusLevel] -> Blocked' Term [PlusLevel]
forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Blocked a) -> Blocked (f a)
blockAny ([Blocked PlusLevel] -> Blocked (Level' Term))
-> ReduceM [Blocked PlusLevel] -> ReduceM (Blocked (Level' Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (PlusLevel -> ReduceM (Blocked PlusLevel))
-> [PlusLevel] -> ReduceM [Blocked PlusLevel]
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 PlusLevel -> ReduceM (Blocked PlusLevel)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' [PlusLevel]
as

instance Reduce PlusLevel where
  reduceB' :: PlusLevel -> ReduceM (Blocked PlusLevel)
reduceB' (Plus Integer
n Term
l) = (Term -> PlusLevel) -> Blocked' Term Term -> Blocked PlusLevel
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Integer -> Term -> PlusLevel
forall t. Integer -> t -> PlusLevel' t
Plus Integer
n) (Blocked' Term Term -> Blocked PlusLevel)
-> ReduceM (Blocked' Term Term) -> ReduceM (Blocked PlusLevel)
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' Term
l

instance (Subst a, Reduce a) => Reduce (Abs a) where
  reduceB' :: Abs a -> ReduceM (Blocked (Abs a))
reduceB' b :: Abs a
b@(Abs [Char]
x a
_) = (a -> Abs a) -> Blocked' Term a -> Blocked (Abs a)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> a -> Abs a
forall a. [Char] -> a -> Abs a
Abs [Char]
x) (Blocked' Term a -> Blocked (Abs a))
-> ReduceM (Blocked' Term a) -> ReduceM (Blocked (Abs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs a
-> (a -> ReduceM (Blocked' Term a)) -> ReduceM (Blocked' Term a)
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs a
b a -> ReduceM (Blocked' Term a)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB'
  reduceB' (NoAbs [Char]
x a
v) = (a -> Abs a) -> Blocked' Term a -> Blocked (Abs a)
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char] -> a -> Abs a
forall a. [Char] -> a -> Abs a
NoAbs [Char]
x) (Blocked' Term a -> Blocked (Abs a))
-> ReduceM (Blocked' Term a) -> ReduceM (Blocked (Abs a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM (Blocked' Term a)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' a
v

-- Lists are never blocked
instance Reduce t => Reduce [t] where
    reduce' :: [t] -> ReduceM [t]
reduce' = (t -> ReduceM t) -> [t] -> ReduceM [t]
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 t -> ReduceM t
forall t. Reduce t => t -> ReduceM t
reduce'

-- Maybes are never blocked
instance Reduce t => Reduce (Maybe t) where
    reduce' :: Maybe t -> ReduceM (Maybe t)
reduce' = (t -> ReduceM t) -> Maybe t -> ReduceM (Maybe t)
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) -> Maybe a -> f (Maybe b)
traverse t -> ReduceM t
forall t. Reduce t => t -> ReduceM t
reduce'

instance Reduce t => Reduce (Arg t) where
    reduce' :: Arg t -> ReduceM (Arg t)
reduce' Arg t
a = case Arg t -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Arg t
a of
      Irrelevant{} -> Arg t -> ReduceM (Arg t)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Arg t
a             -- Don't reduce' irr. args!?
                                           -- Andreas, 2018-03-03, caused #2989.
      Relevance
_ -> (t -> ReduceM t) -> Arg t -> ReduceM (Arg t)
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) -> Arg a -> f (Arg b)
traverse t -> ReduceM t
forall t. Reduce t => t -> ReduceM t
reduce' Arg t
a

    reduceB' :: Arg t -> ReduceM (Blocked (Arg t))
reduceB' Arg t
t = (Blocked' Term t -> Blocked' Term t)
-> Arg (Blocked' Term t) -> Blocked (Arg t)
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) -> Arg a -> f (Arg b)
traverse Blocked' Term t -> Blocked' Term t
forall a. a -> a
id (Arg (Blocked' Term t) -> Blocked (Arg t))
-> ReduceM (Arg (Blocked' Term t)) -> ReduceM (Blocked (Arg t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (t -> ReduceM (Blocked' Term t))
-> Arg t -> ReduceM (Arg (Blocked' Term t))
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) -> Arg a -> f (Arg b)
traverse t -> ReduceM (Blocked' Term t)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Arg t
t

instance Reduce t => Reduce (Dom t) where
    reduce' :: Dom t -> ReduceM (Dom t)
reduce' = (t -> ReduceM t) -> Dom t -> ReduceM (Dom t)
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) -> Dom' Term a -> f (Dom' Term b)
traverse t -> ReduceM t
forall t. Reduce t => t -> ReduceM t
reduce'
    reduceB' :: Dom t -> ReduceM (Blocked (Dom t))
reduceB' Dom t
t = (Blocked' Term t -> Blocked' Term t)
-> Dom' Term (Blocked' Term t) -> Blocked (Dom t)
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) -> Dom' Term a -> f (Dom' Term b)
traverse Blocked' Term t -> Blocked' Term t
forall a. a -> a
id (Dom' Term (Blocked' Term t) -> Blocked (Dom t))
-> ReduceM (Dom' Term (Blocked' Term t))
-> ReduceM (Blocked (Dom t))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (t -> ReduceM (Blocked' Term t))
-> Dom t -> ReduceM (Dom' Term (Blocked' Term t))
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) -> Dom' Term a -> f (Dom' Term b)
traverse t -> ReduceM (Blocked' Term t)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Dom t
t

instance (Reduce a, Reduce b) => Reduce (a,b) where
    reduce' :: (a, b) -> ReduceM (a, b)
reduce' (a
x,b
y)  = (,) (a -> b -> (a, b)) -> ReduceM a -> ReduceM (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Reduce t => t -> ReduceM t
reduce' a
x ReduceM (b -> (a, b)) -> ReduceM b -> ReduceM (a, b)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> ReduceM b
forall t. Reduce t => t -> ReduceM t
reduce' b
y
    reduceB' :: (a, b) -> ReduceM (Blocked (a, b))
reduceB' (a
x,b
y) = do
      x <- a -> ReduceM (Blocked a)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' a
x
      y <- reduceB' y
      let blk = Blocked a -> Blocked' Term ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Blocked a
x Blocked' Term () -> Blocked' Term () -> Blocked' Term ()
forall a. Monoid a => a -> a -> a
`mappend` Blocked b -> Blocked' Term ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Blocked b
y
          xy  = (Blocked a -> a
forall t a. Blocked' t a -> a
ignoreBlocking Blocked a
x , Blocked b -> b
forall t a. Blocked' t a -> a
ignoreBlocking Blocked b
y)
      return $ blk $> xy

instance (Reduce a, Reduce b,Reduce c) => Reduce (a,b,c) where
    reduce' :: (a, b, c) -> ReduceM (a, b, c)
reduce' (a
x,b
y,c
z) = (,,) (a -> b -> c -> (a, b, c))
-> ReduceM a -> ReduceM (b -> c -> (a, b, c))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Reduce t => t -> ReduceM t
reduce' a
x ReduceM (b -> c -> (a, b, c))
-> ReduceM b -> ReduceM (c -> (a, b, c))
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> ReduceM b
forall t. Reduce t => t -> ReduceM t
reduce' b
y ReduceM (c -> (a, b, c)) -> ReduceM c -> ReduceM (a, b, c)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> c -> ReduceM c
forall t. Reduce t => t -> ReduceM t
reduce' c
z
    reduceB' :: (a, b, c) -> ReduceM (Blocked (a, b, c))
reduceB' (a
x,b
y,c
z) = do
      x <- a -> ReduceM (Blocked a)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' a
x
      y <- reduceB' y
      z <- reduceB' z
      let blk = Blocked a -> Blocked' Term ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Blocked a
x Blocked' Term () -> Blocked' Term () -> Blocked' Term ()
forall a. Monoid a => a -> a -> a
`mappend` Blocked b -> Blocked' Term ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Blocked b
y Blocked' Term () -> Blocked' Term () -> Blocked' Term ()
forall a. Monoid a => a -> a -> a
`mappend` Blocked c -> Blocked' Term ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Blocked c
z
          xyz = (Blocked a -> a
forall t a. Blocked' t a -> a
ignoreBlocking Blocked a
x , Blocked b -> b
forall t a. Blocked' t a -> a
ignoreBlocking Blocked b
y , Blocked c -> c
forall t a. Blocked' t a -> a
ignoreBlocking Blocked c
z)
      return $ blk $> xyz

{-# INLINE reduceIApply #-}
reduceIApply :: ReduceM (Blocked Term) -> [Elim] -> ReduceM (Blocked Term)
reduceIApply :: ReduceM (Blocked' Term Term)
-> [Elim] -> ReduceM (Blocked' Term Term)
reduceIApply = (Term -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term)
-> [Elim]
-> ReduceM (Blocked' Term Term)
reduceIApply' Term -> ReduceM (Blocked' Term Term)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB'

{-# INLINE reduceIApply' #-}
reduceIApply' :: (Term -> ReduceM (Blocked Term)) -> ReduceM (Blocked Term) -> [Elim] -> ReduceM (Blocked Term)
reduceIApply' :: (Term -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term)
-> [Elim]
-> ReduceM (Blocked' Term Term)
reduceIApply' Term -> ReduceM (Blocked' Term Term)
red ReduceM (Blocked' Term Term)
d (IApply Term
x Term
y Term
r : [Elim]
es) = do
  view <- ReduceM (Term -> IntervalView)
forall (m :: * -> *). HasBuiltins m => m (Term -> IntervalView)
intervalView' -- András: TODO opt
  r <- reduceB' r
  -- We need to propagate the blocking information so that e.g.
  -- we postpone "someNeutralPath ?0 = a" rather than fail.
  case view (ignoreBlocking r) of
   IntervalView
IZero -> Term -> ReduceM (Blocked' Term Term)
red (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
applyE Term
x [Elim]
es)
   IntervalView
IOne  -> Term -> ReduceM (Blocked' Term Term)
red (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
applyE Term
y [Elim]
es)
   IntervalView
_     -> (Blocked' Term Term -> Blocked' Term Term)
-> ReduceM (Blocked' Term Term) -> ReduceM (Blocked' Term 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 Term -> Blocked' Term Term
forall a b. Blocked' Term a -> Blocked' Term b -> Blocked' Term a
forall (f :: * -> *) a b. Applicative f => f a -> f b -> f a
<* Blocked' Term Term
r) ((Term -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term)
-> [Elim]
-> ReduceM (Blocked' Term Term)
reduceIApply' Term -> ReduceM (Blocked' Term Term)
red ReduceM (Blocked' Term Term)
d [Elim]
es)
reduceIApply' Term -> ReduceM (Blocked' Term Term)
red ReduceM (Blocked' Term Term)
d (Elim
_ : [Elim]
es) = (Term -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term)
-> [Elim]
-> ReduceM (Blocked' Term Term)
reduceIApply' Term -> ReduceM (Blocked' Term Term)
red ReduceM (Blocked' Term Term)
d [Elim]
es
reduceIApply' Term -> ReduceM (Blocked' Term Term)
_   ReduceM (Blocked' Term Term)
d [] = ReduceM (Blocked' Term Term)
d

instance Reduce DeBruijnPattern where
  reduceB' :: DeBruijnPattern -> ReduceM (Blocked DeBruijnPattern)
reduceB' (DotP PatternInfo
o Term
v) = (Term -> DeBruijnPattern)
-> Blocked' Term Term -> Blocked DeBruijnPattern
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (PatternInfo -> Term -> DeBruijnPattern
forall x. PatternInfo -> Term -> Pattern' x
DotP PatternInfo
o) (Blocked' Term Term -> Blocked DeBruijnPattern)
-> ReduceM (Blocked' Term Term)
-> ReduceM (Blocked DeBruijnPattern)
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' Term
v
  reduceB' DeBruijnPattern
p          = Blocked DeBruijnPattern -> ReduceM (Blocked DeBruijnPattern)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked DeBruijnPattern -> ReduceM (Blocked DeBruijnPattern))
-> Blocked DeBruijnPattern -> ReduceM (Blocked DeBruijnPattern)
forall a b. (a -> b) -> a -> b
$ DeBruijnPattern -> Blocked DeBruijnPattern
forall a t. a -> Blocked' t a
notBlocked DeBruijnPattern
p

instance Reduce Term where
  reduceB' :: Term -> ReduceM (Blocked' Term Term)
reduceB' = {-# SCC "reduce'<Term>" #-} Term -> ReduceM (Blocked' Term Term)
maybeFastReduceTerm

shouldTryFastReduce :: ReduceM Bool
shouldTryFastReduce :: ReduceM Bool
shouldTryFastReduce = PragmaOptions -> Bool
optFastReduce (PragmaOptions -> Bool) -> ReduceM PragmaOptions -> ReduceM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReduceM PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions

maybeFastReduceTerm :: Term -> ReduceM (Blocked Term)
maybeFastReduceTerm :: Term -> ReduceM (Blocked' Term Term)
maybeFastReduceTerm Term
v = do
  let maybeFast :: Term -> ReduceM (Blocked' Term Term)
maybeFast Term
v = ReduceM Bool
-> ReduceM (Blocked' Term Term)
-> ReduceM (Blocked' Term Term)
-> ReduceM (Blocked' Term Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ReduceM Bool
shouldTryFastReduce (Term -> ReduceM (Blocked' Term Term)
fastReduce Term
v) (Term -> ReduceM (Blocked' Term Term)
slowReduceTerm Term
v)
  case Term
v of
    v :: Term
v@Def{}       -> Term -> ReduceM (Blocked' Term Term)
maybeFast Term
v
    v :: Term
v@Con{}       -> Term -> ReduceM (Blocked' Term Term)
maybeFast Term
v
    v :: Term
v@(MetaV MetaId
x [Elim]
_) -> ReduceM Bool
-> ReduceM (Blocked' Term Term)
-> ReduceM (Blocked' Term Term)
-> ReduceM (Blocked' Term Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (MetaInstantiation -> Bool
isOpenMeta (MetaInstantiation -> Bool)
-> ReduceM MetaInstantiation -> ReduceM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MetaId -> ReduceM MetaInstantiation
forall (m :: * -> *).
ReadTCState m =>
MetaId -> m MetaInstantiation
lookupMetaInstantiation MetaId
x)
                         (Blocked' Term Term -> ReduceM (Blocked' Term Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked' Term Term -> ReduceM (Blocked' Term Term))
-> Blocked' Term Term -> ReduceM (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$! MetaId -> Term -> Blocked' Term Term
forall a t. MetaId -> a -> Blocked' t a
blocked MetaId
x Term
v)
                         (Term -> ReduceM (Blocked' Term Term)
maybeFast Term
v)
    Term
v             -> Term -> ReduceM (Blocked' Term Term)
slowReduceTerm Term
v

  -- let tryFast = case v of
  --                 Def{}   -> True
  --                 Con{}   -> True
  --                 MetaV{} -> True
  --                 _       -> False
  -- if not tryFast then slowReduceTerm v
  --                else
  --   case v of
  --     MetaV x _ -> ifM (isOpen x) (return $ blocked x v) (maybeFast v)
  --     _         -> maybeFast v
  -- where
  --   isOpen x = isOpenMeta <$> lookupMetaInstantiation x
  --   maybeFast v = ifM shouldTryFastReduce (fastReduce v) (slowReduceTerm v)

slowReduceTerm :: Term -> ReduceM (Blocked Term)
slowReduceTerm :: Term -> ReduceM (Blocked' Term Term)
slowReduceTerm Term
v = do
    v <- Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
v
    let done = Blocked' Term Term -> ReduceM (Blocked' Term Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked' Term Term -> ReduceM (Blocked' Term Term))
-> Blocked' Term Term -> ReduceM (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$ Term -> Blocked' Term Term
forall a t. a -> Blocked' t a
notBlocked Term
v
    case v of
--    Andreas, 2012-11-05 not reducing meta args does not destroy anything
--    and seems to save 2% sec on the standard library
--      MetaV x args -> notBlocked . MetaV x <$> reduce' args
      MetaV MetaId
x [Elim]
es -> ReduceM (Blocked' Term Term)
-> [Elim] -> ReduceM (Blocked' Term Term)
reduceIApply (Blocked' Term Term -> ReduceM (Blocked' Term Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked' Term Term -> ReduceM (Blocked' Term Term))
-> Blocked' Term Term -> ReduceM (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$! MetaId -> Term -> Blocked' Term Term
forall a t. MetaId -> a -> Blocked' t a
blocked MetaId
x Term
v) [Elim]
es
      Def QName
f [Elim]
es   -> (ReduceM (Blocked' Term Term)
 -> [Elim] -> ReduceM (Blocked' Term Term))
-> [Elim]
-> ReduceM (Blocked' Term Term)
-> ReduceM (Blocked' Term Term)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReduceM (Blocked' Term Term)
-> [Elim] -> ReduceM (Blocked' Term Term)
reduceIApply [Elim]
es (ReduceM (Blocked' Term Term) -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term) -> ReduceM (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$ (Term -> ReduceM (Blocked' Term Term))
-> Term -> QName -> [Elim] -> ReduceM (Blocked' Term Term)
unfoldDefinitionE Term -> ReduceM (Blocked' Term Term)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (QName -> [Elim] -> Term
Def QName
f []) QName
f [Elim]
es
      Con ConHead
c ConInfo
ci [Elim]
es -> do
          -- Constructors can reduce' when they come from an
          -- instantiated module.
          -- also reduce when they are path constructors
          v <- (ReduceM (Blocked' Term Term)
 -> [Elim] -> ReduceM (Blocked' Term Term))
-> [Elim]
-> ReduceM (Blocked' Term Term)
-> ReduceM (Blocked' Term Term)
forall a b c. (a -> b -> c) -> b -> a -> c
flip ReduceM (Blocked' Term Term)
-> [Elim] -> ReduceM (Blocked' Term Term)
reduceIApply [Elim]
es
                 (ReduceM (Blocked' Term Term) -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term) -> ReduceM (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$ (Term -> ReduceM (Blocked' Term Term))
-> Term -> QName -> [Elim] -> ReduceM (Blocked' Term Term)
unfoldDefinitionE Term -> ReduceM (Blocked' Term Term)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' (ConHead -> ConInfo -> [Elim] -> Term
Con ConHead
c ConInfo
ci []) (ConHead -> QName
conName ConHead
c) [Elim]
es
          traverse reduceNat v
      Sort Sort' Term
s   -> ReduceM (Blocked' Term Term)
done
      Level Level' Term
l  -> ReduceM Bool
-> ReduceM (Blocked' Term Term)
-> ReduceM (Blocked' Term Term)
-> ReduceM (Blocked' Term Term)
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (AllowedReduction -> SmallSet AllowedReduction -> Bool
forall a. SmallSetElement a => a -> SmallSet a -> Bool
SmallSet.member AllowedReduction
LevelReductions (SmallSet AllowedReduction -> Bool)
-> ReduceM (SmallSet AllowedReduction) -> ReduceM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' TCEnv (SmallSet AllowedReduction)
-> ReduceM (SmallSet AllowedReduction)
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (SmallSet AllowedReduction -> f (SmallSet AllowedReduction))
-> TCEnv -> f TCEnv
Lens' TCEnv (SmallSet AllowedReduction)
eAllowedReductions)
                    {- then -} ((Level' Term -> Term)
-> Blocked (Level' Term) -> Blocked' Term 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 Level' Term -> Term
levelTm (Blocked (Level' Term) -> Blocked' Term Term)
-> ReduceM (Blocked (Level' Term)) -> ReduceM (Blocked' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level' Term -> ReduceM (Blocked (Level' Term))
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Level' Term
l)
                    {- else -} ReduceM (Blocked' Term Term)
done
      Pi Dom' Term Type
_ Abs Type
_     -> ReduceM (Blocked' Term Term)
done
      Lit Literal
_      -> ReduceM (Blocked' Term Term)
done
      Var Int
x [Elim]
es   -> ReduceM Bool
forall (m :: * -> *). HasOptions m => m Bool
localRewritingOption ReduceM Bool
-> (Bool -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term)
forall a b. ReduceM a -> (a -> ReduceM b) -> ReduceM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
                      Bool
True  -> ReduceM (Blocked' Term Term)
-> [Elim] -> ReduceM (Blocked' Term Term)
reduceIApply (Int -> [Elim] -> ReduceM (Blocked' Term Term)
rewriteVarApp Int
x [Elim]
es) [Elim]
es
                      Bool
False -> ReduceM (Blocked' Term Term)
-> [Elim] -> ReduceM (Blocked' Term Term)
reduceIApply ReduceM (Blocked' Term Term)
done [Elim]
es
      Lam ArgInfo
_ Abs Term
_    -> ReduceM (Blocked' Term Term)
done
      DontCare Term
_ -> ReduceM (Blocked' Term Term)
done
      Dummy{}    -> ReduceM (Blocked' Term Term)
done
    where
      -- NOTE: reduceNat can traverse the entire term.
      reduceNat :: Term -> ReduceM Term
reduceNat v :: Term
v@(Con ConHead
c ConInfo
ci []) = do
        mz  <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
builtinZero
        case v of
          Term
_ | Term -> Maybe Term
forall a. a -> Maybe a
Just Term
v Maybe Term -> Maybe Term -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Term
mz  -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> ReduceM Term) -> Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ Literal -> Term
Lit (Literal -> Term) -> Literal -> Term
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
LitNat Integer
0
          Term
_                 -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
      reduceNat v :: Term
v@(Con ConHead
c ConInfo
ci [Apply Arg Term
a]) | Arg Term -> Bool
forall a. LensHiding a => a -> Bool
visible Arg Term
a Bool -> Bool -> Bool
&& Arg Term -> Bool
forall a. LensRelevance a => a -> Bool
isRelevant Arg Term
a = do
        ms  <- BuiltinId -> ReduceM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe Term)
getBuiltin' BuiltinId
builtinSuc
        case v of
          Term
_ | Term -> Maybe Term
forall a. a -> Maybe a
Just (ConHead -> ConInfo -> [Elim] -> Term
Con ConHead
c ConInfo
ci []) Maybe Term -> Maybe Term -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe Term
ms -> Term -> Term
inc (Term -> Term) -> ReduceM Term -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a)
          Term
_                            -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
          where
            inc :: Term -> Term
inc = \case
              Lit (LitNat Integer
n) -> Literal -> Term
Lit (Literal -> Term) -> Literal -> Term
forall a b. (a -> b) -> a -> b
$ Integer -> Literal
LitNat (Integer -> Literal) -> Integer -> Literal
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1
              Term
w              -> let !arg :: Elim
arg = Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Arg Term -> Elim) -> Arg Term -> Elim
forall a b. (a -> b) -> a -> b
$! Term -> Arg Term
forall a. a -> Arg a
defaultArg Term
w in ConHead -> ConInfo -> [Elim] -> Term
Con ConHead
c ConInfo
ci [Elim
arg]
      reduceNat Term
v = Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v

rewriteVarApp :: Nat -> Elims -> ReduceM (Blocked Term)
rewriteVarApp :: Int -> [Elim] -> ReduceM (Blocked' Term Term)
rewriteVarApp Int
x [Elim]
es = do
  r <- Int -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
rewriteVarAppStep Int
x [Elim]
es
  case r of
    NoReduction Blocked' Term Term
v    -> Blocked' Term Term -> ReduceM (Blocked' Term Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocked' Term Term
v
    YesReduction Simplification
_ Term
v -> Term -> ReduceM (Blocked' Term Term)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB' Term
v

rewriteVarAppStep :: Nat -> Elims -> ReduceM (Reduced (Blocked Term) Term)
rewriteVarAppStep :: Int -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
rewriteVarAppStep Int
x [Elim]
es = do
  rewr <- Int -> ReduceM RewriteRules
forall (m :: * -> *). HasConstInfo m => Int -> m RewriteRules
getAllRewriteRulesForVarHead Int
x
  when (not $ null rewr) $
    reportSDoc "rewriting" 30 $
      "Trying to rewrite variable application" <+> prettyTCM (Var x es)
  rewrite (NotBlocked ReallyNotBlocked ())
          (Var x) rewr es

-- Andreas, 2013-03-20 recursive invocations of unfoldCorecursion
-- need also to instantiate metas, see Issue 826.
unfoldCorecursionE :: Elim -> ReduceM (Blocked Elim)
unfoldCorecursionE :: Elim -> ReduceM (Blocked Elim)
unfoldCorecursionE (Proj ProjOrigin
o QName
p)           = Elim -> Blocked Elim
forall a t. a -> Blocked' t a
notBlocked (Elim -> Blocked Elim) -> (QName -> Elim) -> QName -> Blocked Elim
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjOrigin -> QName -> Elim
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
o (QName -> Blocked Elim) -> ReduceM QName -> ReduceM (Blocked Elim)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ReduceM QName
forall (m :: * -> *).
(HasCallStack, HasConstInfo m) =>
QName -> m QName
getOriginalProjection QName
p
unfoldCorecursionE (Apply (Arg ArgInfo
info Term
v)) = (Term -> Elim) -> Blocked' Term Term -> Blocked Elim
forall a b. (a -> b) -> Blocked' Term a -> Blocked' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Arg Term -> Elim) -> (Term -> Arg Term) -> Term -> Elim
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info) (Blocked' Term Term -> Blocked Elim)
-> ReduceM (Blocked' Term Term) -> ReduceM (Blocked Elim)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
  Term -> ReduceM (Blocked' Term Term)
unfoldCorecursion Term
v
unfoldCorecursionE (IApply Term
x Term
y Term
r) = do -- TODO check if this makes sense
   [x,y,r] <- (Term -> ReduceM (Blocked' Term Term))
-> [Term] -> ReduceM [Blocked' Term 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 -> ReduceM (Blocked' Term Term)
unfoldCorecursion [Term
x,Term
y,Term
r]
   return $ IApply <$> x <*> y <*> r

unfoldCorecursion :: Term -> ReduceM (Blocked Term)
unfoldCorecursion :: Term -> ReduceM (Blocked' Term Term)
unfoldCorecursion Term
v = do
  v <- Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
v
  case v of
    Def QName
f [Elim]
es -> (Term -> ReduceM (Blocked' Term Term))
-> Term -> QName -> [Elim] -> ReduceM (Blocked' Term Term)
unfoldDefinitionE Term -> ReduceM (Blocked' Term Term)
unfoldCorecursion (QName -> [Elim] -> Term
Def QName
f []) QName
f [Elim]
es
    Term
_ -> Term -> ReduceM (Blocked' Term Term)
slowReduceTerm Term
v

-- | If the first argument is 'True', then a single delayed clause may
-- be unfolded.
unfoldDefinition ::
  (Term -> ReduceM (Blocked Term)) ->
  Term -> QName -> Args -> ReduceM (Blocked Term)
unfoldDefinition :: (Term -> ReduceM (Blocked' Term Term))
-> Term -> QName -> Args -> ReduceM (Blocked' Term Term)
unfoldDefinition Term -> ReduceM (Blocked' Term Term)
keepGoing Term
v QName
f Args
args =
  (Term -> ReduceM (Blocked' Term Term))
-> Term -> QName -> [Elim] -> ReduceM (Blocked' Term Term)
unfoldDefinitionE Term -> ReduceM (Blocked' Term Term)
keepGoing Term
v QName
f ((Arg Term -> Elim) -> Args -> [Elim]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply Args
args)

{-# INLINE unfoldDefinitionE #-}
unfoldDefinitionE ::
  (Term -> ReduceM (Blocked Term)) ->
  Term -> QName -> Elims -> ReduceM (Blocked Term)
unfoldDefinitionE :: (Term -> ReduceM (Blocked' Term Term))
-> Term -> QName -> [Elim] -> ReduceM (Blocked' Term Term)
unfoldDefinitionE Term -> ReduceM (Blocked' Term Term)
keepGoing Term
v QName
f [Elim]
es = do
  r <- Term
-> QName -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
unfoldDefinitionStep Term
v QName
f [Elim]
es
  case r of
    NoReduction Blocked' Term Term
v    -> Blocked' Term Term -> ReduceM (Blocked' Term Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Blocked' Term Term
v
    YesReduction Simplification
_ Term
v -> Term -> ReduceM (Blocked' Term Term)
keepGoing Term
v

unfoldDefinition' ::
  (Simplification -> Term -> ReduceM (Simplification, Blocked Term)) ->
  Term -> QName -> Elims -> ReduceM (Simplification, Blocked Term)
unfoldDefinition' :: (Simplification
 -> Term -> ReduceM (Simplification, Blocked' Term Term))
-> Term
-> QName
-> [Elim]
-> ReduceM (Simplification, Blocked' Term Term)
unfoldDefinition' Simplification
-> Term -> ReduceM (Simplification, Blocked' Term Term)
keepGoing Term
v0 QName
f [Elim]
es = do
  r <- Term
-> QName -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
unfoldDefinitionStep Term
v0 QName
f [Elim]
es
  case r of
    NoReduction Blocked' Term Term
v       -> (Simplification, Blocked' Term Term)
-> ReduceM (Simplification, Blocked' Term Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Simplification
NoSimplification, Blocked' Term Term
v)
    YesReduction Simplification
simp Term
v -> Simplification
-> Term -> ReduceM (Simplification, Blocked' Term Term)
keepGoing Simplification
simp Term
v

unfoldDefinitionStep :: Term -> QName -> Elims -> ReduceM (Reduced (Blocked Term) Term)
unfoldDefinitionStep :: Term
-> QName -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
unfoldDefinitionStep Term
v0 QName
f [Elim]
es =
  {-# SCC "reduceDef" #-} do
  [Char]
-> Int
-> TCMT IO Doc
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m a -> m a
traceSDoc [Char]
"tc.reduce" Int
90 (TCMT IO Doc
"unfoldDefinitionStep v0" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v0) (ReduceM (Reduced (Blocked' Term Term) Term)
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ do
  info    <- QName -> ReduceM Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
f
  rewr    <- getAllRewriteRulesForDefHead f
  allowed <- viewTC eAllowedReductions
  prp     <- runBlocked $ isPropM $ defType info
  defOk   <- shouldReduceDef f
  let def = Definition -> Defn
theDef Definition
info
      v   = Term
v0 Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [Elim]
es
      -- Non-terminating functions
      -- (i.e., those that failed the termination check)
      -- and delayed definitions
      -- are not unfolded unless explicitly permitted.

      dontUnfold =
          (Definition -> Bool
defNonterminating Definition
info Bool -> Bool -> Bool
&& AllowedReduction -> SmallSet AllowedReduction -> Bool
forall a. SmallSetElement a => a -> SmallSet a -> Bool
SmallSet.notMember AllowedReduction
NonTerminatingReductions SmallSet AllowedReduction
allowed)
        -- defTerminationUnconfirmed info && SmallSet.notMember UnconfirmedReductions allowed
        Bool -> Bool -> Bool
|| (Either Blocker Bool
prp Either Blocker Bool -> Either Blocker Bool -> Bool
forall a. Eq a => a -> a -> Bool
== Bool -> Either Blocker Bool
forall a b. b -> Either a b
Right Bool
True)
        Bool -> Bool -> Bool
|| (Definition -> Bool
forall a. LensRelevance a => a -> Bool
isIrrelevant Definition
info)
        Bool -> Bool -> Bool
|| (Bool -> Bool
not Bool
defOk)

  copatterns <- defCopatternLHS f info

  case def of
    Constructor{conSrcCon :: Defn -> ConHead
conSrcCon = ConHead
c} -> do
      let hd :: [Elim] -> Term
hd = ConHead -> ConInfo -> [Elim] -> Term
Con (ConHead
c ConHead -> QName -> ConHead
forall t u. (SetRange t, HasRange u) => t -> u -> t
`withRangeOf` QName
f) ConInfo
ConOSystem
      Blocked' Term ()
-> ([Elim] -> Term)
-> RewriteRules
-> [Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
rewrite (NotBlocked -> () -> Blocked' Term ()
forall t a. NotBlocked' t -> a -> Blocked' t a
NotBlocked NotBlocked
forall t. NotBlocked' t
ReallyNotBlocked ()) [Elim] -> Term
hd RewriteRules
rewr [Elim]
es
    Primitive{primAbstr :: Defn -> IsAbstract
primAbstr = IsAbstract
ConcreteDef, primName :: Defn -> PrimitiveId
primName = PrimitiveId
x, primClauses :: Defn -> [Clause]
primClauses = [Clause]
cls} -> do
      pf <- PrimFun -> Maybe PrimFun -> PrimFun
forall a. a -> Maybe a -> a
fromMaybe PrimFun
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe PrimFun -> PrimFun)
-> ReduceM (Maybe PrimFun) -> ReduceM PrimFun
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> PrimitiveId -> ReduceM (Maybe PrimFun)
forall (m :: * -> *).
HasBuiltins m =>
PrimitiveId -> m (Maybe PrimFun)
getPrimitive' PrimitiveId
x
      if FunctionReductions `SmallSet.member` allowed
        then reducePrimitive x v0 f es pf dontUnfold
                             cls (defCompiled info) rewr
        else noReduction $ notBlocked v
    PrimitiveSort{ primSortSort :: Defn -> Sort' Term
primSortSort = Sort' Term
s } -> Simplification
-> Term -> ReduceM (Reduced (Blocked' Term Term) Term)
forall {m :: * -> *} {yes} {no}.
Monad m =>
Simplification -> yes -> m (Reduced no yes)
yesReduction Simplification
NoSimplification (Term -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Term -> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Term
Sort Sort' Term
s Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [Elim]
es

    Defn
_  -> do
      if
             (AllowedReduction
RecursiveReductions AllowedReduction -> SmallSet AllowedReduction -> Bool
forall a. SmallSetElement a => a -> SmallSet a -> Bool
`SmallSet.member` SmallSet AllowedReduction
allowed)
          Bool -> Bool -> Bool
|| (Maybe Projection -> Bool
forall a. Maybe a -> Bool
isJust (Defn -> Maybe Projection
isProjection_ Defn
def) Bool -> Bool -> Bool
&& AllowedReduction
ProjectionReductions AllowedReduction -> SmallSet AllowedReduction -> Bool
forall a. SmallSetElement a => a -> SmallSet a -> Bool
`SmallSet.member` SmallSet AllowedReduction
allowed)
              -- Includes projection-like and irrelevant projections.
              -- Note: irrelevant projections lead to @dontUnfold@ and
              -- so are not actually unfolded.
          Bool -> Bool -> Bool
|| (Defn -> Bool
isInlineFun Defn
def Bool -> Bool -> Bool
&& AllowedReduction
InlineReductions AllowedReduction -> SmallSet AllowedReduction -> Bool
forall a. SmallSetElement a => a -> SmallSet a -> Bool
`SmallSet.member` SmallSet AllowedReduction
allowed)
          Bool -> Bool -> Bool
|| (Defn -> Bool
definitelyNonRecursive_ Defn
def Bool -> Bool -> Bool
&& [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
or
               [ Bool
copatterns Bool -> Bool -> Bool
&& AllowedReduction
CopatternReductions AllowedReduction -> SmallSet AllowedReduction -> Bool
forall a. SmallSetElement a => a -> SmallSet a -> Bool
`SmallSet.member` SmallSet AllowedReduction
allowed
               , AllowedReduction
FunctionReductions AllowedReduction -> SmallSet AllowedReduction -> Bool
forall a. SmallSetElement a => a -> SmallSet a -> Bool
`SmallSet.member` SmallSet AllowedReduction
allowed
               ])
        then
          Term
-> QName
-> [MaybeReduced Elim]
-> Bool
-> [Clause]
-> Maybe CompiledClauses
-> RewriteRules
-> ReduceM (Reduced (Blocked' Term Term) Term)
reduceNormalE Term
v0 QName
f ((Elim -> MaybeReduced Elim) -> [Elim] -> [MaybeReduced Elim]
forall a b. (a -> b) -> [a] -> [b]
map' Elim -> MaybeReduced Elim
forall a. a -> MaybeReduced a
notReduced [Elim]
es) Bool
dontUnfold
                       (Definition -> [Clause]
defClauses Definition
info) (Definition -> Maybe CompiledClauses
defCompiled Definition
info) RewriteRules
rewr
        else Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term)
forall {no} {yes}. no -> ReduceM (Reduced no yes)
noReduction (Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Blocked' Term Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ Term -> Blocked' Term Term
forall a t. a -> Blocked' t a
notBlocked Term
v  -- Andrea(s), 2014-12-05 OK?

  where
    noReduction :: no -> ReduceM (Reduced no yes)
noReduction    = Reduced no yes -> ReduceM (Reduced no yes)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced no yes -> ReduceM (Reduced no yes))
-> (no -> Reduced no yes) -> no -> ReduceM (Reduced no yes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. no -> Reduced no yes
forall no yes. no -> Reduced no yes
NoReduction
    yesReduction :: Simplification -> yes -> m (Reduced no yes)
yesReduction Simplification
s = Reduced no yes -> m (Reduced no yes)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced no yes -> m (Reduced no yes))
-> (yes -> Reduced no yes) -> yes -> m (Reduced no yes)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Simplification -> yes -> Reduced no yes
forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
s
    reducePrimitive :: PrimitiveId
-> Term
-> QName
-> [Elim]
-> PrimFun
-> Bool
-> [Clause]
-> Maybe CompiledClauses
-> RewriteRules
-> ReduceM (Reduced (Blocked' Term Term) Term)
reducePrimitive PrimitiveId
x Term
v0 QName
f [Elim]
es PrimFun
pf Bool
dontUnfold [Clause]
cls Maybe CompiledClauses
mcc RewriteRules
rewr
      | [Elim] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Elim]
es Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
ar
                  = Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term)
forall {no} {yes}. no -> ReduceM (Reduced no yes)
noReduction (Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Blocked' Term Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ NotBlocked -> Term -> Blocked' Term Term
forall t a. NotBlocked' t -> a -> Blocked' t a
NotBlocked NotBlocked
forall t. NotBlocked' t
Underapplied (Term -> Blocked' Term Term) -> Term -> Blocked' Term Term
forall a b. (a -> b) -> a -> b
$ Term
v0 Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [Elim]
es -- not fully applied
      | Bool
otherwise = {-# SCC "reducePrimitive" #-} do
          let ([Elim]
es1,[Elim]
es2) = Int -> [Elim] -> ([Elim], [Elim])
forall a. Int -> [a] -> ([a], [a])
splitAt' Int
ar [Elim]
es
              args1 :: Args
args1     = Args -> Maybe Args -> Args
forall a. a -> Maybe a -> a
fromMaybe Args
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Args -> Args) -> Maybe Args -> Args
forall a b. (a -> b) -> a -> b
$ (Elim -> Maybe (Arg Term)) -> [Elim] -> Maybe Args
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 Elim -> Maybe (Arg Term)
forall a. Elim' a -> Maybe (Arg a)
isApplyElim [Elim]
es1
          r <- PrimFun -> Args -> Int -> ReduceM (Reduced MaybeReducedArgs Term)
primFunImplementation PrimFun
pf Args
args1 ([Elim] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Elim]
es2)
          case r of
            NoReduction MaybeReducedArgs
args1' -> do
              let es1' :: [MaybeReduced Elim]
es1' = (MaybeReduced (Arg Term) -> MaybeReduced Elim)
-> MaybeReducedArgs -> [MaybeReduced Elim]
forall a b. (a -> b) -> [a] -> [b]
map' ((Arg Term -> Elim) -> MaybeReduced (Arg Term) -> MaybeReduced Elim
forall a b. (a -> b) -> MaybeReduced a -> MaybeReduced b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply) MaybeReducedArgs
args1'
              if [Clause] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Clause]
cls Bool -> Bool -> Bool
&& RewriteRules -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null RewriteRules
rewr then do
                Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term)
forall {no} {yes}. no -> ReduceM (Reduced no yes)
noReduction (Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Blocked' Term Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
applyE (QName -> [Elim] -> Term
Def QName
f []) ([Elim] -> Term) -> Blocked' Term [Elim] -> Blocked' Term Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
                  [Blocked Elim] -> Blocked' Term [Elim]
forall (f :: * -> *) a.
(Functor f, Foldable f) =>
f (Blocked a) -> Blocked (f a)
blockAll ([Blocked Elim] -> Blocked' Term [Elim])
-> [Blocked Elim] -> Blocked' Term [Elim]
forall a b. (a -> b) -> a -> b
$ (MaybeReduced Elim -> Blocked Elim)
-> [MaybeReduced Elim] -> [Blocked Elim]
forall a b. (a -> b) -> [a] -> [b]
map' MaybeReduced Elim -> Blocked Elim
forall t. MaybeReduced t -> Blocked t
mredToBlocked [MaybeReduced Elim]
es1' [Blocked Elim] -> [Blocked Elim] -> [Blocked Elim]
forall a. [a] -> [a] -> [a]
++! (Elim -> Blocked Elim) -> [Elim] -> [Blocked Elim]
forall a b. (a -> b) -> [a] -> [b]
map' Elim -> Blocked Elim
forall a t. a -> Blocked' t a
notBlocked [Elim]
es2
               else
                Term
-> QName
-> [MaybeReduced Elim]
-> Bool
-> [Clause]
-> Maybe CompiledClauses
-> RewriteRules
-> ReduceM (Reduced (Blocked' Term Term) Term)
reduceNormalE Term
v0 QName
f ([MaybeReduced Elim]
es1' [MaybeReduced Elim] -> [MaybeReduced Elim] -> [MaybeReduced Elim]
forall a. [a] -> [a] -> [a]
++! (Elim -> MaybeReduced Elim) -> [Elim] -> [MaybeReduced Elim]
forall a b. (a -> b) -> [a] -> [b]
map' Elim -> MaybeReduced Elim
forall a. a -> MaybeReduced a
notReduced [Elim]
es2) Bool
dontUnfold [Clause]
cls Maybe CompiledClauses
mcc RewriteRules
rewr
            YesReduction Simplification
simpl Term
v -> Simplification
-> Term -> ReduceM (Reduced (Blocked' Term Term) Term)
forall {m :: * -> *} {yes} {no}.
Monad m =>
Simplification -> yes -> m (Reduced no yes)
yesReduction Simplification
simpl (Term -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Term -> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ Term
v Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [Elim]
es2
      where
          ar :: Int
ar  = PrimFun -> Int
primFunArity PrimFun
pf

          mredToBlocked :: MaybeReduced t -> Blocked t
          mredToBlocked :: forall t. MaybeReduced t -> Blocked t
mredToBlocked (MaybeRed IsReduced
NotReduced  t
e) = t -> Blocked' Term t
forall a t. a -> Blocked' t a
notBlocked t
e
          mredToBlocked (MaybeRed (Reduced Blocked' Term ()
b) t
e) = t
e t -> Blocked' Term () -> Blocked' Term t
forall a b. a -> Blocked' Term b -> Blocked' Term a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Blocked' Term ()
b

    reduceNormalE ::
         Term -> QName -> [MaybeReduced Elim] -> Bool -> [Clause]
      -> Maybe CompiledClauses -> RewriteRules
      -> ReduceM (Reduced (Blocked Term) Term)
    reduceNormalE :: Term
-> QName
-> [MaybeReduced Elim]
-> Bool
-> [Clause]
-> Maybe CompiledClauses
-> RewriteRules
-> ReduceM (Reduced (Blocked' Term Term) Term)
reduceNormalE Term
v0 QName
f [MaybeReduced Elim]
es Bool
dontUnfold [Clause]
def Maybe CompiledClauses
mcc RewriteRules
rewr = {-# SCC "reduceNormal" #-} do
      [Char]
-> Int
-> TCMT IO Doc
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m a -> m a
traceSDoc [Char]
"tc.reduce" Int
90 (TCMT IO Doc
"reduceNormalE v0 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v0) (ReduceM (Reduced (Blocked' Term Term) Term)
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ do
      case ([Clause]
def,RewriteRules
rewr) of
        ([Clause], RewriteRules)
_ | Bool
dontUnfold -> [Char]
-> Int
-> [Char]
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Int -> [Char] -> m a -> m a
traceSLn [Char]
"tc.reduce" Int
90 [Char]
"reduceNormalE: don't unfold (non-terminating or delayed)" (ReduceM (Reduced (Blocked' Term Term) Term)
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$
                          ReduceM (Reduced (Blocked' Term Term) Term)
defaultResult -- non-terminating or delayed
        ([],[])        -> [Char]
-> Int
-> [Char]
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Int -> [Char] -> m a -> m a
traceSLn [Char]
"tc.reduce" Int
90 [Char]
"reduceNormalE: no clauses or rewrite rules" (ReduceM (Reduced (Blocked' Term Term) Term)
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ do
          -- no definition for head
          (Definition -> Blocked' Term ()
defBlocked (Definition -> Blocked' Term ())
-> ReduceM Definition -> ReduceM (Blocked' Term ())
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ReduceM Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
f) ReduceM (Blocked' Term ())
-> (Blocked' Term ()
    -> ReduceM (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. ReduceM a -> (a -> ReduceM b) -> ReduceM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
            Blocked{}    -> Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term)
forall {no} {yes}. no -> ReduceM (Reduced no yes)
noReduction (Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Blocked' Term Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ Blocker -> Term -> Blocked' Term Term
forall t a. Blocker -> a -> Blocked' t a
Blocked (QName -> Blocker
UnblockOnDef QName
f) Term
vfull
            NotBlocked{} -> ReduceM (Reduced (Blocked' Term Term) Term)
defaultResult
        ([Clause]
cls,RewriteRules
rewr)     -> do
          ev <- QName
-> Term
-> [Clause]
-> Maybe CompiledClauses
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE_ QName
f Term
v0 [Clause]
cls Maybe CompiledClauses
mcc RewriteRules
rewr [MaybeReduced Elim]
es
          debugReduce ev
          return ev
      where
      defaultResult :: ReduceM (Reduced (Blocked' Term Term) Term)
defaultResult = Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term)
forall {no} {yes}. no -> ReduceM (Reduced no yes)
noReduction (Blocked' Term Term -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Blocked' Term Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ NotBlocked -> Term -> Blocked' Term Term
forall t a. NotBlocked' t -> a -> Blocked' t a
NotBlocked NotBlocked
forall t. NotBlocked' t
ReallyNotBlocked Term
vfull
      vfull :: Term
vfull         = Term
v0 Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` (MaybeReduced Elim -> Elim) -> [MaybeReduced Elim] -> [Elim]
forall a b. (a -> b) -> [a] -> [b]
map' MaybeReduced Elim -> Elim
forall a. MaybeReduced a -> a
ignoreReduced [MaybeReduced Elim]
es
      debugReduce :: Reduced (Blocked' Term Term) Term -> ReduceM ()
debugReduce Reduced (Blocked' Term Term) Term
ev = [Char] -> Int -> ReduceM () -> ReduceM ()
forall (m :: * -> *). MonadDebug m => [Char] -> Int -> m () -> m ()
verboseS [Char]
"tc.reduce" Int
90 (ReduceM () -> ReduceM ()) -> ReduceM () -> ReduceM ()
forall a b. (a -> b) -> a -> b
$ do
        case Reduced (Blocked' Term Term) Term
ev of
          NoReduction Blocked' Term Term
v -> do
            [Char] -> Int -> TCMT IO Doc -> ReduceM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.reduce" Int
90 (TCMT IO Doc -> ReduceM ()) -> TCMT IO Doc -> ReduceM ()
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
vcat
              [ TCMT IO Doc
"*** tried to reduce " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty QName
f
              , TCMT IO Doc
"    es =  " 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
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep ((MaybeReduced Elim -> TCMT IO Doc)
-> [MaybeReduced Elim] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map' (Elim -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Elim -> TCMT IO Doc)
-> (MaybeReduced Elim -> Elim) -> MaybeReduced Elim -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. MaybeReduced Elim -> Elim
forall a. MaybeReduced a -> a
ignoreReduced) [MaybeReduced Elim]
es)
              -- , "*** tried to reduce " <+> pretty vfull
              , TCMT IO Doc
"    stuck on" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term Term
v)
              ]
          YesReduction Simplification
_simpl Term
v -> do
            [Char] -> Int -> TCMT IO Doc -> ReduceM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.reduce"  Int
90 (TCMT IO Doc -> ReduceM ()) -> TCMT IO Doc -> ReduceM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"*** reduced definition: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty QName
f
            [Char] -> Int -> TCMT IO Doc -> ReduceM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.reduce"  Int
95 (TCMT IO Doc -> ReduceM ()) -> TCMT IO Doc -> ReduceM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"    result" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v

-- | Specialized version to put in boot file.
reduceDefCopyTCM :: QName -> Elims -> TCM (Reduced () Term)
reduceDefCopyTCM :: QName -> [Elim] -> TCM (Reduced () Term)
reduceDefCopyTCM = QName -> [Elim] -> TCM (Reduced () Term)
forall (m :: * -> *).
PureTCM m =>
QName -> [Elim] -> m (Reduced () Term)
reduceDefCopy

-- | Reduce a non-primitive definition if it is a copy linking to another def.
reduceDefCopy :: forall m. PureTCM m => QName -> Elims -> m (Reduced () Term)
reduceDefCopy :: forall (m :: * -> *).
PureTCM m =>
QName -> [Elim] -> m (Reduced () Term)
reduceDefCopy QName
f [Elim]
es = do
  info <- QName -> m Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
f
  case theDef info of
    Defn
_ | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Definition -> Bool
defCopy Definition
info     -> Reduced () Term -> m (Reduced () Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced () Term -> m (Reduced () Term))
-> Reduced () Term -> m (Reduced () Term)
forall a b. (a -> b) -> a -> b
$ () -> Reduced () Term
forall no yes. no -> Reduced no yes
NoReduction ()
    Constructor{conSrcCon :: Defn -> ConHead
conSrcCon = ConHead
c} -> Reduced () Term -> m (Reduced () Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced () Term -> m (Reduced () Term))
-> Reduced () Term -> m (Reduced () Term)
forall a b. (a -> b) -> a -> b
$ Simplification -> Term -> Reduced () Term
forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
YesSimplification (ConHead -> ConInfo -> [Elim] -> Term
Con ConHead
c ConInfo
ConOSystem [Elim]
es)
    Defn
_                          -> Definition -> QName -> [Elim] -> m (Reduced () Term)
reduceDef_ Definition
info QName
f [Elim]
es
  where
    reduceDef_ :: Definition -> QName -> Elims -> m (Reduced () Term)
    reduceDef_ :: Definition -> QName -> [Elim] -> m (Reduced () Term)
reduceDef_ Definition
info QName
f [Elim]
es = case Definition -> [Clause]
defClauses Definition
info of
      [Clause
cl] -> do  -- proper copies always have a single clause
        let v0 :: Term
v0 = QName -> [Elim] -> Term
Def QName
f [] -- TODO: could be Con
            ps :: NAPs
ps    = Clause -> NAPs
namedClausePats Clause
cl
            nargs :: Int
nargs = [Elim] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Elim]
es
            -- appDefE_ cannot handle underapplied functions, so we eta-expand here if that's the
            -- case. We use this function to compute display forms from module applications and in
            -- that case we don't always have saturated applications.
            (Term -> Term
lam, [Elim]
es') = ([Arg [Char]] -> Term -> Term
unlamView [Arg [Char]]
xs, [Elim]
newes)
              where
                etaArgs :: NAPs -> [a] -> [Arg [Char]]
etaArgs [] [a]
_ = []
                etaArgs (Arg (Named_ DeBruijnPattern)
p : NAPs
ps) []
                  | VarP PatternInfo
_ DBPatVar
x <- Arg (Named_ DeBruijnPattern) -> DeBruijnPattern
forall a. NamedArg a -> a
namedArg Arg (Named_ DeBruijnPattern)
p = ArgInfo -> [Char] -> Arg [Char]
forall e. ArgInfo -> e -> Arg e
Arg (Arg (Named_ DeBruijnPattern) -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Arg (Named_ DeBruijnPattern)
p) (DBPatVar -> [Char]
dbPatVarName DBPatVar
x) Arg [Char] -> [Arg [Char]] -> [Arg [Char]]
forall a. a -> [a] -> [a]
: NAPs -> [a] -> [Arg [Char]]
etaArgs NAPs
ps []
                  | Bool
otherwise              = []
                etaArgs (Arg (Named_ DeBruijnPattern)
_ : NAPs
ps) (a
_ : [a]
es) = NAPs -> [a] -> [Arg [Char]]
etaArgs NAPs
ps [a]
es
                xs :: [Arg [Char]]
xs  = NAPs -> [Elim] -> [Arg [Char]]
forall {a}. NAPs -> [a] -> [Arg [Char]]
etaArgs NAPs
ps [Elim]
es
                n :: Int
n   = [Arg [Char]] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg [Char]]
xs
                newes :: [Elim]
newes = Int -> [Elim] -> [Elim]
forall a. Subst a => Int -> a -> a
raise Int
n [Elim]
es [Elim] -> [Elim] -> [Elim]
forall a. [a] -> [a] -> [a]
++! [ Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Arg Term -> Elim) -> Arg Term -> Elim
forall a b. (a -> b) -> a -> b
$ Int -> Term
var Int
i Term -> Arg [Char] -> Arg Term
forall a b. a -> Arg b -> Arg a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg [Char]
x | (Int
i, Arg [Char]
x) <- [Int] -> [Arg [Char]] -> [(Int, Arg [Char])]
forall a b. [a] -> [b] -> [(a, b)]
zip (Int -> [Int]
forall a. Integral a => a -> [a]
downFrom Int
n) [Arg [Char]]
xs ]
        if Definition -> Bool
defNonterminating Definition
info
         then Reduced () Term -> m (Reduced () Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced () Term -> m (Reduced () Term))
-> Reduced () Term -> m (Reduced () Term)
forall a b. (a -> b) -> a -> b
$ () -> Reduced () Term
forall no yes. no -> Reduced no yes
NoReduction ()
         else do
            ev <- ReduceM (Reduced (Blocked' Term Term) Term)
-> m (Reduced (Blocked' Term Term) Term)
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM (Reduced (Blocked' Term Term) Term)
 -> m (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> m (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ QName
-> Term
-> [Clause]
-> Maybe CompiledClauses
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE_ QName
f Term
v0 [Clause
cl] Maybe CompiledClauses
forall a. Maybe a
Nothing RewriteRules
forall a. Monoid a => a
mempty ([MaybeReduced Elim]
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ (Elim -> MaybeReduced Elim) -> [Elim] -> [MaybeReduced Elim]
forall a b. (a -> b) -> [a] -> [b]
map' Elim -> MaybeReduced Elim
forall a. a -> MaybeReduced a
notReduced [Elim]
es'
            case ev of
              YesReduction Simplification
simpl Term
t -> Reduced () Term -> m (Reduced () Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced () Term -> m (Reduced () Term))
-> Reduced () Term -> m (Reduced () Term)
forall a b. (a -> b) -> a -> b
$ Simplification -> Term -> Reduced () Term
forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
simpl (Term -> Term
lam Term
t)
              NoReduction{}        -> Reduced () Term -> m (Reduced () Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced () Term -> m (Reduced () Term))
-> Reduced () Term -> m (Reduced () Term)
forall a b. (a -> b) -> a -> b
$ () -> Reduced () Term
forall no yes. no -> Reduced no yes
NoReduction ()
      []    -> Reduced () Term -> m (Reduced () Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced () Term -> m (Reduced () Term))
-> Reduced () Term -> m (Reduced () Term)
forall a b. (a -> b) -> a -> b
$ () -> Reduced () Term
forall no yes. no -> Reduced no yes
NoReduction ()  -- copies of generalizable variables have no clauses (and don't need unfolding)
      Clause
_:Clause
_:[Clause]
_ -> m (Reduced () Term)
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Reduce simple (single clause) definitions.
reduceHead :: PureTCM m => Term -> m (Blocked Term)
reduceHead :: forall (m :: * -> *). PureTCM m => Term -> m (Blocked' Term Term)
reduceHead Term
v = do -- ignoreAbstractMode $ do
  -- Andreas, 2013-02-18 ignoreAbstractMode leads to information leakage
  -- see Issue 796

  -- first, possibly rewrite literal v to constructor form
  v <- Term -> m Term
forall (m :: * -> *). HasBuiltins m => Term -> m Term
constructorForm Term
v
  traceSDoc "tc.inj.reduce" 30 (ignoreAbstractMode $ "reduceHead" <+> prettyTCM v) $ do
  case v of
    Def QName
f [Elim]
es -> do
      abstractMode <- Lens' TCEnv AbstractMode -> m AbstractMode
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (AbstractMode -> f AbstractMode) -> TCEnv -> f TCEnv
Lens' TCEnv AbstractMode
eAbstractMode
      isAbstract <- not <$> hasAccessibleDef f
      traceSLn "tc.inj.reduce" 50 (
        "reduceHead: we are in " ++! show abstractMode ++! "; " ++! prettyShow f ++!
        " is treated " ++! if isAbstract then "abstractly" else "concretely"
        ) $ do
      let v0  = QName -> [Elim] -> Term
Def QName
f []
          red = ReduceM (Blocked' Term Term) -> m (Blocked' Term Term)
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM (Blocked' Term Term) -> m (Blocked' Term Term))
-> ReduceM (Blocked' Term Term) -> m (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$ (Term -> ReduceM (Blocked' Term Term))
-> Term -> QName -> [Elim] -> ReduceM (Blocked' Term Term)
unfoldDefinitionE Term -> ReduceM (Blocked' Term Term)
forall (m :: * -> *). PureTCM m => Term -> m (Blocked' Term Term)
reduceHead Term
v0 QName
f [Elim]
es
      def <- theDef <$> getConstInfo f
      case def of
        -- Andreas, 2012-11-06 unfold aliases (single clause terminating functions)
        -- see test/succeed/Issue747
        -- We restrict this to terminating functions to not make the
        -- type checker loop here on non-terminating functions.
        -- see test/fail/TerminationInfiniteRecord
        Function{ funClauses :: Defn -> [Clause]
funClauses = [ Clause
_ ], funTerminates :: Defn -> Maybe Bool
funTerminates = Just Bool
True } -> do
          [Char]
-> Int
-> [Char]
-> m (Blocked' Term Term)
-> m (Blocked' Term Term)
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Int -> [Char] -> m a -> m a
traceSLn [Char]
"tc.inj.reduce" Int
50 ([Char]
"reduceHead: head " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
f [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! [Char]
" is Function") (m (Blocked' Term Term) -> m (Blocked' Term Term))
-> m (Blocked' Term Term) -> m (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$ do
          red
        Datatype{ dataClause :: Defn -> Maybe Clause
dataClause = Just Clause
_ } -> m (Blocked' Term Term)
red
        Record{ recClause :: Defn -> Maybe Clause
recClause = Just Clause
_ }    -> m (Blocked' Term Term)
red
        Defn
_                               -> Blocked' Term Term -> m (Blocked' Term Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked' Term Term -> m (Blocked' Term Term))
-> Blocked' Term Term -> m (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$ Term -> Blocked' Term Term
forall a t. a -> Blocked' t a
notBlocked Term
v
    Term
_ -> Blocked' Term Term -> m (Blocked' Term Term)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked' Term Term -> m (Blocked' Term Term))
-> Blocked' Term Term -> m (Blocked' Term Term)
forall a b. (a -> b) -> a -> b
$ Term -> Blocked' Term Term
forall a t. a -> Blocked' t a
notBlocked Term
v

-- | Unfold as many copies as possible, and then potentially a single
-- inline function.
unfoldInlined :: PureTCM m => Term -> m Term
unfoldInlined :: forall (m :: * -> *). PureTCM m => Term -> m Term
unfoldInlined Term
v = do
  inTypes <- Lens' TCEnv Bool -> m Bool
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (Bool -> f Bool) -> TCEnv -> f TCEnv
Lens' TCEnv Bool
eWorkingOnTypes
  case v of
    Term
_ | Bool
inTypes -> Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v -- Don't inline in types (to avoid unfolding of goals)
    Def QName
f [Elim]
es -> do
      info <- QName -> m Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
f

      let
        def = Definition -> Defn
theDef Definition
info
        irr = ArgInfo -> Bool
forall a. LensRelevance a => a -> Bool
isIrrelevant (ArgInfo -> Bool) -> ArgInfo -> Bool
forall a b. (a -> b) -> a -> b
$ Definition -> ArgInfo
defArgInfo Definition
info
        continue
          | Definition -> Bool
defCopy Definition
info = (Term -> Blocked' Term Term)
-> ReduceM Term -> ReduceM (Blocked' Term Term)
forall a b. (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Blocked' Term Term
forall a t. a -> Blocked' t a
notBlocked (ReduceM Term -> ReduceM (Blocked' Term Term))
-> (Term -> ReduceM Term) -> Term -> ReduceM (Blocked' Term Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> ReduceM Term
forall (m :: * -> *). PureTCM m => Term -> m Term
unfoldInlined
          | Bool
otherwise    = Blocked' Term Term -> ReduceM (Blocked' Term Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Blocked' Term Term -> ReduceM (Blocked' Term Term))
-> (Term -> Blocked' Term Term)
-> Term
-> ReduceM (Blocked' Term Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Blocked' Term Term
forall a t. a -> Blocked' t a
notBlocked

      case def of
        Function{} ->
          [Char] -> Int -> [Char] -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.inline" Int
90 ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$
            [Char] -> [[Char]] -> [Char]
forall a. [a] -> [[a]] -> [a]
intercalate [Char]
"\n"
            [ [Char]
"considering to inline " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
f
            , [Char]
"irr         = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Bool -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Bool
irr
            , [Char]
"funInline   = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Bool -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Defn
def Defn -> Getting Bool Defn Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Defn Bool
Lens' Defn Bool
funInline)
            , [Char]
"funCompiled = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Maybe CompiledClauses -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Defn -> Maybe CompiledClauses
funCompiled Defn
def)
            ]
        Defn
_ -> () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

      case def of -- Only for simple definitions with no pattern matching (TODO: maybe copatterns?)
        Function{ funCompiled :: Defn -> Maybe CompiledClauses
funCompiled = Just Done{} }
          | (Definition -> Bool
defCopy Definition
info Bool -> Bool -> Bool
|| Defn
def Defn -> Getting Bool Defn Bool -> Bool
forall s a. s -> Getting a s a -> a
^. Getting Bool Defn Bool
Lens' Defn Bool
funInline), Bool -> Bool
not Bool
irr -> do
            [Char] -> Int -> [Char] -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.inline" Int
70 ([Char] -> m ()) -> [Char] -> m ()
forall a b. (a -> b) -> a -> b
$ [Char]
"asking to inline " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
f
            ReduceM Term -> m Term
forall a. ReduceM a -> m a
forall (m :: * -> *) a. MonadReduce m => ReduceM a -> m a
liftReduce (ReduceM Term -> m Term) -> ReduceM Term -> m Term
forall a b. (a -> b) -> a -> b
$
              Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked' Term Term -> Term)
-> ReduceM (Blocked' Term Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> ReduceM (Blocked' Term Term))
-> Term -> QName -> [Elim] -> ReduceM (Blocked' Term Term)
unfoldDefinitionE Term -> ReduceM (Blocked' Term Term)
continue (QName -> [Elim] -> Term
Def QName
f []) QName
f [Elim]
es
        Defn
_ -> Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
    Term
_ -> Term -> m Term
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v

-- | Apply a definition using the compiled clauses, or fall back to
--   ordinary clauses if no compiled clauses exist.
appDef_ :: QName -> Term -> [Clause] -> Maybe CompiledClauses
        -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
appDef_ :: QName
-> Term
-> [Clause]
-> Maybe CompiledClauses
-> RewriteRules
-> MaybeReducedArgs
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDef_ QName
f Term
v0 [Clause]
cls Maybe CompiledClauses
mcc RewriteRules
rewr MaybeReducedArgs
args = QName
-> Term
-> [Clause]
-> Maybe CompiledClauses
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE_ QName
f Term
v0 [Clause]
cls Maybe CompiledClauses
mcc RewriteRules
rewr ([MaybeReduced Elim]
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ (MaybeReduced (Arg Term) -> MaybeReduced Elim)
-> MaybeReducedArgs -> [MaybeReduced Elim]
forall a b. (a -> b) -> [a] -> [b]
map' ((Arg Term -> Elim) -> MaybeReduced (Arg Term) -> MaybeReduced Elim
forall a b. (a -> b) -> MaybeReduced a -> MaybeReduced b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply) MaybeReducedArgs
args

appDefE_ ::
     QName -> Term -> [Clause] -> Maybe CompiledClauses -> RewriteRules
  -> MaybeReducedElims -> ReduceM (Reduced (Blocked Term) Term)
appDefE_ :: QName
-> Term
-> [Clause]
-> Maybe CompiledClauses
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE_ QName
f Term
v0 [Clause]
cls Maybe CompiledClauses
mcc RewriteRules
rewr [MaybeReduced Elim]
args =
  (TCEnv -> TCEnv)
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a. (TCEnv -> TCEnv) -> ReduceM a -> ReduceM a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC (ASetter TCEnv TCEnv (Maybe QName) (Maybe QName)
-> Maybe QName -> TCEnv -> TCEnv
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter TCEnv TCEnv (Maybe QName) (Maybe QName)
Lens' TCEnv (Maybe QName)
eAppDef (QName -> Maybe QName
forall a. a -> Maybe a
Just QName
f)) (ReduceM (Reduced (Blocked' Term Term) Term)
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$
  ReduceM (Reduced (Blocked' Term Term) Term)
-> (CompiledClauses -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Maybe CompiledClauses
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Term
-> [Clause]
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE'' Term
v0 [Clause]
cls RewriteRules
rewr [MaybeReduced Elim]
args)
        (\CompiledClauses
cc -> Term
-> CompiledClauses
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE Term
v0 CompiledClauses
cc RewriteRules
rewr [MaybeReduced Elim]
args) Maybe CompiledClauses
mcc

-- | Apply a defined function to it's arguments, using the compiled clauses.
--   The original term is the first argument applied to the third.
appDef :: Term -> CompiledClauses -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
appDef :: Term
-> CompiledClauses
-> RewriteRules
-> MaybeReducedArgs
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDef Term
v CompiledClauses
cc RewriteRules
rewr MaybeReducedArgs
args = Term
-> CompiledClauses
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE Term
v CompiledClauses
cc RewriteRules
rewr ([MaybeReduced Elim]
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ (MaybeReduced (Arg Term) -> MaybeReduced Elim)
-> MaybeReducedArgs -> [MaybeReduced Elim]
forall a b. (a -> b) -> [a] -> [b]
map' ((Arg Term -> Elim) -> MaybeReduced (Arg Term) -> MaybeReduced Elim
forall a b. (a -> b) -> MaybeReduced a -> MaybeReduced b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply) MaybeReducedArgs
args

appDefE ::
     Term -> CompiledClauses -> RewriteRules -> MaybeReducedElims
  -> ReduceM (Reduced (Blocked Term) Term)
appDefE :: Term
-> CompiledClauses
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE Term
v CompiledClauses
cc RewriteRules
rewr [MaybeReduced Elim]
es = do
  [Char]
-> Int
-> TCMT IO Doc
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m a -> m a
traceSDoc [Char]
"tc.reduce" Int
90 (TCMT IO Doc
"appDefE v = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v) (ReduceM (Reduced (Blocked' Term Term) Term)
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ do
  r <- CompiledClauses
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term [Elim]) Term)
matchCompiledE CompiledClauses
cc [MaybeReduced Elim]
es
  case r of
    YesReduction Simplification
simpl Term
t -> Reduced (Blocked' Term Term) Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced (Blocked' Term Term) Term
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Reduced (Blocked' Term Term) Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ Simplification -> Term -> Reduced (Blocked' Term Term) Term
forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
simpl Term
t
    NoReduction Blocked' Term [Elim]
es'      -> Blocked' Term ()
-> ([Elim] -> Term)
-> RewriteRules
-> [Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
rewrite (Blocked' Term [Elim] -> Blocked' Term ()
forall (f :: * -> *) a. Functor f => f a -> f ()
void Blocked' Term [Elim]
es') (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
applyE Term
v) RewriteRules
rewr (Blocked' Term [Elim] -> [Elim]
forall t a. Blocked' t a -> a
ignoreBlocking Blocked' Term [Elim]
es')

-- | Apply a defined function to it's arguments, using the original clauses.
appDef' :: QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedArgs -> ReduceM (Reduced (Blocked Term) Term)
appDef' :: QName
-> Term
-> [Clause]
-> RewriteRules
-> MaybeReducedArgs
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDef' QName
f Term
v [Clause]
cls RewriteRules
rewr MaybeReducedArgs
args = QName
-> Term
-> [Clause]
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE' QName
f Term
v [Clause]
cls RewriteRules
rewr ([MaybeReduced Elim]
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ (MaybeReduced (Arg Term) -> MaybeReduced Elim)
-> MaybeReducedArgs -> [MaybeReduced Elim]
forall a b. (a -> b) -> [a] -> [b]
map' ((Arg Term -> Elim) -> MaybeReduced (Arg Term) -> MaybeReduced Elim
forall a b. (a -> b) -> MaybeReduced a -> MaybeReduced b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply) MaybeReducedArgs
args

appDefE' ::
     QName -> Term -> [Clause] -> RewriteRules -> MaybeReducedElims
  -> ReduceM (Reduced (Blocked Term) Term)
appDefE' :: QName
-> Term
-> [Clause]
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE' QName
f Term
v [Clause]
cls RewriteRules
rewr [MaybeReduced Elim]
es =
  (TCEnv -> TCEnv)
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a. (TCEnv -> TCEnv) -> ReduceM a -> ReduceM a
forall (m :: * -> *) a.
MonadTCEnv m =>
(TCEnv -> TCEnv) -> m a -> m a
localTC (ASetter TCEnv TCEnv (Maybe QName) (Maybe QName)
-> Maybe QName -> TCEnv -> TCEnv
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter TCEnv TCEnv (Maybe QName) (Maybe QName)
Lens' TCEnv (Maybe QName)
eAppDef (QName -> Maybe QName
forall a. a -> Maybe a
Just QName
f)) (ReduceM (Reduced (Blocked' Term Term) Term)
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$
  Term
-> [Clause]
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE'' Term
v [Clause]
cls RewriteRules
rewr [MaybeReduced Elim]
es

-- | Expects @'envAppDef' = Just f@ in 'TCEnv' to be able to report @'MissingClauses' f@.
appDefE'' ::
     Term -> [Clause] -> RewriteRules -> MaybeReducedElims
  -> ReduceM (Reduced (Blocked Term) Term)
appDefE'' :: Term
-> [Clause]
-> RewriteRules
-> [MaybeReduced Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
appDefE'' Term
v [Clause]
cls RewriteRules
rewr [MaybeReduced Elim]
es = [Char]
-> Int
-> TCMT IO Doc
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall (m :: * -> *) a.
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m a -> m a
traceSDoc [Char]
"tc.reduce" Int
90 (TCMT IO Doc
"appDefE' v = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v) (ReduceM (Reduced (Blocked' Term Term) Term)
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> ReduceM (Reduced (Blocked' Term Term) Term)
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ do
  [Clause] -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
goCls [Clause]
cls ([Elim] -> ReduceM (Reduced (Blocked' Term Term) Term))
-> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ (MaybeReduced Elim -> Elim) -> [MaybeReduced Elim] -> [Elim]
forall a b. (a -> b) -> [a] -> [b]
map' MaybeReduced Elim -> Elim
forall a. MaybeReduced a -> a
ignoreReduced [MaybeReduced Elim]
es
  where
    goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked Term) Term)
    goCls :: [Clause] -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
goCls [Clause]
cl [Elim]
es = do
      case [Clause]
cl of
        -- Andreas, 2013-10-26  In case of an incomplete match,
        -- we just do not reduce.  This allows adding single function
        -- clauses after they have been type-checked, to type-check
        -- the remaining clauses (see Issue 907).
        -- Andrea(s), 2014-12-05:  We return 'MissingClauses' here, since this
        -- is the most conservative reason.
        [] -> do
          f <- QName -> Maybe QName -> QName
forall a. a -> Maybe a -> a
fromMaybe QName
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe QName -> QName) -> ReduceM (Maybe QName) -> ReduceM QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' TCEnv (Maybe QName) -> ReduceM (Maybe QName)
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (Maybe QName -> f (Maybe QName)) -> TCEnv -> f TCEnv
Lens' TCEnv (Maybe QName)
eAppDef
          rewrite (NotBlocked (MissingClauses f) ()) (applyE v) rewr es
        Clause
cl : [Clause]
cls -> do
          let pats :: NAPs
pats = Clause -> NAPs
namedClausePats Clause
cl
              body :: Maybe Term
body = Clause -> Maybe Term
clauseBody Clause
cl
              npats :: Int
npats = NAPs -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length NAPs
pats
              nvars :: Int
nvars = Telescope -> Int
forall a. Sized a => a -> Int
size (Telescope -> Int) -> Telescope -> Int
forall a b. (a -> b) -> a -> b
$ Clause -> Telescope
clauseTel Clause
cl
          -- if clause is underapplied, skip to next clause
          if [Elim] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Elim]
es Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
npats then [Clause] -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
goCls [Clause]
cls [Elim]
es else do
            allowedReductions <- Lens' TCEnv (SmallSet AllowedReduction)
-> ReduceM (SmallSet AllowedReduction)
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (SmallSet AllowedReduction -> f (SmallSet AllowedReduction))
-> TCEnv -> f TCEnv
Lens' TCEnv (SmallSet AllowedReduction)
eAllowedReductions
            let (es0, es1) = splitAt' npats es
            (m, es0) <- matchCopatterns pats es0
            let es = [Elim]
es0 [Elim] -> [Elim] -> [Elim]
forall a. [a] -> [a] -> [a]
++! [Elim]
es1
            case m of
              Match Term
No               -> [Clause] -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
goCls [Clause]
cls [Elim]
es
              -- Szumi, 2024-03-29, issue #7181:
              -- If a lazy match is stuck and all non-lazy matches are conclusive,
              -- then reduction should not be stuck on the current clause and it
              -- should be fine to continue matching on the next clause.
              -- This assumes it's impossible for a lazy match to be stuck if
              -- all non-lazy matches succeed.
              DontKnow OnlyLazy
OnlyLazy Blocked' Term ()
_ -> [Clause] -> [Elim] -> ReduceM (Reduced (Blocked' Term Term) Term)
goCls [Clause]
cls [Elim]
es
              DontKnow OnlyLazy
NonLazy  Blocked' Term ()
b -> Blocked' Term ()
-> ([Elim] -> Term)
-> RewriteRules
-> [Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
rewrite Blocked' Term ()
b (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
applyE Term
v) RewriteRules
rewr [Elim]
es
              Yes Simplification
simpl IntMap (Arg Term)
vs -- vs is the subst. for the variables bound in body
                | ClauseRecursive -> Bool
couldBeRecursive (Clause -> ClauseRecursive
clauseRecursive Clause
cl)
                , AllowedReduction
RecursiveReductions AllowedReduction -> SmallSet AllowedReduction -> Bool
forall a. SmallSetElement a => a -> SmallSet a -> Bool
`SmallSet.notMember` SmallSet AllowedReduction
allowedReductions ->
                    Reduced (Blocked' Term Term) Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced (Blocked' Term Term) Term
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Reduced (Blocked' Term Term) Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ Blocked' Term Term -> Reduced (Blocked' Term Term) Term
forall no yes. no -> Reduced no yes
NoReduction Blocked' Term Term
forall a. HasCallStack => a
__IMPOSSIBLE__
                | Just Term
w <- Maybe Term
body -> do -- clause has body?
                    -- TODO: let matchPatterns also return the reduced forms
                    -- of the original arguments!
                    -- Andreas, 2013-05-19 isn't this done now?
                    let sigma :: Substitution
sigma = Impossible -> Int -> IntMap (Arg Term) -> Substitution
forall a.
DeBruijn a =>
Impossible -> Int -> IntMap (Arg a) -> Substitution' a
buildSubstitution Impossible
HasCallStack => Impossible
impossible Int
nvars IntMap (Arg Term)
vs
                    Reduced (Blocked' Term Term) Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Reduced (Blocked' Term Term) Term
 -> ReduceM (Reduced (Blocked' Term Term) Term))
-> Reduced (Blocked' Term Term) Term
-> ReduceM (Reduced (Blocked' Term Term) Term)
forall a b. (a -> b) -> a -> b
$ Simplification -> Term -> Reduced (Blocked' Term Term) Term
forall no yes. Simplification -> yes -> Reduced no yes
YesReduction Simplification
simpl (Term -> Reduced (Blocked' Term Term) Term)
-> Term -> Reduced (Blocked' Term Term) Term
forall a b. (a -> b) -> a -> b
$ Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg Term)
sigma Term
w Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
`applyE` [Elim]
es1
                | Bool
otherwise     -> Blocked' Term ()
-> ([Elim] -> Term)
-> RewriteRules
-> [Elim]
-> ReduceM (Reduced (Blocked' Term Term) Term)
rewrite (NotBlocked -> () -> Blocked' Term ()
forall t a. NotBlocked' t -> a -> Blocked' t a
NotBlocked NotBlocked
forall t. NotBlocked' t
AbsurdMatch ()) (Term -> [Elim] -> Term
forall t. Apply t => t -> [Elim] -> t
applyE Term
v) RewriteRules
rewr [Elim]
es

instance Reduce a => Reduce (Closure a) where
    reduce' :: Closure a -> ReduceM (Closure a)
reduce' Closure a
cl = do
        x <- Closure a -> (a -> ReduceM a) -> ReduceM a
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure Closure a
cl a -> ReduceM a
forall t. Reduce t => t -> ReduceM t
reduce'
        return $ cl { clValue = x }
{-# SPECIALIZE reduce' :: Closure Constraint -> ReduceM (Closure Constraint) #-}

instance Reduce Telescope where
  reduce' :: Telescope -> ReduceM Telescope
reduce' Telescope
EmptyTel          = Telescope -> ReduceM Telescope
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Telescope
forall a. Tele a
EmptyTel
  reduce' (ExtendTel Dom' Term Type
a Abs Telescope
tel) = Dom' Term Type -> Abs Telescope -> Telescope
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel (Dom' Term Type -> Abs Telescope -> Telescope)
-> ReduceM (Dom' Term Type) -> ReduceM (Abs Telescope -> Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom' Term Type -> ReduceM (Dom' Term Type)
forall t. Reduce t => t -> ReduceM t
reduce' Dom' Term Type
a ReduceM (Abs Telescope -> Telescope)
-> ReduceM (Abs Telescope) -> ReduceM Telescope
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Abs Telescope -> ReduceM (Abs Telescope)
forall t. Reduce t => t -> ReduceM t
reduce' Abs Telescope
tel

instance Reduce ProblemConstraint where
  reduce' :: ProblemConstraint -> ReduceM ProblemConstraint
reduce' (PConstr Set ProblemId
p Blocker
u Closure Constraint
c) = Set ProblemId -> Blocker -> Closure Constraint -> ProblemConstraint
PConstr Set ProblemId
p Blocker
u (Closure Constraint -> ProblemConstraint)
-> ReduceM (Closure Constraint) -> ReduceM ProblemConstraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure Constraint -> ReduceM (Closure Constraint)
forall t. Reduce t => t -> ReduceM t
reduce' Closure Constraint
c

instance Reduce LocalEquation where
  reduce' :: LocalEquation' Term -> ReduceM (LocalEquation' Term)
reduce' (LocalEquation Telescope
g Term
t Term
u Type
a) = do
    g' <- Telescope -> ReduceM Telescope
forall t. Reduce t => t -> ReduceM t
reduce' Telescope
g
    (t', u', a') <- addContext g' $ reduce' (t, u, a)
    return $ LocalEquation g' t' u' a'

instance Reduce Constraint where
  reduce' :: Constraint -> ReduceM Constraint
reduce' (ValueCmp Comparison
cmp CompareAs
t Term
u Term
v) = do
    (t,u,v) <- (CompareAs, Term, Term) -> ReduceM (CompareAs, Term, Term)
forall t. Reduce t => t -> ReduceM t
reduce' (CompareAs
t,Term
u,Term
v)
    return $ ValueCmp cmp t u v
  reduce' (ValueCmpOnFace Comparison
cmp Term
p Type
t Term
u Term
v) = do
    ((p,t),u,v) <- ((Term, Type), Term, Term) -> ReduceM ((Term, Type), Term, Term)
forall t. Reduce t => t -> ReduceM t
reduce' ((Term
p,Type
t),Term
u,Term
v)
    return $ ValueCmpOnFace cmp p t u v
  reduce' (ElimCmp [Polarity]
cmp [IsForced]
fs Type
t Term
v [Elim]
as [Elim]
bs) =
    [Polarity]
-> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> Constraint
ElimCmp [Polarity]
cmp [IsForced]
fs (Type -> Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Type -> ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
t ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Term -> ReduceM ([Elim] -> [Elim] -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
v ReduceM ([Elim] -> [Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM ([Elim] -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Elim] -> ReduceM [Elim]
forall t. Reduce t => t -> ReduceM t
reduce' [Elim]
as ReduceM ([Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Elim] -> ReduceM [Elim]
forall t. Reduce t => t -> ReduceM t
reduce' [Elim]
bs
  reduce' (LevelCmp Comparison
cmp Level' Term
u Level' Term
v)    = (Level' Term -> Level' Term -> Constraint)
-> (Level' Term, Level' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Level' Term -> Level' Term -> Constraint
LevelCmp Comparison
cmp) ((Level' Term, Level' Term) -> Constraint)
-> ReduceM (Level' Term, Level' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Level' Term, Level' Term) -> ReduceM (Level' Term, Level' Term)
forall t. Reduce t => t -> ReduceM t
reduce' (Level' Term
u,Level' Term
v)
  reduce' (SortCmp Comparison
cmp Sort' Term
a Sort' Term
b)     = (Sort' Term -> Sort' Term -> Constraint)
-> (Sort' Term, Sort' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Sort' Term -> Sort' Term -> Constraint
SortCmp Comparison
cmp) ((Sort' Term, Sort' Term) -> Constraint)
-> ReduceM (Sort' Term, Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sort' Term, Sort' Term) -> ReduceM (Sort' Term, Sort' Term)
forall t. Reduce t => t -> ReduceM t
reduce' (Sort' Term
a,Sort' Term
b)
  reduce' (UnBlock MetaId
m)           = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ MetaId -> Constraint
UnBlock MetaId
m
  reduce' (FindInstance Range
r MetaId
m Maybe [Candidate]
cs)   = Range -> MetaId -> Maybe [Candidate] -> Constraint
FindInstance Range
r MetaId
m (Maybe [Candidate] -> Constraint)
-> ReduceM (Maybe [Candidate]) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Candidate] -> ReduceM [Candidate])
-> Maybe [Candidate] -> ReduceM (Maybe [Candidate])
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) -> Maybe a -> m (Maybe b)
mapM [Candidate] -> ReduceM [Candidate]
forall t. Reduce t => t -> ReduceM t
reduce' Maybe [Candidate]
cs
  reduce' (ResolveInstanceHead KwRange
kwr QName
q) = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ KwRange -> QName -> Constraint
ResolveInstanceHead KwRange
kwr QName
q
  reduce' (IsEmpty Range
r Type
t)         = Range -> Type -> Constraint
IsEmpty Range
r (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
t
  reduce' (CheckSizeLtSat Term
t)    = Term -> Constraint
CheckSizeLtSat (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
t
  reduce' c :: Constraint
c@CheckFunDef{}       = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
  reduce' (HasBiggerSort Sort' Term
a)     = Sort' Term -> Constraint
HasBiggerSort (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Reduce t => t -> ReduceM t
reduce' Sort' Term
a
  reduce' (HasPTSRule Dom' Term Type
a Abs (Sort' Term)
b)      = (Dom' Term Type -> Abs (Sort' Term) -> Constraint)
-> (Dom' Term Type, Abs (Sort' Term)) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Dom' Term Type -> Abs (Sort' Term) -> Constraint
HasPTSRule ((Dom' Term Type, Abs (Sort' Term)) -> Constraint)
-> ReduceM (Dom' Term Type, Abs (Sort' Term)) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dom' Term Type, Abs (Sort' Term))
-> ReduceM (Dom' Term Type, Abs (Sort' Term))
forall t. Reduce t => t -> ReduceM t
reduce' (Dom' Term Type
a,Abs (Sort' Term)
b)
  reduce' (UnquoteTactic Term
t Term
h Type
g) = Term -> Term -> Type -> Constraint
UnquoteTactic (Term -> Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Term -> Type -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
t ReduceM (Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
h ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
g
  reduce' (CheckLockedVars Term
a Type
b Arg Term
c Type
d) =
    Term -> Type -> Arg Term -> Type -> Constraint
CheckLockedVars (Term -> Type -> Arg Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Arg Term -> Type -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
a ReduceM (Type -> Arg Term -> Type -> Constraint)
-> ReduceM Type -> ReduceM (Arg Term -> Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
b ReduceM (Arg Term -> Type -> Constraint)
-> ReduceM (Arg Term) -> ReduceM (Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Reduce t => t -> ReduceM t
reduce' Arg Term
c ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
d
  reduce' (CheckDataSort QName
q Sort' Term
s)   = QName -> Sort' Term -> Constraint
CheckDataSort QName
q (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Reduce t => t -> ReduceM t
reduce' Sort' Term
s
  reduce' c :: Constraint
c@CheckMetaInst{}     = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
  reduce' (CheckType Type
t)         = Type -> Constraint
CheckType (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
t
  reduce' (UsableAtModality WhyCheckModality
cc Maybe (Sort' Term)
ms Modality
mod Term
t) = (Maybe (Sort' Term) -> Modality -> Term -> Constraint)
-> Modality -> Maybe (Sort' Term) -> Term -> Constraint
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WhyCheckModality
-> Maybe (Sort' Term) -> Modality -> Term -> Constraint
UsableAtModality WhyCheckModality
cc) Modality
mod (Maybe (Sort' Term) -> Term -> Constraint)
-> ReduceM (Maybe (Sort' Term)) -> ReduceM (Term -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Sort' Term) -> ReduceM (Maybe (Sort' Term))
forall t. Reduce t => t -> ReduceM t
reduce' Maybe (Sort' Term)
ms ReduceM (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
t
  reduce' (RewConstraint LocalEquation' Term
e)     = LocalEquation' Term -> Constraint
RewConstraint (LocalEquation' Term -> Constraint)
-> ReduceM (LocalEquation' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalEquation' Term -> ReduceM (LocalEquation' Term)
forall t. Reduce t => t -> ReduceM t
reduce' LocalEquation' Term
e

instance Reduce CompareAs where
  reduce' :: CompareAs -> ReduceM CompareAs
reduce' (AsTermsOf Type
a) = Type -> CompareAs
AsTermsOf (Type -> CompareAs) -> ReduceM Type -> ReduceM CompareAs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
a
  reduce' CompareAs
AsSizes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsSizes
  reduce' CompareAs
AsTypes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsTypes

instance Reduce e => Reduce (Map k e) where
  reduce' :: Map k e -> ReduceM (Map k e)
reduce' = (e -> ReduceM e) -> Map k e -> ReduceM (Map k e)
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) -> Map k a -> f (Map k b)
traverse e -> ReduceM e
forall t. Reduce t => t -> ReduceM t
reduce'

instance Reduce Candidate where
  reduce' :: Candidate -> ReduceM Candidate
reduce' (Candidate CandidateKind
q Term
u Type
t OverlapMode
ov) = CandidateKind -> Term -> Type -> OverlapMode -> Candidate
Candidate CandidateKind
q (Term -> Type -> OverlapMode -> Candidate)
-> ReduceM Term -> ReduceM (Type -> OverlapMode -> Candidate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
u ReduceM (Type -> OverlapMode -> Candidate)
-> ReduceM Type -> ReduceM (OverlapMode -> Candidate)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
t ReduceM (OverlapMode -> Candidate)
-> ReduceM OverlapMode -> ReduceM Candidate
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OverlapMode -> ReduceM OverlapMode
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OverlapMode
ov

instance Reduce EqualityView where
  reduce' :: EqualityView -> ReduceM EqualityView
reduce' (OtherType Type
t)            = Type -> EqualityView
OtherType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
t
  reduce' (IdiomType Type
t)            = Type -> EqualityView
IdiomType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Reduce t => t -> ReduceM t
reduce' Type
t
  reduce' (EqualityType Range
r Sort' Term
s QName
eq Args
l Arg Term
t Arg Term
a Arg Term
b) = Range
-> Sort' Term
-> QName
-> Args
-> Arg Term
-> Arg Term
-> Arg Term
-> EqualityView
EqualityType Range
r
    (Sort' Term
 -> QName
 -> Args
 -> Arg Term
 -> Arg Term
 -> Arg Term
 -> EqualityView)
-> ReduceM (Sort' Term)
-> ReduceM
     (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Reduce t => t -> ReduceM t
reduce' Sort' Term
s
    ReduceM
  (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM QName
-> ReduceM
     (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QName -> ReduceM QName
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
eq
    ReduceM (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM Args
-> ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Arg Term -> ReduceM (Arg Term)) -> Args -> ReduceM Args
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 -> ReduceM (Arg Term)
forall t. Reduce t => t -> ReduceM t
reduce' Args
l
    ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term)
-> ReduceM (Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Reduce t => t -> ReduceM t
reduce' Arg Term
t
    ReduceM (Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM (Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Reduce t => t -> ReduceM t
reduce' Arg Term
a
    ReduceM (Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM EqualityView
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Reduce t => t -> ReduceM t
reduce' Arg Term
b

instance Reduce t => Reduce (IPBoundary' t) where
  reduce' :: IPBoundary' t -> ReduceM (IPBoundary' t)
reduce' = (t -> ReduceM t) -> IPBoundary' t -> ReduceM (IPBoundary' t)
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) -> IPBoundary' a -> f (IPBoundary' b)
traverse t -> ReduceM t
forall t. Reduce t => t -> ReduceM t
reduce'
  reduceB' :: IPBoundary' t -> ReduceM (Blocked (IPBoundary' t))
reduceB' = (IPBoundary' (Blocked' Term t) -> Blocked (IPBoundary' t))
-> ReduceM (IPBoundary' (Blocked' Term t))
-> ReduceM (Blocked (IPBoundary' t))
forall a b. (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap IPBoundary' (Blocked' Term t) -> Blocked (IPBoundary' t)
forall (t :: * -> *) (f :: * -> *) a.
(Traversable t, Applicative f) =>
t (f a) -> f (t a)
forall (f :: * -> *) a.
Applicative f =>
IPBoundary' (f a) -> f (IPBoundary' a)
sequenceA (ReduceM (IPBoundary' (Blocked' Term t))
 -> ReduceM (Blocked (IPBoundary' t)))
-> (IPBoundary' t -> ReduceM (IPBoundary' (Blocked' Term t)))
-> IPBoundary' t
-> ReduceM (Blocked (IPBoundary' t))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (t -> ReduceM (Blocked' Term t))
-> IPBoundary' t -> ReduceM (IPBoundary' (Blocked' Term t))
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) -> IPBoundary' a -> f (IPBoundary' b)
traverse t -> ReduceM (Blocked' Term t)
forall t. Reduce t => t -> ReduceM (Blocked t)
reduceB'

---------------------------------------------------------------------------
-- * Simplification
---------------------------------------------------------------------------

-- | Only unfold definitions if this leads to simplification
--   which means that a constructor/literal pattern is matched.
--   We include reduction of IApply patterns, as `p i0` is akin to
--   matcing on the `i0` constructor of interval.
class Simplify t where
  simplify' :: t -> ReduceM t

  default simplify' :: (t ~ f a, Traversable f, Simplify a) => t -> ReduceM t
  simplify' = (a -> ReduceM a) -> f a -> ReduceM (f a)
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) -> f a -> f (f b)
traverse a -> ReduceM a
forall t. Simplify t => t -> ReduceM t
simplify'

-- boring instances:

instance Simplify t => Simplify [t]
instance Simplify t => Simplify (Map k t)
instance Simplify t => Simplify (Maybe t)
instance Simplify t => Simplify (Strict.Maybe t)

instance Simplify t => Simplify (Arg t)
instance Simplify t => Simplify (Elim' t)
instance Simplify t => Simplify (Named name t)
instance Simplify t => Simplify (IPBoundary' t)

instance (Simplify a, Simplify b) => Simplify (a,b) where
    simplify' :: (a, b) -> ReduceM (a, b)
simplify' (a
x,b
y) = (,) (a -> b -> (a, b)) -> ReduceM a -> ReduceM (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Simplify t => t -> ReduceM t
simplify' a
x ReduceM (b -> (a, b)) -> ReduceM b -> ReduceM (a, b)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> ReduceM b
forall t. Simplify t => t -> ReduceM t
simplify' b
y

instance (Simplify a, Simplify b, Simplify c) => Simplify (a,b,c) where
    simplify' :: (a, b, c) -> ReduceM (a, b, c)
simplify' (a
x,b
y,c
z) =
        do  (x,(y,z)) <- (a, (b, c)) -> ReduceM (a, (b, c))
forall t. Simplify t => t -> ReduceM t
simplify' (a
x,(b
y,c
z))
            return (x,y,z)

instance Simplify Bool where
  simplify' :: Bool -> ReduceM Bool
simplify' = Bool -> ReduceM Bool
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- interesting instances:

instance Simplify Term where
  simplify' :: Term -> ReduceM Term
simplify' Term
v = do
    v <- Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' Term
v
    let iapp [Elim]
es ReduceM Term
m = Blocked' Term Term -> Term
forall t a. Blocked' t a -> a
ignoreBlocking (Blocked' Term Term -> Term)
-> ReduceM (Blocked' Term Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> ReduceM (Blocked' Term Term))
-> ReduceM (Blocked' Term Term)
-> [Elim]
-> ReduceM (Blocked' Term Term)
reduceIApply' ((Term -> Blocked' Term Term)
-> ReduceM Term -> ReduceM (Blocked' Term Term)
forall a b. (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> Blocked' Term Term
forall a t. a -> Blocked' t a
notBlocked (ReduceM Term -> ReduceM (Blocked' Term Term))
-> (Term -> ReduceM Term) -> Term -> ReduceM (Blocked' Term Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify') (Term -> Blocked' Term Term
forall a t. a -> Blocked' t a
notBlocked (Term -> Blocked' Term Term)
-> ReduceM Term -> ReduceM (Blocked' Term Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReduceM Term
m) [Elim]
es
    case v of
      Def QName
f [Elim]
vs   -> [Elim] -> ReduceM Term -> ReduceM Term
iapp [Elim]
vs (ReduceM Term -> ReduceM Term) -> ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ do
        let keepGoing :: a -> a -> m (a, Blocked' t a)
keepGoing a
simp a
v = (a, Blocked' t a) -> m (a, Blocked' t a)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (a
simp, a -> Blocked' t a
forall a t. a -> Blocked' t a
notBlocked a
v)
        (simpl, v) <- (Simplification
 -> Term -> ReduceM (Simplification, Blocked' Term Term))
-> Term
-> QName
-> [Elim]
-> ReduceM (Simplification, Blocked' Term Term)
unfoldDefinition' Simplification
-> Term -> ReduceM (Simplification, Blocked' Term Term)
forall {m :: * -> *} {a} {a} {t}.
Monad m =>
a -> a -> m (a, Blocked' t a)
keepGoing (QName -> [Elim] -> Term
Def QName
f []) QName
f [Elim]
vs
        when (simpl == YesSimplification) $
          reportSDoc "tc.simplify'" 90 $
            pretty f <+> text ("simplify': unfolding definition returns " ++! show simpl) <+> pretty (ignoreBlocking v)
        case simpl of
          Simplification
YesSimplification -> Blocked' Term Term -> ReduceM Term
forall t. Simplify t => Blocked t -> ReduceM t
simplifyBlocked' Blocked' Term Term
v -- Dangerous, but if @simpl@ then @v /= Def f vs@
          Simplification
NoSimplification  -> QName -> [Elim] -> Term
Def QName
f ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Simplify t => t -> ReduceM t
simplify' [Elim]
vs
      MetaV MetaId
x [Elim]
vs -> [Elim] -> ReduceM Term -> ReduceM Term
iapp [Elim]
vs (ReduceM Term -> ReduceM Term) -> ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ MetaId -> [Elim] -> Term
MetaV MetaId
x  ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Simplify t => t -> ReduceM t
simplify' [Elim]
vs
      Con ConHead
c ConInfo
ci [Elim]
vs-> [Elim] -> ReduceM Term -> ReduceM Term
iapp [Elim]
vs (ReduceM Term -> ReduceM Term) -> ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ ConHead -> ConInfo -> [Elim] -> Term
Con ConHead
c ConInfo
ci ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Simplify t => t -> ReduceM t
simplify' [Elim]
vs
      Sort Sort' Term
s     -> Sort' Term -> Term
Sort     (Sort' Term -> Term) -> ReduceM (Sort' Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Simplify t => t -> ReduceM t
simplify' Sort' Term
s
      Level Level' Term
l    -> Level' Term -> Term
levelTm  (Level' Term -> Term) -> ReduceM (Level' Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level' Term -> ReduceM (Level' Term)
forall t. Simplify t => t -> ReduceM t
simplify' Level' Term
l
      Pi Dom' Term Type
a Abs Type
b     -> Dom' Term Type -> Abs Type -> Term
Pi       (Dom' Term Type -> Abs Type -> Term)
-> ReduceM (Dom' Term Type) -> ReduceM (Abs Type -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom' Term Type -> ReduceM (Dom' Term Type)
forall t. Simplify t => t -> ReduceM t
simplify' Dom' Term Type
a ReduceM (Abs Type -> Term) -> ReduceM (Abs Type) -> ReduceM Term
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Abs Type -> ReduceM (Abs Type)
forall t. Simplify t => t -> ReduceM t
simplify' Abs Type
b
      Lit Literal
l      -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
      Var Int
i [Elim]
vs   -> [Elim] -> ReduceM Term -> ReduceM Term
iapp [Elim]
vs (ReduceM Term -> ReduceM Term) -> ReduceM Term -> ReduceM Term
forall a b. (a -> b) -> a -> b
$ Int -> [Elim] -> Term
Var Int
i    ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Simplify t => t -> ReduceM t
simplify' [Elim]
vs
      Lam ArgInfo
h Abs Term
v    -> ArgInfo -> Abs Term -> Term
Lam ArgInfo
h    (Abs Term -> Term) -> ReduceM (Abs Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs Term -> ReduceM (Abs Term)
forall t. Simplify t => t -> ReduceM t
simplify' Abs Term
v
      DontCare Term
v -> Term -> Term
dontCare (Term -> Term) -> ReduceM Term -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify' Term
v
      Dummy{}    -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v

simplifyBlocked' :: Simplify t => Blocked t -> ReduceM t
simplifyBlocked' :: forall t. Simplify t => Blocked t -> ReduceM t
simplifyBlocked' (Blocked Blocker
_ t
t) = t -> ReduceM t
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return t
t
simplifyBlocked' (NotBlocked NotBlocked
_ t
t) = t -> ReduceM t
forall t. Simplify t => t -> ReduceM t
simplify' t
t  -- Andrea(s), 2014-12-05 OK?

instance Simplify t => Simplify (Type' t) where
    simplify' :: Type' t -> ReduceM (Type' t)
simplify' (El Sort' Term
s t
t) = Sort' Term -> t -> Type' t
forall t a. Sort' t -> a -> Type'' t a
El (Sort' Term -> t -> Type' t)
-> ReduceM (Sort' Term) -> ReduceM (t -> Type' t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Simplify t => t -> ReduceM t
simplify' Sort' Term
s ReduceM (t -> Type' t) -> ReduceM t -> ReduceM (Type' t)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> ReduceM t
forall t. Simplify t => t -> ReduceM t
simplify' t
t

instance Simplify Sort where
    simplify' :: Sort' Term -> ReduceM (Sort' Term)
simplify' Sort' Term
s = do
      case Sort' Term
s of
        PiSort Dom' Term Term
a Sort' Term
s1 Abs (Sort' Term)
s2 -> (Dom' Term Term
 -> Sort' Term -> Abs (Sort' Term) -> ReduceM (Sort' Term))
-> (Dom' Term Term, Sort' Term, Abs (Sort' Term))
-> ReduceM (Sort' Term)
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Dom' Term Term
-> Sort' Term -> Abs (Sort' Term) -> ReduceM (Sort' Term)
forall (m :: * -> *).
HasOptions m =>
Dom' Term Term -> Sort' Term -> Abs (Sort' Term) -> m (Sort' Term)
piSortM ((Dom' Term Term, Sort' Term, Abs (Sort' Term))
 -> ReduceM (Sort' Term))
-> ReduceM (Dom' Term Term, Sort' Term, Abs (Sort' Term))
-> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Dom' Term Term, Sort' Term, Abs (Sort' Term))
-> ReduceM (Dom' Term Term, Sort' Term, Abs (Sort' Term))
forall t. Simplify t => t -> ReduceM t
simplify' (Dom' Term Term
a, Sort' Term
s1, Abs (Sort' Term)
s2)
        FunSort Sort' Term
s1 Sort' Term
s2 -> (Sort' Term -> Sort' Term -> ReduceM (Sort' Term))
-> (Sort' Term, Sort' Term) -> ReduceM (Sort' Term)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Sort' Term -> Sort' Term -> ReduceM (Sort' Term)
forall (m :: * -> *).
HasOptions m =>
Sort' Term -> Sort' Term -> m (Sort' Term)
funSortM ((Sort' Term, Sort' Term) -> ReduceM (Sort' Term))
-> ReduceM (Sort' Term, Sort' Term) -> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Sort' Term, Sort' Term) -> ReduceM (Sort' Term, Sort' Term)
forall t. Simplify t => t -> ReduceM t
simplify' (Sort' Term
s1, Sort' Term
s2)
        UnivSort Sort' Term
s -> Sort' Term -> Sort' Term
univSort (Sort' Term -> Sort' Term)
-> ReduceM (Sort' Term) -> ReduceM (Sort' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Simplify t => t -> ReduceM t
simplify' Sort' Term
s
        Univ Univ
u Level' Term
s   -> Univ -> Level' Term -> Sort' Term
forall t. Univ -> Level' t -> Sort' t
Univ Univ
u (Level' Term -> Sort' Term)
-> ReduceM (Level' Term) -> ReduceM (Sort' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level' Term -> ReduceM (Level' Term)
forall t. Simplify t => t -> ReduceM t
simplify' Level' Term
s
        Inf Univ
_ Integer
_    -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
        Sort' Term
SizeUniv   -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
        Sort' Term
LockUniv   -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
        Sort' Term
LevelUniv  -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
        Sort' Term
IntervalUniv -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
        MetaS MetaId
x [Elim]
es -> MetaId -> [Elim] -> Sort' Term
forall t. MetaId -> [Elim' t] -> Sort' t
MetaS MetaId
x ([Elim] -> Sort' Term) -> ReduceM [Elim] -> ReduceM (Sort' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Simplify t => t -> ReduceM t
simplify' [Elim]
es
        DefS QName
d [Elim]
es  -> QName -> [Elim] -> Sort' Term
forall t. QName -> [Elim' t] -> Sort' t
DefS QName
d ([Elim] -> Sort' Term) -> ReduceM [Elim] -> ReduceM (Sort' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Simplify t => t -> ReduceM t
simplify' [Elim]
es
        DummyS{}   -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s

instance Simplify Level where
  simplify' :: Level' Term -> ReduceM (Level' Term)
simplify' (Max Integer
m [PlusLevel]
as) = Integer -> [PlusLevel] -> Level' Term
levelMax Integer
m ([PlusLevel] -> Level' Term)
-> ReduceM [PlusLevel] -> ReduceM (Level' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PlusLevel] -> ReduceM [PlusLevel]
forall t. Simplify t => t -> ReduceM t
simplify' [PlusLevel]
as

instance Simplify PlusLevel where
  simplify' :: PlusLevel -> ReduceM PlusLevel
simplify' (Plus Integer
n Term
l) = Integer -> Term -> PlusLevel
forall t. Integer -> t -> PlusLevel' t
Plus Integer
n (Term -> PlusLevel) -> ReduceM Term -> ReduceM PlusLevel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify' Term
l

instance (Subst a, Simplify a) => Simplify (Abs a) where
    simplify' :: Abs a -> ReduceM (Abs a)
simplify' a :: Abs a
a@(Abs [Char]
x a
_) = [Char] -> a -> Abs a
forall a. [Char] -> a -> Abs a
Abs [Char]
x (a -> Abs a) -> ReduceM a -> ReduceM (Abs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs a -> (a -> ReduceM a) -> ReduceM a
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs a
a a -> ReduceM a
forall t. Simplify t => t -> ReduceM t
simplify'
    simplify' (NoAbs [Char]
x a
v) = [Char] -> a -> Abs a
forall a. [Char] -> a -> Abs a
NoAbs [Char]
x (a -> Abs a) -> ReduceM a -> ReduceM (Abs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Simplify t => t -> ReduceM t
simplify' a
v

instance Simplify t => Simplify (Dom t) where
    simplify' :: Dom t -> ReduceM (Dom t)
simplify' = (t -> ReduceM t) -> Dom t -> ReduceM (Dom t)
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) -> Dom' Term a -> f (Dom' Term b)
traverse t -> ReduceM t
forall t. Simplify t => t -> ReduceM t
simplify'

instance Simplify a => Simplify (Closure a) where
    simplify' :: Closure a -> ReduceM (Closure a)
simplify' Closure a
cl = do
        x <- Closure a -> (a -> ReduceM a) -> ReduceM a
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure Closure a
cl a -> ReduceM a
forall t. Simplify t => t -> ReduceM t
simplify'
        return $ cl { clValue = x }

instance (Subst a, Simplify a) => Simplify (Tele a) where
  simplify' :: Tele a -> ReduceM (Tele a)
simplify' Tele a
EmptyTel        = Tele a -> ReduceM (Tele a)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Tele a
forall a. Tele a
EmptyTel
  simplify' (ExtendTel a
a Abs (Tele a)
b) = (a -> Abs (Tele a) -> Tele a) -> (a, Abs (Tele a)) -> Tele a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> Abs (Tele a) -> Tele a
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel ((a, Abs (Tele a)) -> Tele a)
-> ReduceM (a, Abs (Tele a)) -> ReduceM (Tele a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, Abs (Tele a)) -> ReduceM (a, Abs (Tele a))
forall t. Simplify t => t -> ReduceM t
simplify' (a
a, Abs (Tele a)
b)

instance Simplify ProblemConstraint where
  simplify' :: ProblemConstraint -> ReduceM ProblemConstraint
simplify' (PConstr Set ProblemId
pid Blocker
unblock Closure Constraint
c) = Set ProblemId -> Blocker -> Closure Constraint -> ProblemConstraint
PConstr Set ProblemId
pid Blocker
unblock (Closure Constraint -> ProblemConstraint)
-> ReduceM (Closure Constraint) -> ReduceM ProblemConstraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure Constraint -> ReduceM (Closure Constraint)
forall t. Simplify t => t -> ReduceM t
simplify' Closure Constraint
c

instance Simplify LocalEquation where
  simplify' :: LocalEquation' Term -> ReduceM (LocalEquation' Term)
simplify' (LocalEquation Telescope
g Term
t Term
u Type
a) = do
    g' <- Telescope -> ReduceM Telescope
forall t. Simplify t => t -> ReduceM t
simplify' Telescope
g
    (t', u', a') <- addContext g' $ simplify (t, u, a)
    return $ LocalEquation g' t' u' a'

instance Simplify Constraint where
  simplify' :: Constraint -> ReduceM Constraint
simplify' (ValueCmp Comparison
cmp CompareAs
t Term
u Term
v) = do
    (t,u,v) <- (CompareAs, Term, Term) -> ReduceM (CompareAs, Term, Term)
forall t. Simplify t => t -> ReduceM t
simplify' (CompareAs
t,Term
u,Term
v)
    return $ ValueCmp cmp t u v
  simplify' (ValueCmpOnFace Comparison
cmp Term
p Type
t Term
u Term
v) = do
    ((p,t),u,v) <- ((Term, Type), Term, Term) -> ReduceM ((Term, Type), Term, Term)
forall t. Simplify t => t -> ReduceM t
simplify' ((Term
p,Type
t),Term
u,Term
v)
    return $ ValueCmp cmp (AsTermsOf t) u v
  simplify' (ElimCmp [Polarity]
cmp [IsForced]
fs Type
t Term
v [Elim]
as [Elim]
bs) =
    [Polarity]
-> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> Constraint
ElimCmp [Polarity]
cmp [IsForced]
fs (Type -> Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Type -> ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
t ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Term -> ReduceM ([Elim] -> [Elim] -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify' Term
v ReduceM ([Elim] -> [Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM ([Elim] -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Elim] -> ReduceM [Elim]
forall t. Simplify t => t -> ReduceM t
simplify' [Elim]
as ReduceM ([Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Elim] -> ReduceM [Elim]
forall t. Simplify t => t -> ReduceM t
simplify' [Elim]
bs
  simplify' (LevelCmp Comparison
cmp Level' Term
u Level' Term
v)    = (Level' Term -> Level' Term -> Constraint)
-> (Level' Term, Level' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Level' Term -> Level' Term -> Constraint
LevelCmp Comparison
cmp) ((Level' Term, Level' Term) -> Constraint)
-> ReduceM (Level' Term, Level' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Level' Term, Level' Term) -> ReduceM (Level' Term, Level' Term)
forall t. Simplify t => t -> ReduceM t
simplify' (Level' Term
u,Level' Term
v)
  simplify' (SortCmp Comparison
cmp Sort' Term
a Sort' Term
b)     = (Sort' Term -> Sort' Term -> Constraint)
-> (Sort' Term, Sort' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Sort' Term -> Sort' Term -> Constraint
SortCmp Comparison
cmp) ((Sort' Term, Sort' Term) -> Constraint)
-> ReduceM (Sort' Term, Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sort' Term, Sort' Term) -> ReduceM (Sort' Term, Sort' Term)
forall t. Simplify t => t -> ReduceM t
simplify' (Sort' Term
a,Sort' Term
b)
  simplify' (UnBlock MetaId
m)           = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ MetaId -> Constraint
UnBlock MetaId
m
  simplify' (FindInstance Range
r MetaId
m Maybe [Candidate]
cs)   = Range -> MetaId -> Maybe [Candidate] -> Constraint
FindInstance Range
r MetaId
m (Maybe [Candidate] -> Constraint)
-> ReduceM (Maybe [Candidate]) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Candidate] -> ReduceM [Candidate])
-> Maybe [Candidate] -> ReduceM (Maybe [Candidate])
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) -> Maybe a -> m (Maybe b)
mapM [Candidate] -> ReduceM [Candidate]
forall t. Simplify t => t -> ReduceM t
simplify' Maybe [Candidate]
cs
  simplify' (ResolveInstanceHead KwRange
kwr QName
q) = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ KwRange -> QName -> Constraint
ResolveInstanceHead KwRange
kwr QName
q
  simplify' (IsEmpty Range
r Type
t)         = Range -> Type -> Constraint
IsEmpty Range
r (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
t
  simplify' (CheckSizeLtSat Term
t)    = Term -> Constraint
CheckSizeLtSat (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify' Term
t
  simplify' c :: Constraint
c@CheckFunDef{}       = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
  simplify' (HasBiggerSort Sort' Term
a)     = Sort' Term -> Constraint
HasBiggerSort (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Simplify t => t -> ReduceM t
simplify' Sort' Term
a
  simplify' (HasPTSRule Dom' Term Type
a Abs (Sort' Term)
b)      = (Dom' Term Type -> Abs (Sort' Term) -> Constraint)
-> (Dom' Term Type, Abs (Sort' Term)) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Dom' Term Type -> Abs (Sort' Term) -> Constraint
HasPTSRule ((Dom' Term Type, Abs (Sort' Term)) -> Constraint)
-> ReduceM (Dom' Term Type, Abs (Sort' Term)) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dom' Term Type, Abs (Sort' Term))
-> ReduceM (Dom' Term Type, Abs (Sort' Term))
forall t. Simplify t => t -> ReduceM t
simplify' (Dom' Term Type
a,Abs (Sort' Term)
b)
  simplify' (UnquoteTactic Term
t Term
h Type
g) = Term -> Term -> Type -> Constraint
UnquoteTactic (Term -> Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Term -> Type -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify' Term
t ReduceM (Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify' Term
h ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
g
  simplify' (CheckLockedVars Term
a Type
b Arg Term
c Type
d) =
    Term -> Type -> Arg Term -> Type -> Constraint
CheckLockedVars (Term -> Type -> Arg Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Arg Term -> Type -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify' Term
a ReduceM (Type -> Arg Term -> Type -> Constraint)
-> ReduceM Type -> ReduceM (Arg Term -> Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
b ReduceM (Arg Term -> Type -> Constraint)
-> ReduceM (Arg Term) -> ReduceM (Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Simplify t => t -> ReduceM t
simplify' Arg Term
c ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
d
  simplify' (CheckDataSort QName
q Sort' Term
s)   = QName -> Sort' Term -> Constraint
CheckDataSort QName
q (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Simplify t => t -> ReduceM t
simplify' Sort' Term
s
  simplify' c :: Constraint
c@CheckMetaInst{}     = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
  simplify' (CheckType Type
t)         = Type -> Constraint
CheckType (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
t
  simplify' (UsableAtModality WhyCheckModality
cc Maybe (Sort' Term)
ms Modality
mod Term
t) = (Maybe (Sort' Term) -> Modality -> Term -> Constraint)
-> Modality -> Maybe (Sort' Term) -> Term -> Constraint
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WhyCheckModality
-> Maybe (Sort' Term) -> Modality -> Term -> Constraint
UsableAtModality WhyCheckModality
cc) Modality
mod (Maybe (Sort' Term) -> Term -> Constraint)
-> ReduceM (Maybe (Sort' Term)) -> ReduceM (Term -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Sort' Term) -> ReduceM (Maybe (Sort' Term))
forall t. Simplify t => t -> ReduceM t
simplify' Maybe (Sort' Term)
ms ReduceM (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify' Term
t
  simplify' (RewConstraint LocalEquation' Term
e)     = LocalEquation' Term -> Constraint
RewConstraint (LocalEquation' Term -> Constraint)
-> ReduceM (LocalEquation' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalEquation' Term -> ReduceM (LocalEquation' Term)
forall t. Simplify t => t -> ReduceM t
simplify' LocalEquation' Term
e

instance Simplify CompareAs where
  simplify' :: CompareAs -> ReduceM CompareAs
simplify' (AsTermsOf Type
a) = Type -> CompareAs
AsTermsOf (Type -> CompareAs) -> ReduceM Type -> ReduceM CompareAs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
a
  simplify' CompareAs
AsSizes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsSizes
  simplify' CompareAs
AsTypes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsTypes

-- UNUSED
-- instance Simplify ConPatternInfo where
--   simplify' (ConPatternInfo mr mt) = ConPatternInfo mr <$> simplify' mt

-- UNUSED
-- instance Simplify Pattern where
--   simplify' p = case p of
--     VarP _       -> return p
--     LitP _       -> return p
--     ConP c ci ps -> ConP c <$> simplify' ci <*> simplify' ps
--     DotP v       -> DotP <$> simplify' v
--     ProjP _      -> return p

instance Simplify DisplayForm where
  simplify' :: DisplayForm -> ReduceM DisplayForm
simplify' (Display Int
n [Elim]
ps DisplayTerm
v) = Int -> [Elim] -> DisplayTerm -> DisplayForm
Display Int
n ([Elim] -> DisplayTerm -> DisplayForm)
-> ReduceM [Elim] -> ReduceM (DisplayTerm -> DisplayForm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Simplify t => t -> ReduceM t
simplify' [Elim]
ps ReduceM (DisplayTerm -> DisplayForm)
-> ReduceM DisplayTerm -> ReduceM DisplayForm
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DisplayTerm -> ReduceM DisplayTerm
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayTerm
v

instance Simplify Candidate where
  simplify' :: Candidate -> ReduceM Candidate
simplify' (Candidate CandidateKind
q Term
u Type
t OverlapMode
ov) = CandidateKind -> Term -> Type -> OverlapMode -> Candidate
Candidate CandidateKind
q (Term -> Type -> OverlapMode -> Candidate)
-> ReduceM Term -> ReduceM (Type -> OverlapMode -> Candidate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Simplify t => t -> ReduceM t
simplify' Term
u ReduceM (Type -> OverlapMode -> Candidate)
-> ReduceM Type -> ReduceM (OverlapMode -> Candidate)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
t ReduceM (OverlapMode -> Candidate)
-> ReduceM OverlapMode -> ReduceM Candidate
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OverlapMode -> ReduceM OverlapMode
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OverlapMode
ov

instance Simplify EqualityView where
  simplify' :: EqualityView -> ReduceM EqualityView
simplify' (OtherType Type
t)            = Type -> EqualityView
OtherType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
t
  simplify' (IdiomType Type
t)            = Type -> EqualityView
IdiomType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Simplify t => t -> ReduceM t
simplify' Type
t
  simplify' (EqualityType Range
r Sort' Term
s QName
eq Args
l Arg Term
t Arg Term
a Arg Term
b) = Range
-> Sort' Term
-> QName
-> Args
-> Arg Term
-> Arg Term
-> Arg Term
-> EqualityView
EqualityType Range
r
    (Sort' Term
 -> QName
 -> Args
 -> Arg Term
 -> Arg Term
 -> Arg Term
 -> EqualityView)
-> ReduceM (Sort' Term)
-> ReduceM
     (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Simplify t => t -> ReduceM t
simplify' Sort' Term
s
    ReduceM
  (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM QName
-> ReduceM
     (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QName -> ReduceM QName
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
eq
    ReduceM (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM Args
-> ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Arg Term -> ReduceM (Arg Term)) -> Args -> ReduceM Args
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 -> ReduceM (Arg Term)
forall t. Simplify t => t -> ReduceM t
simplify' Args
l
    ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term)
-> ReduceM (Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Simplify t => t -> ReduceM t
simplify' Arg Term
t
    ReduceM (Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM (Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Simplify t => t -> ReduceM t
simplify' Arg Term
a
    ReduceM (Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM EqualityView
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Simplify t => t -> ReduceM t
simplify' Arg Term
b

---------------------------------------------------------------------------
-- * Normalisation
---------------------------------------------------------------------------

class Normalise t where
  normalise' :: t -> ReduceM t

  default normalise' :: (t ~ f a, Traversable f, Normalise a) => t -> ReduceM t
  normalise' = (a -> ReduceM a) -> f a -> ReduceM (f a)
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) -> f a -> f (f b)
traverse a -> ReduceM a
forall t. Normalise t => t -> ReduceM t
normalise'

-- Functor instances:

instance Normalise t => Normalise [t]
instance Normalise t => Normalise (List1 t)
instance Normalise t => Normalise (Map k t)
instance Normalise t => Normalise (Maybe t)
instance Normalise t => Normalise (Strict.Maybe t)

-- Arg not included since we do not normalize irrelevant subterms
-- Elim' not included since it contains Arg
instance Normalise t => Normalise (Named name t)
instance Normalise t => Normalise (IPBoundary' t)
instance Normalise t => Normalise (Ranged t)
instance Normalise t => Normalise (WithHiding t)

-- more boring instances:

instance (Normalise a, Normalise b) => Normalise (a,b) where
    normalise' :: (a, b) -> ReduceM (a, b)
normalise' (a
x,b
y) = (,) (a -> b -> (a, b)) -> ReduceM a -> ReduceM (b -> (a, b))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Normalise t => t -> ReduceM t
normalise' a
x ReduceM (b -> (a, b)) -> ReduceM b -> ReduceM (a, b)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> b -> ReduceM b
forall t. Normalise t => t -> ReduceM t
normalise' b
y

instance (Normalise a, Normalise b, Normalise c) => Normalise (a,b,c) where
    normalise' :: (a, b, c) -> ReduceM (a, b, c)
normalise' (a
x,b
y,c
z) =
        do  (x,(y,z)) <- (a, (b, c)) -> ReduceM (a, (b, c))
forall t. Normalise t => t -> ReduceM t
normalise' (a
x,(b
y,c
z))
            return (x,y,z)

instance Normalise Bool where
  normalise' :: Bool -> ReduceM Bool
normalise' = Bool -> ReduceM Bool
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Normalise Char where
  normalise' :: Char -> ReduceM Char
normalise' = Char -> ReduceM Char
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Normalise Int where
  normalise' :: Int -> ReduceM Int
normalise' = Int -> ReduceM Int
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance Normalise DBPatVar where
  normalise' :: DBPatVar -> ReduceM DBPatVar
normalise' = DBPatVar -> ReduceM DBPatVar
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- interesting instances:

instance Normalise Sort where
    normalise' :: Sort' Term -> ReduceM (Sort' Term)
normalise' Sort' Term
s = do
      s <- Sort' Term -> ReduceM (Sort' Term)
forall t. Reduce t => t -> ReduceM t
reduce' Sort' Term
s
      case s of
        PiSort Dom' Term Term
a Sort' Term
s1 Abs (Sort' Term)
s2 -> (Dom' Term Term
 -> Sort' Term -> Abs (Sort' Term) -> ReduceM (Sort' Term))
-> (Dom' Term Term, Sort' Term, Abs (Sort' Term))
-> ReduceM (Sort' Term)
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Dom' Term Term
-> Sort' Term -> Abs (Sort' Term) -> ReduceM (Sort' Term)
forall (m :: * -> *).
HasOptions m =>
Dom' Term Term -> Sort' Term -> Abs (Sort' Term) -> m (Sort' Term)
piSortM ((Dom' Term Term, Sort' Term, Abs (Sort' Term))
 -> ReduceM (Sort' Term))
-> ReduceM (Dom' Term Term, Sort' Term, Abs (Sort' Term))
-> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Dom' Term Term, Sort' Term, Abs (Sort' Term))
-> ReduceM (Dom' Term Term, Sort' Term, Abs (Sort' Term))
forall t. Normalise t => t -> ReduceM t
normalise' (Dom' Term Term
a, Sort' Term
s1, Abs (Sort' Term)
s2)
        FunSort Sort' Term
s1 Sort' Term
s2 -> (Sort' Term -> Sort' Term -> ReduceM (Sort' Term))
-> (Sort' Term, Sort' Term) -> ReduceM (Sort' Term)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Sort' Term -> Sort' Term -> ReduceM (Sort' Term)
forall (m :: * -> *).
HasOptions m =>
Sort' Term -> Sort' Term -> m (Sort' Term)
funSortM ((Sort' Term, Sort' Term) -> ReduceM (Sort' Term))
-> ReduceM (Sort' Term, Sort' Term) -> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Sort' Term, Sort' Term) -> ReduceM (Sort' Term, Sort' Term)
forall t. Normalise t => t -> ReduceM t
normalise' (Sort' Term
s1, Sort' Term
s2)
        UnivSort Sort' Term
s -> Sort' Term -> Sort' Term
univSort (Sort' Term -> Sort' Term)
-> ReduceM (Sort' Term) -> ReduceM (Sort' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Normalise t => t -> ReduceM t
normalise' Sort' Term
s
        Univ Univ
u Level' Term
s   -> Univ -> Level' Term -> Sort' Term
forall t. Univ -> Level' t -> Sort' t
Univ Univ
u (Level' Term -> Sort' Term)
-> ReduceM (Level' Term) -> ReduceM (Sort' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level' Term -> ReduceM (Level' Term)
forall t. Normalise t => t -> ReduceM t
normalise' Level' Term
s
        Inf Univ
_ Integer
_    -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
        Sort' Term
SizeUniv   -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
forall t. Sort' t
SizeUniv
        Sort' Term
LockUniv   -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
forall t. Sort' t
LockUniv
        Sort' Term
LevelUniv  -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
forall t. Sort' t
LevelUniv
        Sort' Term
IntervalUniv -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
forall t. Sort' t
IntervalUniv
        MetaS MetaId
x [Elim]
es -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
        DefS QName
d [Elim]
es  -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
        DummyS{}   -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s

instance Normalise t => Normalise (Type' t) where
    normalise' :: Type' t -> ReduceM (Type' t)
normalise' (El Sort' Term
s t
t) = Sort' Term -> t -> Type' t
forall t a. Sort' t -> a -> Type'' t a
El (Sort' Term -> t -> Type' t)
-> ReduceM (Sort' Term) -> ReduceM (t -> Type' t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Normalise t => t -> ReduceM t
normalise' Sort' Term
s ReduceM (t -> Type' t) -> ReduceM t -> ReduceM (Type' t)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> ReduceM t
forall t. Normalise t => t -> ReduceM t
normalise' t
t

instance Normalise Term where
    normalise' :: Term -> ReduceM Term
normalise' Term
v = ReduceM Bool -> ReduceM Term -> ReduceM Term -> ReduceM Term
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM ReduceM Bool
shouldTryFastReduce (Term -> ReduceM Term
fastNormalise Term
v) (Term -> ReduceM Term
slowNormaliseArgs (Term -> ReduceM Term) -> ReduceM Term -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> ReduceM Term
forall t. Reduce t => t -> ReduceM t
reduce' Term
v)

slowNormaliseArgs :: Term -> ReduceM Term
slowNormaliseArgs :: Term -> ReduceM Term
slowNormaliseArgs = \case
  Var Int
n [Elim]
vs    -> Int -> [Elim] -> Term
Var Int
n      ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Normalise t => t -> ReduceM t
normalise' [Elim]
vs
  Con ConHead
c ConInfo
ci [Elim]
vs -> ConHead -> ConInfo -> [Elim] -> Term
Con ConHead
c ConInfo
ci   ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Normalise t => t -> ReduceM t
normalise' [Elim]
vs
  Def QName
f [Elim]
vs    -> QName -> [Elim] -> Term
Def QName
f      ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Normalise t => t -> ReduceM t
normalise' [Elim]
vs
  MetaV MetaId
x [Elim]
vs  -> MetaId -> [Elim] -> Term
MetaV MetaId
x    ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Normalise t => t -> ReduceM t
normalise' [Elim]
vs
  v :: Term
v@(Lit Literal
_)   -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
  Level Level' Term
l     -> Level' Term -> Term
levelTm    (Level' Term -> Term) -> ReduceM (Level' Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Level' Term -> ReduceM (Level' Term)
forall t. Normalise t => t -> ReduceM t
normalise' Level' Term
l
  Lam ArgInfo
h Abs Term
b     -> ArgInfo -> Abs Term -> Term
Lam ArgInfo
h      (Abs Term -> Term) -> ReduceM (Abs Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs Term -> ReduceM (Abs Term)
forall t. Normalise t => t -> ReduceM t
normalise' Abs Term
b
  Sort Sort' Term
s      -> Sort' Term -> Term
Sort       (Sort' Term -> Term) -> ReduceM (Sort' Term) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Normalise t => t -> ReduceM t
normalise' Sort' Term
s
  Pi Dom' Term Type
a Abs Type
b      -> (Dom' Term Type -> Abs Type -> Term)
-> (Dom' Term Type, Abs Type) -> Term
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Dom' Term Type -> Abs Type -> Term
Pi ((Dom' Term Type, Abs Type) -> Term)
-> ReduceM (Dom' Term Type, Abs Type) -> ReduceM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dom' Term Type, Abs Type) -> ReduceM (Dom' Term Type, Abs Type)
forall t. Normalise t => t -> ReduceM t
normalise' (Dom' Term Type
a, Abs Type
b)
  v :: Term
v@DontCare{}-> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
  v :: Term
v@Dummy{}   -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v

-- Note: not the default instance for Elim' since we do something special for Arg.
instance Normalise t => Normalise (Elim' t) where
  normalise' :: Elim' t -> ReduceM (Elim' t)
normalise' (Apply Arg t
v) = Arg t -> Elim' t
forall a. Arg a -> Elim' a
Apply (Arg t -> Elim' t) -> ReduceM (Arg t) -> ReduceM (Elim' t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Arg t -> ReduceM (Arg t)
forall t. Normalise t => t -> ReduceM t
normalise' Arg t
v  -- invokes Normalise Arg here
  normalise' (Proj ProjOrigin
o QName
f)= Elim' t -> ReduceM (Elim' t)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Elim' t -> ReduceM (Elim' t)) -> Elim' t -> ReduceM (Elim' t)
forall a b. (a -> b) -> a -> b
$ ProjOrigin -> QName -> Elim' t
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
o QName
f
  normalise' (IApply t
x t
y t
v) = t -> t -> t -> Elim' t
forall a. a -> a -> a -> Elim' a
IApply (t -> t -> t -> Elim' t)
-> ReduceM t -> ReduceM (t -> t -> Elim' t)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t -> ReduceM t
forall t. Normalise t => t -> ReduceM t
normalise' t
x ReduceM (t -> t -> Elim' t) -> ReduceM t -> ReduceM (t -> Elim' t)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> ReduceM t
forall t. Normalise t => t -> ReduceM t
normalise' t
y ReduceM (t -> Elim' t) -> ReduceM t -> ReduceM (Elim' t)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t -> ReduceM t
forall t. Normalise t => t -> ReduceM t
normalise' t
v

instance Normalise Level where
  normalise' :: Level' Term -> ReduceM (Level' Term)
normalise' (Max Integer
m [PlusLevel]
as) = Integer -> [PlusLevel] -> Level' Term
levelMax Integer
m ([PlusLevel] -> Level' Term)
-> ReduceM [PlusLevel] -> ReduceM (Level' Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [PlusLevel] -> ReduceM [PlusLevel]
forall t. Normalise t => t -> ReduceM t
normalise' [PlusLevel]
as

instance Normalise PlusLevel where
  normalise' :: PlusLevel -> ReduceM PlusLevel
normalise' (Plus Integer
n Term
l) = Integer -> Term -> PlusLevel
forall t. Integer -> t -> PlusLevel' t
Plus Integer
n (Term -> PlusLevel) -> ReduceM Term -> ReduceM PlusLevel
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
l

instance (Subst a, Normalise a) => Normalise (Abs a) where
    normalise' :: Abs a -> ReduceM (Abs a)
normalise' a :: Abs a
a@(Abs [Char]
x a
_) = [Char] -> a -> Abs a
forall a. [Char] -> a -> Abs a
Abs [Char]
x (a -> Abs a) -> ReduceM a -> ReduceM (Abs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Abs a -> (a -> ReduceM a) -> ReduceM a
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs a
a a -> ReduceM a
forall t. Normalise t => t -> ReduceM t
normalise'
    normalise' (NoAbs [Char]
x a
v) = [Char] -> a -> Abs a
forall a. [Char] -> a -> Abs a
NoAbs [Char]
x (a -> Abs a) -> ReduceM a -> ReduceM (Abs a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Normalise t => t -> ReduceM t
normalise' a
v

instance Normalise t => Normalise (Arg t) where
    normalise' :: Arg t -> ReduceM (Arg t)
normalise' Arg t
a
      | Arg t -> Bool
forall a. LensRelevance a => a -> Bool
isIrrelevant Arg t
a = Arg t -> ReduceM (Arg t)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Arg t
a -- Andreas, 2012-04-02: Do not normalize irrelevant terms!?
      | Bool
otherwise      = (t -> ReduceM t) -> Arg t -> ReduceM (Arg t)
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) -> Arg a -> f (Arg b)
traverse t -> ReduceM t
forall t. Normalise t => t -> ReduceM t
normalise' Arg t
a

instance Normalise t => Normalise (Dom t) where
    normalise' :: Dom t -> ReduceM (Dom t)
normalise' = (t -> ReduceM t) -> Dom t -> ReduceM (Dom t)
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) -> Dom' Term a -> f (Dom' Term b)
traverse t -> ReduceM t
forall t. Normalise t => t -> ReduceM t
normalise'

instance Normalise a => Normalise (Closure a) where
    normalise' :: Closure a -> ReduceM (Closure a)
normalise' Closure a
cl = do
        x <- Closure a -> (a -> ReduceM a) -> ReduceM a
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure Closure a
cl a -> ReduceM a
forall t. Normalise t => t -> ReduceM t
normalise'
        return $ cl { clValue = x }

instance (Subst a, Normalise a) => Normalise (Tele a) where
  normalise' :: Tele a -> ReduceM (Tele a)
normalise' Tele a
tel = ((ReduceM (Tele a) -> Result (ReduceM (Tele a)))
 -> Result (ReduceM (Tele a)))
-> ReduceM (Tele a)
forall a. ExpandCase a => ((a -> Result a) -> Result a) -> a
expand \ReduceM (Tele a) -> Result (ReduceM (Tele a))
ret -> case Tele a
tel of
    Tele a
EmptyTel      -> ReduceM (Tele a) -> Result (ReduceM (Tele a))
ret (ReduceM (Tele a) -> Result (ReduceM (Tele a)))
-> ReduceM (Tele a) -> Result (ReduceM (Tele a))
forall a b. (a -> b) -> a -> b
$ Tele a -> ReduceM (Tele a)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Tele a
forall a. Tele a
EmptyTel
    ExtendTel a
a Abs (Tele a)
b -> ReduceM (Tele a) -> Result (ReduceM (Tele a))
ret (ReduceM (Tele a) -> Result (ReduceM (Tele a)))
-> ReduceM (Tele a) -> Result (ReduceM (Tele a))
forall a b. (a -> b) -> a -> b
$ (a -> Abs (Tele a) -> Tele a) -> (a, Abs (Tele a)) -> Tele a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> Abs (Tele a) -> Tele a
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel ((a, Abs (Tele a)) -> Tele a)
-> ReduceM (a, Abs (Tele a)) -> ReduceM (Tele a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a, Abs (Tele a)) -> ReduceM (a, Abs (Tele a))
forall t. Normalise t => t -> ReduceM t
normalise' (a
a, Abs (Tele a)
b)

instance Normalise ProblemConstraint where
  normalise' :: ProblemConstraint -> ReduceM ProblemConstraint
normalise' (PConstr Set ProblemId
pid Blocker
unblock Closure Constraint
c) = Set ProblemId -> Blocker -> Closure Constraint -> ProblemConstraint
PConstr Set ProblemId
pid Blocker
unblock (Closure Constraint -> ProblemConstraint)
-> ReduceM (Closure Constraint) -> ReduceM ProblemConstraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Closure Constraint -> ReduceM (Closure Constraint)
forall t. Normalise t => t -> ReduceM t
normalise' Closure Constraint
c

instance Normalise LocalEquation where
  normalise' :: LocalEquation' Term -> ReduceM (LocalEquation' Term)
normalise' (LocalEquation Telescope
g Term
t Term
u Type
a) = do
    g' <- Telescope -> ReduceM Telescope
forall a (m :: * -> *). (Normalise a, MonadReduce m) => a -> m a
normalise Telescope
g
    (t', u', a') <- addContext g' $ normalise (t, u, a)
    return $ LocalEquation g' t' u' a'

instance Normalise Constraint where
  normalise' :: Constraint -> ReduceM Constraint
normalise' (ValueCmp Comparison
cmp CompareAs
t Term
u Term
v) = do
    (t,u,v) <- (CompareAs, Term, Term) -> ReduceM (CompareAs, Term, Term)
forall t. Normalise t => t -> ReduceM t
normalise' (CompareAs
t,Term
u,Term
v)
    return $ ValueCmp cmp t u v
  normalise' (ValueCmpOnFace Comparison
cmp Term
p Type
t Term
u Term
v) = do
    ((p,t),u,v) <- ((Term, Type), Term, Term) -> ReduceM ((Term, Type), Term, Term)
forall t. Normalise t => t -> ReduceM t
normalise' ((Term
p,Type
t),Term
u,Term
v)
    return $ ValueCmpOnFace cmp p t u v
  normalise' (ElimCmp [Polarity]
cmp [IsForced]
fs Type
t Term
v [Elim]
as [Elim]
bs) =
    [Polarity]
-> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> Constraint
ElimCmp [Polarity]
cmp [IsForced]
fs (Type -> Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Type -> ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
t ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Term -> ReduceM ([Elim] -> [Elim] -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
v ReduceM ([Elim] -> [Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM ([Elim] -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Elim] -> ReduceM [Elim]
forall t. Normalise t => t -> ReduceM t
normalise' [Elim]
as ReduceM ([Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [Elim] -> ReduceM [Elim]
forall t. Normalise t => t -> ReduceM t
normalise' [Elim]
bs
  normalise' (LevelCmp Comparison
cmp Level' Term
u Level' Term
v)    = (Level' Term -> Level' Term -> Constraint)
-> (Level' Term, Level' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Level' Term -> Level' Term -> Constraint
LevelCmp Comparison
cmp) ((Level' Term, Level' Term) -> Constraint)
-> ReduceM (Level' Term, Level' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Level' Term, Level' Term) -> ReduceM (Level' Term, Level' Term)
forall t. Normalise t => t -> ReduceM t
normalise' (Level' Term
u,Level' Term
v)
  normalise' (SortCmp Comparison
cmp Sort' Term
a Sort' Term
b)     = (Sort' Term -> Sort' Term -> Constraint)
-> (Sort' Term, Sort' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Sort' Term -> Sort' Term -> Constraint
SortCmp Comparison
cmp) ((Sort' Term, Sort' Term) -> Constraint)
-> ReduceM (Sort' Term, Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Sort' Term, Sort' Term) -> ReduceM (Sort' Term, Sort' Term)
forall t. Normalise t => t -> ReduceM t
normalise' (Sort' Term
a,Sort' Term
b)
  normalise' (UnBlock MetaId
m)           = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ MetaId -> Constraint
UnBlock MetaId
m
  normalise' (FindInstance Range
r MetaId
m Maybe [Candidate]
cs)   = Range -> MetaId -> Maybe [Candidate] -> Constraint
FindInstance Range
r MetaId
m (Maybe [Candidate] -> Constraint)
-> ReduceM (Maybe [Candidate]) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ([Candidate] -> ReduceM [Candidate])
-> Maybe [Candidate] -> ReduceM (Maybe [Candidate])
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) -> Maybe a -> m (Maybe b)
mapM [Candidate] -> ReduceM [Candidate]
forall t. Normalise t => t -> ReduceM t
normalise' Maybe [Candidate]
cs
  normalise' (ResolveInstanceHead KwRange
kwr QName
q) = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ KwRange -> QName -> Constraint
ResolveInstanceHead KwRange
kwr QName
q
  normalise' (IsEmpty Range
r Type
t)         = Range -> Type -> Constraint
IsEmpty Range
r (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
t
  normalise' (CheckSizeLtSat Term
t)    = Term -> Constraint
CheckSizeLtSat (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
t
  normalise' c :: Constraint
c@CheckFunDef{}       = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
  normalise' (HasBiggerSort Sort' Term
a)     = Sort' Term -> Constraint
HasBiggerSort (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Normalise t => t -> ReduceM t
normalise' Sort' Term
a
  normalise' (HasPTSRule Dom' Term Type
a Abs (Sort' Term)
b)      = (Dom' Term Type -> Abs (Sort' Term) -> Constraint)
-> (Dom' Term Type, Abs (Sort' Term)) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Dom' Term Type -> Abs (Sort' Term) -> Constraint
HasPTSRule ((Dom' Term Type, Abs (Sort' Term)) -> Constraint)
-> ReduceM (Dom' Term Type, Abs (Sort' Term)) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Dom' Term Type, Abs (Sort' Term))
-> ReduceM (Dom' Term Type, Abs (Sort' Term))
forall t. Normalise t => t -> ReduceM t
normalise' (Dom' Term Type
a,Abs (Sort' Term)
b)
  normalise' (UnquoteTactic Term
t Term
h Type
g) = Term -> Term -> Type -> Constraint
UnquoteTactic (Term -> Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Term -> Type -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
t ReduceM (Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
h ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
g
  normalise' (CheckLockedVars Term
a Type
b Arg Term
c Type
d) =
    Term -> Type -> Arg Term -> Type -> Constraint
CheckLockedVars (Term -> Type -> Arg Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Arg Term -> Type -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
a ReduceM (Type -> Arg Term -> Type -> Constraint)
-> ReduceM Type -> ReduceM (Arg Term -> Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
b ReduceM (Arg Term -> Type -> Constraint)
-> ReduceM (Arg Term) -> ReduceM (Type -> Constraint)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Normalise t => t -> ReduceM t
normalise' Arg Term
c ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
d
  normalise' (CheckDataSort QName
q Sort' Term
s)   = QName -> Sort' Term -> Constraint
CheckDataSort QName
q (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Normalise t => t -> ReduceM t
normalise' Sort' Term
s
  normalise' c :: Constraint
c@CheckMetaInst{}     = Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
  normalise' (CheckType Type
t)         = Type -> Constraint
CheckType (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
t
  normalise' (UsableAtModality WhyCheckModality
cc Maybe (Sort' Term)
ms Modality
mod Term
t) = (Maybe (Sort' Term) -> Modality -> Term -> Constraint)
-> Modality -> Maybe (Sort' Term) -> Term -> Constraint
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WhyCheckModality
-> Maybe (Sort' Term) -> Modality -> Term -> Constraint
UsableAtModality WhyCheckModality
cc) Modality
mod (Maybe (Sort' Term) -> Term -> Constraint)
-> ReduceM (Maybe (Sort' Term)) -> ReduceM (Term -> Constraint)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Maybe (Sort' Term) -> ReduceM (Maybe (Sort' Term))
forall t. Normalise t => t -> ReduceM t
normalise' Maybe (Sort' Term)
ms ReduceM (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
t
  normalise' (RewConstraint LocalEquation' Term
e)     = LocalEquation' Term -> Constraint
RewConstraint (LocalEquation' Term -> Constraint)
-> ReduceM (LocalEquation' Term) -> ReduceM Constraint
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> LocalEquation' Term -> ReduceM (LocalEquation' Term)
forall t. Normalise t => t -> ReduceM t
normalise' LocalEquation' Term
e

instance Normalise CompareAs where
  normalise' :: CompareAs -> ReduceM CompareAs
normalise' (AsTermsOf Type
a) = Type -> CompareAs
AsTermsOf (Type -> CompareAs) -> ReduceM Type -> ReduceM CompareAs
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
a
  normalise' CompareAs
AsSizes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsSizes
  normalise' CompareAs
AsTypes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsTypes

instance Normalise ConPatternInfo where
  normalise' :: ConPatternInfo -> ReduceM ConPatternInfo
normalise' ConPatternInfo
i = Maybe (Arg Type) -> ReduceM (Maybe (Arg Type))
forall t. Normalise t => t -> ReduceM t
normalise' (ConPatternInfo -> Maybe (Arg Type)
conPType ConPatternInfo
i) ReduceM (Maybe (Arg Type))
-> (Maybe (Arg Type) -> ConPatternInfo) -> ReduceM ConPatternInfo
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ Maybe (Arg Type)
t -> ConPatternInfo
i { conPType = t }

instance Normalise a => Normalise (Pattern' a) where
  normalise' :: Pattern' a -> ReduceM (Pattern' a)
normalise' Pattern' a
p = case Pattern' a
p of
    VarP PatternInfo
o a
x     -> PatternInfo -> a -> Pattern' a
forall x. PatternInfo -> x -> Pattern' x
VarP PatternInfo
o (a -> Pattern' a) -> ReduceM a -> ReduceM (Pattern' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> a -> ReduceM a
forall t. Normalise t => t -> ReduceM t
normalise' a
x
    LitP{}       -> Pattern' a -> ReduceM (Pattern' a)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern' a
p
    ConP ConHead
c ConPatternInfo
mt [NamedArg (Pattern' a)]
ps -> ConHead -> ConPatternInfo -> [NamedArg (Pattern' a)] -> Pattern' a
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c (ConPatternInfo -> [NamedArg (Pattern' a)] -> Pattern' a)
-> ReduceM ConPatternInfo
-> ReduceM ([NamedArg (Pattern' a)] -> Pattern' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConPatternInfo -> ReduceM ConPatternInfo
forall t. Normalise t => t -> ReduceM t
normalise' ConPatternInfo
mt ReduceM ([NamedArg (Pattern' a)] -> Pattern' a)
-> ReduceM [NamedArg (Pattern' a)] -> ReduceM (Pattern' a)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [NamedArg (Pattern' a)] -> ReduceM [NamedArg (Pattern' a)]
forall t. Normalise t => t -> ReduceM t
normalise' [NamedArg (Pattern' a)]
ps
    DefP PatternInfo
o QName
q [NamedArg (Pattern' a)]
ps  -> PatternInfo -> QName -> [NamedArg (Pattern' a)] -> Pattern' a
forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
o QName
q ([NamedArg (Pattern' a)] -> Pattern' a)
-> ReduceM [NamedArg (Pattern' a)] -> ReduceM (Pattern' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedArg (Pattern' a)] -> ReduceM [NamedArg (Pattern' a)]
forall t. Normalise t => t -> ReduceM t
normalise' [NamedArg (Pattern' a)]
ps
    DotP PatternInfo
o Term
v     -> PatternInfo -> Term -> Pattern' a
forall x. PatternInfo -> Term -> Pattern' x
DotP PatternInfo
o (Term -> Pattern' a) -> ReduceM Term -> ReduceM (Pattern' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
v
    ProjP{}      -> Pattern' a -> ReduceM (Pattern' a)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern' a
p
    IApplyP PatternInfo
o Term
t Term
u a
x -> PatternInfo -> Term -> Term -> a -> Pattern' a
forall x. PatternInfo -> Term -> Term -> x -> Pattern' x
IApplyP PatternInfo
o (Term -> Term -> a -> Pattern' a)
-> ReduceM Term -> ReduceM (Term -> a -> Pattern' a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
t ReduceM (Term -> a -> Pattern' a)
-> ReduceM Term -> ReduceM (a -> Pattern' a)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
u ReduceM (a -> Pattern' a) -> ReduceM a -> ReduceM (Pattern' a)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> a -> ReduceM a
forall t. Normalise t => t -> ReduceM t
normalise' a
x

instance Normalise DisplayForm where
  normalise' :: DisplayForm -> ReduceM DisplayForm
normalise' (Display Int
n [Elim]
ps DisplayTerm
v) = Int -> [Elim] -> DisplayTerm -> DisplayForm
Display Int
n ([Elim] -> DisplayTerm -> DisplayForm)
-> ReduceM [Elim] -> ReduceM (DisplayTerm -> DisplayForm)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Elim] -> ReduceM [Elim]
forall t. Normalise t => t -> ReduceM t
normalise' [Elim]
ps ReduceM (DisplayTerm -> DisplayForm)
-> ReduceM DisplayTerm -> ReduceM DisplayForm
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> DisplayTerm -> ReduceM DisplayTerm
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return DisplayTerm
v

instance Normalise Candidate where
  normalise' :: Candidate -> ReduceM Candidate
normalise' (Candidate CandidateKind
q Term
u Type
t OverlapMode
ov) = CandidateKind -> Term -> Type -> OverlapMode -> Candidate
Candidate CandidateKind
q (Term -> Type -> OverlapMode -> Candidate)
-> ReduceM Term -> ReduceM (Type -> OverlapMode -> Candidate)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Term -> ReduceM Term
forall t. Normalise t => t -> ReduceM t
normalise' Term
u ReduceM (Type -> OverlapMode -> Candidate)
-> ReduceM Type -> ReduceM (OverlapMode -> Candidate)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
t ReduceM (OverlapMode -> Candidate)
-> ReduceM OverlapMode -> ReduceM Candidate
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> OverlapMode -> ReduceM OverlapMode
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OverlapMode
ov

instance Normalise EqualityView where
  normalise' :: EqualityView -> ReduceM EqualityView
normalise' (OtherType Type
t)            = Type -> EqualityView
OtherType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
t
  normalise' (IdiomType Type
t)            = Type -> EqualityView
IdiomType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> ReduceM Type
forall t. Normalise t => t -> ReduceM t
normalise' Type
t
  normalise' (EqualityType Range
r Sort' Term
s QName
eq Args
l Arg Term
t Arg Term
a Arg Term
b) = Range
-> Sort' Term
-> QName
-> Args
-> Arg Term
-> Arg Term
-> Arg Term
-> EqualityView
EqualityType Range
r
    (Sort' Term
 -> QName
 -> Args
 -> Arg Term
 -> Arg Term
 -> Arg Term
 -> EqualityView)
-> ReduceM (Sort' Term)
-> ReduceM
     (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> ReduceM (Sort' Term)
forall t. Normalise t => t -> ReduceM t
normalise' Sort' Term
s
    ReduceM
  (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM QName
-> ReduceM
     (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> QName -> ReduceM QName
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
eq
    ReduceM (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM Args
-> ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (Arg Term -> ReduceM (Arg Term)) -> Args -> ReduceM Args
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 -> ReduceM (Arg Term)
forall t. Normalise t => t -> ReduceM t
normalise' Args
l
    ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term)
-> ReduceM (Arg Term -> Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Normalise t => t -> ReduceM t
normalise' Arg Term
t
    ReduceM (Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM (Arg Term -> EqualityView)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Normalise t => t -> ReduceM t
normalise' Arg Term
a
    ReduceM (Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM EqualityView
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg Term -> ReduceM (Arg Term)
forall t. Normalise t => t -> ReduceM t
normalise' Arg Term
b

---------------------------------------------------------------------------
-- * Full instantiation
---------------------------------------------------------------------------

-- | @instantiateFull'@ 'instantiate's metas everywhere (and recursively)
--   but does not 'reduce'.
class InstantiateFull t where
  instantiateFull' :: t -> ReduceM t

  default instantiateFull' :: (t ~ f a, Traversable f, InstantiateFull a) => t -> ReduceM t
  instantiateFull' = (a -> ReduceM a) -> f a -> ReduceM (f a)
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) -> f a -> f (f b)
traverse a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull'

instance InstantiateFull a => InstantiateFull [a] where
  instantiateFull' :: [a] -> ReduceM [a]
instantiateFull' = \case
    []   -> [a] -> ReduceM [a]
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []
    a
a:[a]
as -> (:) (a -> [a] -> [a]) -> ReduceM a -> ReduceM ([a] -> [a])
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' a
a ReduceM ([a] -> [a]) -> ReduceM [a] -> ReduceM [a]
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [a] -> ReduceM [a]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [a]
as

instance InstantiateFull t => InstantiateFull (List1 t) where
  instantiateFull' :: List1 t -> ReduceM (List1 t)
instantiateFull' (t
a :| [t]
as) =
    t -> [t] -> List1 t
forall a. a -> [a] -> NonEmpty a
(:|) (t -> [t] -> List1 t) -> ReduceM t -> ReduceM ([t] -> List1 t)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
a ReduceM ([t] -> List1 t) -> ReduceM [t] -> ReduceM (List1 t)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [t] -> ReduceM [t]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [t]
as

-- Traversables (doesn't include binders like Abs, Tele):
instance InstantiateFull t => InstantiateFull (HashMap k t)
instance InstantiateFull t => InstantiateFull (Map k t)

instance InstantiateFull t => InstantiateFull (Maybe t) where
  instantiateFull' :: Maybe t -> ReduceM (Maybe t)
instantiateFull' = \case
    Maybe t
Nothing -> Maybe t -> ReduceM (Maybe t)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe t
forall a. Maybe a
Nothing
    Just t
t  -> t -> Maybe t
forall a. a -> Maybe a
Just (t -> Maybe t) -> ReduceM t -> ReduceM (Maybe t)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
t

instance InstantiateFull t => InstantiateFull (Strict.Maybe t) where
  instantiateFull' :: Maybe t -> ReduceM (Maybe t)
instantiateFull' = \case
    Maybe t
Strict.Nothing -> Maybe t -> ReduceM (Maybe t)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe t
forall a. Maybe a
Strict.Nothing
    Strict.Just t
t  -> t -> Maybe t
forall a. a -> Maybe a
Strict.Just (t -> Maybe t) -> ReduceM t -> ReduceM (Maybe t)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
t

instance InstantiateFull t => InstantiateFull (Arg t) where
  instantiateFull' :: Arg t -> ReduceM (Arg t)
instantiateFull' (Arg ArgInfo
x t
y) = ArgInfo -> t -> Arg t
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
x (t -> Arg t) -> ReduceM t -> ReduceM (Arg t)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
y

instance InstantiateFull t => InstantiateFull (Elim' t) where
  instantiateFull' :: Elim' t -> ReduceM (Elim' t)
instantiateFull' = \case
    Apply Arg t
a      -> Arg t -> Elim' t
forall a. Arg a -> Elim' a
Apply (Arg t -> Elim' t) -> ReduceM (Arg t) -> ReduceM (Elim' t)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Arg t -> ReduceM (Arg t)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Arg t
a
    Proj ProjOrigin
o QName
x     -> Elim' t -> ReduceM (Elim' t)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (ProjOrigin -> QName -> Elim' t
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
o QName
x)
    IApply t
l t
r t
t -> t -> t -> t -> Elim' t
forall a. a -> a -> a -> Elim' a
IApply (t -> t -> t -> Elim' t)
-> ReduceM t -> ReduceM (t -> t -> Elim' t)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
l
                           ReduceM (t -> t -> Elim' t) -> ReduceM t -> ReduceM (t -> Elim' t)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
r
                           ReduceM (t -> Elim' t) -> ReduceM t -> ReduceM (Elim' t)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
t

instance InstantiateFull t => InstantiateFull (Named name t) where
  instantiateFull' :: Named name t -> ReduceM (Named name t)
instantiateFull' (Named Maybe name
x t
y) = Maybe name -> t -> Named name t
forall name a. Maybe name -> a -> Named name a
Named Maybe name
x (t -> Named name t) -> ReduceM t -> ReduceM (Named name t)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
y

instance InstantiateFull t => InstantiateFull (WithArity t)
instance InstantiateFull t => InstantiateFull (IPBoundary' t)

-- Tuples:
instance (InstantiateFull a, InstantiateFull b) => InstantiateFull (a,b) where
    {-# INLINE instantiateFull' #-}
    instantiateFull' :: (a, b) -> ReduceM (a, b)
instantiateFull' (a
x,b
y) = (,) (a -> b -> (a, b)) -> ReduceM a -> ReduceM (b -> (a, b))
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' a
x ReduceM (b -> (a, b)) -> ReduceM b -> ReduceM (a, b)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> b -> ReduceM b
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' b
y

instance (InstantiateFull a, InstantiateFull b, InstantiateFull c) => InstantiateFull (a,b,c) where
    {-# INLINE instantiateFull' #-}
    instantiateFull' :: (a, b, c) -> ReduceM (a, b, c)
instantiateFull' (a
x,b
y,c
z) =
        do (x,(y,z)) <- (a, (b, c)) -> ReduceM (a, (b, c))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (a
x,(b
y,c
z))
           return (x,y,z)

instance (InstantiateFull a, InstantiateFull b, InstantiateFull c, InstantiateFull d)
    => InstantiateFull (a,b,c,d) where
    {-# INLINE instantiateFull' #-}
    instantiateFull' :: (a, b, c, d) -> ReduceM (a, b, c, d)
instantiateFull' (a
x,b
y,c
z,d
w) =
        do (x,(y,z,w)) <- (a, (b, c, d)) -> ReduceM (a, (b, c, d))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (a
x,(b
y,c
z,d
w))
           return (x,y,z,w)

-- Base types:
instance InstantiateFull Bool where
    instantiateFull' :: Bool -> ReduceM Bool
instantiateFull' = Bool -> ReduceM Bool
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance InstantiateFull Char where
    instantiateFull' :: Char -> ReduceM Char
instantiateFull' = Char -> ReduceM Char
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance InstantiateFull Int where
    instantiateFull' :: Int -> ReduceM Int
instantiateFull' = Int -> ReduceM Int
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance InstantiateFull ModuleName where
    instantiateFull' :: ModuleName -> ReduceM ModuleName
instantiateFull' = ModuleName -> ReduceM ModuleName
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance InstantiateFull Name where
    instantiateFull' :: Name -> ReduceM Name
instantiateFull' = Name -> ReduceM Name
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance InstantiateFull QName where
  instantiateFull' :: QName -> ReduceM QName
instantiateFull' = QName -> ReduceM QName
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance InstantiateFull Scope where
    instantiateFull' :: Scope -> ReduceM Scope
instantiateFull' = Scope -> ReduceM Scope
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance InstantiateFull ConHead where
  instantiateFull' :: ConHead -> ReduceM ConHead
instantiateFull' = ConHead -> ReduceM ConHead
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance InstantiateFull DBPatVar where
    instantiateFull' :: DBPatVar -> ReduceM DBPatVar
instantiateFull' = DBPatVar -> ReduceM DBPatVar
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

instance InstantiateFull PrimitiveId where
  instantiateFull' :: PrimitiveId -> ReduceM PrimitiveId
instantiateFull' = PrimitiveId -> ReduceM PrimitiveId
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return

-- Rest:
instance InstantiateFull Sort where
    instantiateFull' :: Sort' Term -> ReduceM (Sort' Term)
instantiateFull' Sort' Term
s = do
        s <- Sort' Term -> ReduceM (Sort' Term)
forall t. Instantiate t => t -> ReduceM t
instantiate' Sort' Term
s
        case s of
            Univ Univ
u Level' Term
n   -> Univ -> Level' Term -> Sort' Term
forall t. Univ -> Level' t -> Sort' t
Univ Univ
u (Level' Term -> Sort' Term)
-> ReduceM (Level' Term) -> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Level' Term -> ReduceM (Level' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Level' Term
n
            PiSort Dom' Term Term
a Sort' Term
s1 Abs (Sort' Term)
s2 -> (Dom' Term Term
 -> Sort' Term -> Abs (Sort' Term) -> ReduceM (Sort' Term))
-> (Dom' Term Term, Sort' Term, Abs (Sort' Term))
-> ReduceM (Sort' Term)
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 Dom' Term Term
-> Sort' Term -> Abs (Sort' Term) -> ReduceM (Sort' Term)
forall (m :: * -> *).
HasOptions m =>
Dom' Term Term -> Sort' Term -> Abs (Sort' Term) -> m (Sort' Term)
piSortM ((Dom' Term Term, Sort' Term, Abs (Sort' Term))
 -> ReduceM (Sort' Term))
-> ReduceM (Dom' Term Term, Sort' Term, Abs (Sort' Term))
-> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Dom' Term Term, Sort' Term, Abs (Sort' Term))
-> ReduceM (Dom' Term Term, Sort' Term, Abs (Sort' Term))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (Dom' Term Term
a, Sort' Term
s1, Abs (Sort' Term)
s2)
            FunSort Sort' Term
s1 Sort' Term
s2 -> (Sort' Term -> Sort' Term -> ReduceM (Sort' Term))
-> (Sort' Term, Sort' Term) -> ReduceM (Sort' Term)
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Sort' Term -> Sort' Term -> ReduceM (Sort' Term)
forall (m :: * -> *).
HasOptions m =>
Sort' Term -> Sort' Term -> m (Sort' Term)
funSortM ((Sort' Term, Sort' Term) -> ReduceM (Sort' Term))
-> ReduceM (Sort' Term, Sort' Term) -> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Sort' Term, Sort' Term) -> ReduceM (Sort' Term, Sort' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (Sort' Term
s1, Sort' Term
s2)
            UnivSort Sort' Term
s -> Sort' Term -> Sort' Term
univSort (Sort' Term -> Sort' Term)
-> ReduceM (Sort' Term) -> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Sort' Term -> ReduceM (Sort' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Sort' Term
s
            Inf Univ
_ Integer
_    -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
            Sort' Term
SizeUniv   -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
            Sort' Term
LockUniv   -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
            Sort' Term
LevelUniv  -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
            Sort' Term
IntervalUniv -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s
            MetaS MetaId
x [Elim]
es -> MetaId -> [Elim] -> Sort' Term
forall t. MetaId -> [Elim' t] -> Sort' t
MetaS MetaId
x ([Elim] -> Sort' Term) -> ReduceM [Elim] -> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
es
            DefS QName
d [Elim]
es  -> QName -> [Elim] -> Sort' Term
forall t. QName -> [Elim' t] -> Sort' t
DefS QName
d ([Elim] -> Sort' Term) -> ReduceM [Elim] -> ReduceM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
es
            DummyS{}   -> Sort' Term -> ReduceM (Sort' Term)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Sort' Term
s

instance InstantiateFull t => InstantiateFull (Type' t) where
    instantiateFull' :: Type' t -> ReduceM (Type' t)
instantiateFull' (El Sort' Term
s t
t) =
      Sort' Term -> t -> Type' t
forall t a. Sort' t -> a -> Type'' t a
El (Sort' Term -> t -> Type' t)
-> ReduceM (Sort' Term) -> ReduceM (t -> Type' t)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Sort' Term -> ReduceM (Sort' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Sort' Term
s ReduceM (t -> Type' t) -> ReduceM t -> ReduceM (Type' t)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
t

instance InstantiateFull Term where
    instantiateFull' :: Term -> ReduceM Term
instantiateFull' = Term -> ReduceM Term
forall t. Instantiate t => t -> ReduceM t
instantiate' (Term -> ReduceM Term)
-> (Term -> ReduceM Term) -> Term -> ReduceM Term
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Term -> ReduceM Term
recurse (Term -> ReduceM Term)
-> (Term -> ReduceM Term) -> Term -> ReduceM Term
forall (m :: * -> *) a b c.
Monad m =>
(a -> m b) -> (b -> m c) -> a -> m c
>=> Term -> ReduceM Term
forall (m :: * -> *). HasConstInfo m => Term -> m Term
etaOnce
      -- Andreas, 2010-11-12 DONT ETA!? eta-reduction breaks subject reduction
      -- but removing etaOnce now breaks everything
      where
        recurse :: Term -> ReduceM Term
recurse = \case
          Var Int
n [Elim]
vs    -> Int -> [Elim] -> Term
Var Int
n ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
vs
          Con ConHead
c ConInfo
ci [Elim]
vs -> ConHead -> ConInfo -> [Elim] -> Term
Con ConHead
c ConInfo
ci ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
vs
          Def QName
f [Elim]
vs    -> QName -> [Elim] -> Term
Def QName
f ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
vs
          MetaV MetaId
x [Elim]
vs  -> MetaId -> [Elim] -> Term
MetaV MetaId
x ([Elim] -> Term) -> ReduceM [Elim] -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
vs
          v :: Term
v@Lit{}     -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
          Level Level' Term
l     -> Level' Term -> Term
levelTm (Level' Term -> Term) -> ReduceM (Level' Term) -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Level' Term -> ReduceM (Level' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Level' Term
l
          Lam ArgInfo
h Abs Term
b     -> ArgInfo -> Abs Term -> Term
Lam ArgInfo
h (Abs Term -> Term) -> ReduceM (Abs Term) -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Abs Term -> ReduceM (Abs Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Abs Term
b
          Sort Sort' Term
s      -> Sort' Term -> Term
Sort (Sort' Term -> Term) -> ReduceM (Sort' Term) -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Sort' Term -> ReduceM (Sort' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Sort' Term
s
          Pi Dom' Term Type
a Abs Type
b      -> (Dom' Term Type -> Abs Type -> Term)
-> (Dom' Term Type, Abs Type) -> Term
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Dom' Term Type -> Abs Type -> Term
Pi ((Dom' Term Type, Abs Type) -> Term)
-> ReduceM (Dom' Term Type, Abs Type) -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Dom' Term Type, Abs Type) -> ReduceM (Dom' Term Type, Abs Type)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (Dom' Term Type
a,Abs Type
b)
          DontCare Term
v  -> Term -> Term
dontCare (Term -> Term) -> ReduceM Term -> ReduceM Term
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
v
          v :: Term
v@Dummy{}   -> Term -> ReduceM Term
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v

instance InstantiateFull Level where
  instantiateFull' :: Level' Term -> ReduceM (Level' Term)
instantiateFull' (Max Integer
m [PlusLevel]
as) = Integer -> [PlusLevel] -> Level' Term
levelMax Integer
m ([PlusLevel] -> Level' Term)
-> ReduceM [PlusLevel] -> ReduceM (Level' Term)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [PlusLevel] -> ReduceM [PlusLevel]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [PlusLevel]
as

instance InstantiateFull PlusLevel where
  instantiateFull' :: PlusLevel -> ReduceM PlusLevel
instantiateFull' (Plus Integer
n Term
l) = Integer -> Term -> PlusLevel
forall t. Integer -> t -> PlusLevel' t
Plus Integer
n (Term -> PlusLevel) -> ReduceM Term -> ReduceM PlusLevel
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
l

instance InstantiateFull Substitution where
  instantiateFull' :: Substitution -> ReduceM Substitution
instantiateFull' Substitution
sigma =
    case Substitution
sigma of
      Substitution
IdS                    -> Substitution -> ReduceM Substitution
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Substitution
forall a. Substitution' a
IdS
      EmptyS Impossible
err             -> Substitution -> ReduceM Substitution
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Substitution -> ReduceM Substitution)
-> Substitution -> ReduceM Substitution
forall a b. (a -> b) -> a -> b
$ Impossible -> Substitution
forall a. Impossible -> Substitution' a
EmptyS Impossible
err
      Wk   Int
n Substitution
sigma           -> Int -> Substitution -> Substitution
forall a. Int -> Substitution' a -> Substitution' a
Wk   Int
n           (Substitution -> Substitution)
-> ReduceM Substitution -> ReduceM Substitution
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Substitution -> ReduceM Substitution
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Substitution
sigma
      Lift Int
n Substitution
sigma           -> Int -> Substitution -> Substitution
forall a. Int -> Substitution' a -> Substitution' a
Lift Int
n           (Substitution -> Substitution)
-> ReduceM Substitution -> ReduceM Substitution
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Substitution -> ReduceM Substitution
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Substitution
sigma
      Strengthen Impossible
bot Int
n Substitution
sigma -> Impossible -> Int -> Substitution -> Substitution
forall a. Impossible -> Int -> Substitution' a -> Substitution' a
Strengthen Impossible
bot Int
n (Substitution -> Substitution)
-> ReduceM Substitution -> ReduceM Substitution
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Substitution -> ReduceM Substitution
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Substitution
sigma
      Term
t :# Substitution
sigma             -> Term -> Substitution -> Substitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS (Term -> Substitution -> Substitution)
-> ReduceM Term -> ReduceM (Substitution -> Substitution)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
t
                                      ReduceM (Substitution -> Substitution)
-> ReduceM Substitution -> ReduceM Substitution
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Substitution -> ReduceM Substitution
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Substitution
sigma

instance InstantiateFull ConPatternInfo where
    instantiateFull' :: ConPatternInfo -> ReduceM ConPatternInfo
instantiateFull' ConPatternInfo
i = Maybe (Arg Type) -> ReduceM (Maybe (Arg Type))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (ConPatternInfo -> Maybe (Arg Type)
conPType ConPatternInfo
i) ReduceM (Maybe (Arg Type))
-> (Maybe (Arg Type) -> ConPatternInfo) -> ReduceM ConPatternInfo
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ Maybe (Arg Type)
t -> ConPatternInfo
i { conPType = t }

instance InstantiateFull a => InstantiateFull (Pattern' a) where
    instantiateFull' :: Pattern' a -> ReduceM (Pattern' a)
instantiateFull' (VarP PatternInfo
o a
x)     = PatternInfo -> a -> Pattern' a
forall x. PatternInfo -> x -> Pattern' x
VarP PatternInfo
o (a -> Pattern' a) -> ReduceM a -> ReduceM (Pattern' a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' a
x
    instantiateFull' (DotP PatternInfo
o Term
t)     = PatternInfo -> Term -> Pattern' a
forall x. PatternInfo -> Term -> Pattern' x
DotP PatternInfo
o (Term -> Pattern' a) -> ReduceM Term -> ReduceM (Pattern' a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
t
    instantiateFull' (ConP ConHead
n ConPatternInfo
mt [NamedArg (Pattern' a)]
ps) = ConHead -> ConPatternInfo -> [NamedArg (Pattern' a)] -> Pattern' a
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
n (ConPatternInfo -> [NamedArg (Pattern' a)] -> Pattern' a)
-> ReduceM ConPatternInfo
-> ReduceM ([NamedArg (Pattern' a)] -> Pattern' a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> ConPatternInfo -> ReduceM ConPatternInfo
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' ConPatternInfo
mt ReduceM ([NamedArg (Pattern' a)] -> Pattern' a)
-> ReduceM [NamedArg (Pattern' a)] -> ReduceM (Pattern' a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [NamedArg (Pattern' a)] -> ReduceM [NamedArg (Pattern' a)]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [NamedArg (Pattern' a)]
ps
    instantiateFull' (DefP PatternInfo
o QName
q [NamedArg (Pattern' a)]
ps) = PatternInfo -> QName -> [NamedArg (Pattern' a)] -> Pattern' a
forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
o QName
q ([NamedArg (Pattern' a)] -> Pattern' a)
-> ReduceM [NamedArg (Pattern' a)] -> ReduceM (Pattern' a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [NamedArg (Pattern' a)] -> ReduceM [NamedArg (Pattern' a)]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [NamedArg (Pattern' a)]
ps
    instantiateFull' l :: Pattern' a
l@LitP{}       = Pattern' a -> ReduceM (Pattern' a)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern' a
l
    instantiateFull' p :: Pattern' a
p@ProjP{}      = Pattern' a -> ReduceM (Pattern' a)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Pattern' a
p
    instantiateFull' (IApplyP PatternInfo
o Term
t Term
u a
x) = PatternInfo -> Term -> Term -> a -> Pattern' a
forall x. PatternInfo -> Term -> Term -> x -> Pattern' x
IApplyP PatternInfo
o (Term -> Term -> a -> Pattern' a)
-> ReduceM Term -> ReduceM (Term -> a -> Pattern' a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
t ReduceM (Term -> a -> Pattern' a)
-> ReduceM Term -> ReduceM (a -> Pattern' a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
u ReduceM (a -> Pattern' a) -> ReduceM a -> ReduceM (Pattern' a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' a
x

instance (Subst a, InstantiateFull a) => InstantiateFull (Abs a) where
    instantiateFull' :: Abs a -> ReduceM (Abs a)
instantiateFull' a :: Abs a
a@(Abs [Char]
x a
_) = [Char] -> a -> Abs a
forall a. [Char] -> a -> Abs a
Abs [Char]
x (a -> Abs a) -> ReduceM a -> ReduceM (Abs a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Abs a -> (a -> ReduceM a) -> ReduceM a
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Abs a -> (a -> m b) -> m b
underAbstraction_ Abs a
a a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull'
    instantiateFull' (NoAbs [Char]
x a
a) = [Char] -> a -> Abs a
forall a. [Char] -> a -> Abs a
NoAbs [Char]
x (a -> Abs a) -> ReduceM a -> ReduceM (Abs a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' a
a


instance InstantiateFull e => InstantiateFull (Dom e) where
    instantiateFull' :: Dom e -> ReduceM (Dom e)
instantiateFull' (Dom ArgInfo
i Maybe NamedName
n Bool
b Maybe Term
tac Maybe (RewDom' Term)
rew e
x) =
      ArgInfo
-> Maybe NamedName
-> Bool
-> Maybe Term
-> Maybe (RewDom' Term)
-> e
-> Dom e
forall t e.
ArgInfo
-> Maybe NamedName
-> Bool
-> Maybe t
-> Maybe (RewDom' t)
-> e
-> Dom' t e
Dom ArgInfo
i Maybe NamedName
n Bool
b (Maybe Term -> Maybe (RewDom' Term) -> e -> Dom e)
-> ReduceM (Maybe Term)
-> ReduceM (Maybe (RewDom' Term) -> e -> Dom e)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Maybe Term -> ReduceM (Maybe Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe Term
tac ReduceM (Maybe (RewDom' Term) -> e -> Dom e)
-> ReduceM (Maybe (RewDom' Term)) -> ReduceM (e -> Dom e)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe (RewDom' Term) -> ReduceM (Maybe (RewDom' Term))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe (RewDom' Term)
rew ReduceM (e -> Dom e) -> ReduceM e -> ReduceM (Dom e)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> e -> ReduceM e
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' e
x

instance InstantiateFull Context where
  instantiateFull' :: Context -> ReduceM Context
instantiateFull' (Context [ContextEntry]
es) = [ContextEntry] -> Context
forall a. [a] -> Context' a
Context ([ContextEntry] -> Context)
-> ReduceM [ContextEntry] -> ReduceM Context
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [ContextEntry] -> ReduceM [ContextEntry]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [ContextEntry]
es

instance InstantiateFull ContextEntry where
  instantiateFull' :: ContextEntry -> ReduceM ContextEntry
instantiateFull' (CtxVar Name
x Dom' Term Type
a) = Name -> Dom' Term Type -> ContextEntry
CtxVar Name
x (Dom' Term Type -> ContextEntry)
-> ReduceM (Dom' Term Type) -> ReduceM ContextEntry
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Dom' Term Type -> ReduceM (Dom' Term Type)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Dom' Term Type
a

instance InstantiateFull LetBinding where
  instantiateFull' :: LetBinding -> ReduceM LetBinding
instantiateFull' (LetBinding IsAxiom
isAxiom Origin
o Term
v Dom' Term Type
t) = IsAxiom -> Origin -> Term -> Dom' Term Type -> LetBinding
LetBinding IsAxiom
isAxiom Origin
o (Term -> Dom' Term Type -> LetBinding)
-> ReduceM Term -> ReduceM (Dom' Term Type -> LetBinding)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
v ReduceM (Dom' Term Type -> LetBinding)
-> ReduceM (Dom' Term Type) -> ReduceM LetBinding
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Dom' Term Type -> ReduceM (Dom' Term Type)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Dom' Term Type
t

-- Andreas, 2021-09-13, issue #5544, need to traverse @checkpoints@ map
instance InstantiateFull t => InstantiateFull (Open t) where
  instantiateFull' :: Open t -> ReduceM (Open t)
instantiateFull' (OpenThing CheckpointId
checkpoint Map CheckpointId Substitution
checkpoints ModuleNameHash
modl t
t) =
    CheckpointId
-> Map CheckpointId Substitution -> ModuleNameHash -> t -> Open t
forall a.
CheckpointId
-> Map CheckpointId Substitution -> ModuleNameHash -> a -> Open a
OpenThing CheckpointId
checkpoint
    (Map CheckpointId Substitution -> ModuleNameHash -> t -> Open t)
-> ReduceM (Map CheckpointId Substitution)
-> ReduceM (ModuleNameHash -> t -> Open t)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Map CheckpointId Substitution
-> ReduceM (Map CheckpointId Substitution)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (Map CheckpointId Substitution
 -> ReduceM (Map CheckpointId Substitution))
-> ReduceM (Map CheckpointId Substitution)
-> ReduceM (Map CheckpointId Substitution)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Map CheckpointId Substitution
-> ReduceM (Map CheckpointId Substitution)
forall {m :: * -> *} {a}.
MonadTCEnv m =>
Map CheckpointId a -> m (Map CheckpointId a)
prune Map CheckpointId Substitution
checkpoints)
    ReduceM (ModuleNameHash -> t -> Open t)
-> ReduceM ModuleNameHash -> ReduceM (t -> Open t)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> ModuleNameHash -> ReduceM ModuleNameHash
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ModuleNameHash
modl
    ReduceM (t -> Open t) -> ReduceM t -> ReduceM (Open t)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> t -> ReduceM t
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' t
t
    where
      -- Ulf, 2021-11-17, #5544
      --  Remove checkpoints that are no longer in scope, since they can
      --  mention functions that deadcode elimination will get rid of.
      prune :: Map CheckpointId a -> m (Map CheckpointId a)
prune Map CheckpointId a
cps = do
        inscope <- Lens' TCEnv (Map CheckpointId Substitution)
-> m (Map CheckpointId Substitution)
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (Map CheckpointId Substitution
 -> f (Map CheckpointId Substitution))
-> TCEnv -> f TCEnv
Lens' TCEnv (Map CheckpointId Substitution)
eCheckpoints
        return $! cps `Map.intersection` inscope

instance InstantiateFull a => InstantiateFull (Closure a) where
    instantiateFull' :: Closure a -> ReduceM (Closure a)
instantiateFull' Closure a
cl = do
        x <- Closure a -> (a -> ReduceM a) -> ReduceM a
forall (m :: * -> *) c a b.
(MonadTCEnv m, ReadTCState m, LensClosure c a) =>
c -> (a -> m b) -> m b
enterClosure Closure a
cl a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull'
        return $! cl { clValue = x }

instance InstantiateFull ProblemConstraint where
  instantiateFull' :: ProblemConstraint -> ReduceM ProblemConstraint
instantiateFull' (PConstr Set ProblemId
p Blocker
u Closure Constraint
c) = Set ProblemId -> Blocker -> Closure Constraint -> ProblemConstraint
PConstr Set ProblemId
p Blocker
u (Closure Constraint -> ProblemConstraint)
-> ReduceM (Closure Constraint) -> ReduceM ProblemConstraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Closure Constraint -> ReduceM (Closure Constraint)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Closure Constraint
c

instance InstantiateFull Constraint where
  instantiateFull' :: Constraint -> ReduceM Constraint
instantiateFull' = \case
    ValueCmp Comparison
cmp CompareAs
t Term
u Term
v -> do
      (t,u,v) <- (CompareAs, Term, Term) -> ReduceM (CompareAs, Term, Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (CompareAs
t,Term
u,Term
v)
      return $ ValueCmp cmp t u v
    ValueCmpOnFace Comparison
cmp Term
p Type
t Term
u Term
v -> do
      ((p,t),u,v) <- ((Term, Type), Term, Term) -> ReduceM ((Term, Type), Term, Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' ((Term
p,Type
t),Term
u,Term
v)
      return $ ValueCmpOnFace cmp p t u v
    ElimCmp [Polarity]
cmp [IsForced]
fs Type
t Term
v [Elim]
as [Elim]
bs ->
      [Polarity]
-> [IsForced] -> Type -> Term -> [Elim] -> [Elim] -> Constraint
ElimCmp [Polarity]
cmp [IsForced]
fs (Type -> Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Type -> ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
t ReduceM (Term -> [Elim] -> [Elim] -> Constraint)
-> ReduceM Term -> ReduceM ([Elim] -> [Elim] -> Constraint)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
v ReduceM ([Elim] -> [Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM ([Elim] -> Constraint)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
as ReduceM ([Elim] -> Constraint)
-> ReduceM [Elim] -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
bs
    LevelCmp Comparison
cmp Level' Term
u Level' Term
v    -> (Level' Term -> Level' Term -> Constraint)
-> (Level' Term, Level' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Level' Term -> Level' Term -> Constraint
LevelCmp Comparison
cmp) ((Level' Term, Level' Term) -> Constraint)
-> ReduceM (Level' Term, Level' Term) -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Level' Term, Level' Term) -> ReduceM (Level' Term, Level' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (Level' Term
u,Level' Term
v)
    SortCmp Comparison
cmp Sort' Term
a Sort' Term
b     -> (Sort' Term -> Sort' Term -> Constraint)
-> (Sort' Term, Sort' Term) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Comparison -> Sort' Term -> Sort' Term -> Constraint
SortCmp Comparison
cmp) ((Sort' Term, Sort' Term) -> Constraint)
-> ReduceM (Sort' Term, Sort' Term) -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Sort' Term, Sort' Term) -> ReduceM (Sort' Term, Sort' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (Sort' Term
a,Sort' Term
b)
    UnBlock MetaId
m           -> Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ MetaId -> Constraint
UnBlock MetaId
m
    FindInstance Range
r MetaId
m Maybe [Candidate]
cs -> Range -> MetaId -> Maybe [Candidate] -> Constraint
FindInstance Range
r MetaId
m (Maybe [Candidate] -> Constraint)
-> ReduceM (Maybe [Candidate]) -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> ([Candidate] -> ReduceM [Candidate])
-> Maybe [Candidate] -> ReduceM (Maybe [Candidate])
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) -> Maybe a -> m (Maybe b)
mapM [Candidate] -> ReduceM [Candidate]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe [Candidate]
cs
    ResolveInstanceHead KwRange
kwr QName
q -> Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (Constraint -> ReduceM Constraint)
-> Constraint -> ReduceM Constraint
forall a b. (a -> b) -> a -> b
$ KwRange -> QName -> Constraint
ResolveInstanceHead KwRange
kwr QName
q
    IsEmpty Range
r Type
t         -> Range -> Type -> Constraint
IsEmpty Range
r (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
t
    CheckSizeLtSat Term
t    -> Term -> Constraint
CheckSizeLtSat (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
t
    c :: Constraint
c@CheckFunDef{}     -> Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
    HasBiggerSort Sort' Term
a     -> Sort' Term -> Constraint
HasBiggerSort (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Sort' Term -> ReduceM (Sort' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Sort' Term
a
    HasPTSRule Dom' Term Type
a Abs (Sort' Term)
b      -> (Dom' Term Type -> Abs (Sort' Term) -> Constraint)
-> (Dom' Term Type, Abs (Sort' Term)) -> Constraint
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Dom' Term Type -> Abs (Sort' Term) -> Constraint
HasPTSRule ((Dom' Term Type, Abs (Sort' Term)) -> Constraint)
-> ReduceM (Dom' Term Type, Abs (Sort' Term)) -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (Dom' Term Type, Abs (Sort' Term))
-> ReduceM (Dom' Term Type, Abs (Sort' Term))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (Dom' Term Type
a,Abs (Sort' Term)
b)
    UnquoteTactic Term
t Term
g Type
h -> Term -> Term -> Type -> Constraint
UnquoteTactic (Term -> Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Term -> Type -> Constraint)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
t ReduceM (Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Constraint)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
g ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
h
    CheckLockedVars Term
a Type
b Arg Term
c Type
d ->
      Term -> Type -> Arg Term -> Type -> Constraint
CheckLockedVars (Term -> Type -> Arg Term -> Type -> Constraint)
-> ReduceM Term -> ReduceM (Type -> Arg Term -> Type -> Constraint)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
a ReduceM (Type -> Arg Term -> Type -> Constraint)
-> ReduceM Type -> ReduceM (Arg Term -> Type -> Constraint)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
b ReduceM (Arg Term -> Type -> Constraint)
-> ReduceM (Arg Term) -> ReduceM (Type -> Constraint)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Arg Term -> ReduceM (Arg Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Arg Term
c ReduceM (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
d
    CheckDataSort QName
q Sort' Term
s   -> QName -> Sort' Term -> Constraint
CheckDataSort QName
q (Sort' Term -> Constraint)
-> ReduceM (Sort' Term) -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Sort' Term -> ReduceM (Sort' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Sort' Term
s
    c :: Constraint
c@CheckMetaInst{}   -> Constraint -> ReduceM Constraint
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Constraint
c
    CheckType Type
t         -> Type -> Constraint
CheckType (Type -> Constraint) -> ReduceM Type -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
t
    UsableAtModality WhyCheckModality
cc Maybe (Sort' Term)
ms Modality
mod Term
t -> (Maybe (Sort' Term) -> Modality -> Term -> Constraint)
-> Modality -> Maybe (Sort' Term) -> Term -> Constraint
forall a b c. (a -> b -> c) -> b -> a -> c
flip (WhyCheckModality
-> Maybe (Sort' Term) -> Modality -> Term -> Constraint
UsableAtModality WhyCheckModality
cc) Modality
mod (Maybe (Sort' Term) -> Term -> Constraint)
-> ReduceM (Maybe (Sort' Term)) -> ReduceM (Term -> Constraint)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Maybe (Sort' Term) -> ReduceM (Maybe (Sort' Term))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe (Sort' Term)
ms ReduceM (Term -> Constraint) -> ReduceM Term -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
t
    RewConstraint LocalEquation' Term
e     -> LocalEquation' Term -> Constraint
RewConstraint (LocalEquation' Term -> Constraint)
-> ReduceM (LocalEquation' Term) -> ReduceM Constraint
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> LocalEquation' Term -> ReduceM (LocalEquation' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' LocalEquation' Term
e

instance InstantiateFull CompareAs where
  instantiateFull' :: CompareAs -> ReduceM CompareAs
instantiateFull' (AsTermsOf Type
a) = Type -> CompareAs
AsTermsOf (Type -> CompareAs) -> ReduceM Type -> ReduceM CompareAs
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
a
  instantiateFull' CompareAs
AsSizes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsSizes
  instantiateFull' CompareAs
AsTypes       = CompareAs -> ReduceM CompareAs
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return CompareAs
AsTypes

instance InstantiateFull Signature where
  instantiateFull' :: Signature -> ReduceM Signature
instantiateFull' (Sig Map ModuleName Section
a HashMap QName Definition
b HashMap QName GlobalRewriteRules
c InstanceTable
d) = Map ModuleName Section
-> HashMap QName Definition
-> HashMap QName GlobalRewriteRules
-> InstanceTable
-> Signature
Sig
    (Map ModuleName Section
 -> HashMap QName Definition
 -> HashMap QName GlobalRewriteRules
 -> InstanceTable
 -> Signature)
-> ReduceM (Map ModuleName Section)
-> ReduceM
     (HashMap QName Definition
      -> HashMap QName GlobalRewriteRules -> InstanceTable -> Signature)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Map ModuleName Section -> ReduceM (Map ModuleName Section)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Map ModuleName Section
a
    ReduceM
  (HashMap QName Definition
   -> HashMap QName GlobalRewriteRules -> InstanceTable -> Signature)
-> ReduceM (HashMap QName Definition)
-> ReduceM
     (HashMap QName GlobalRewriteRules -> InstanceTable -> Signature)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> HashMap QName Definition -> ReduceM (HashMap QName Definition)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' HashMap QName Definition
b
    ReduceM
  (HashMap QName GlobalRewriteRules -> InstanceTable -> Signature)
-> ReduceM (HashMap QName GlobalRewriteRules)
-> ReduceM (InstanceTable -> Signature)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> HashMap QName GlobalRewriteRules
-> ReduceM (HashMap QName GlobalRewriteRules)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' HashMap QName GlobalRewriteRules
c
    ReduceM (InstanceTable -> Signature)
-> ReduceM InstanceTable -> ReduceM Signature
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> InstanceTable -> ReduceM InstanceTable
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure InstanceTable
d             -- The instance table only stores names

instance InstantiateFull Section where
  instantiateFull' :: Section -> ReduceM Section
instantiateFull' (Section Telescope
tel) = Telescope -> Section
Section (Telescope -> Section) -> ReduceM Telescope -> ReduceM Section
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Telescope -> ReduceM Telescope
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Telescope
tel

instance (Subst a, InstantiateFull a) => InstantiateFull (Tele a) where
  instantiateFull' :: Tele a -> ReduceM (Tele a)
instantiateFull' Tele a
EmptyTel = Tele a -> ReduceM (Tele a)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Tele a
forall a. Tele a
EmptyTel
  instantiateFull' (ExtendTel a
a Abs (Tele a)
b) = (a -> Abs (Tele a) -> Tele a) -> (a, Abs (Tele a)) -> Tele a
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry a -> Abs (Tele a) -> Tele a
forall a. a -> Abs (Tele a) -> Tele a
ExtendTel ((a, Abs (Tele a)) -> Tele a)
-> ReduceM (a, Abs (Tele a)) -> ReduceM (Tele a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (a, Abs (Tele a)) -> ReduceM (a, Abs (Tele a))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (a
a, Abs (Tele a)
b)

instance InstantiateFull Definition where
  instantiateFull' :: Definition -> ReduceM Definition
instantiateFull' def :: Definition
def@Defn{ defType :: Definition -> Type
defType = Type
t ,defDisplay :: Definition -> [LocalDisplayForm]
defDisplay = [LocalDisplayForm]
df, theDef :: Definition -> Defn
theDef = Defn
d } =
    if Definition -> Bool
defMightContainMetas Definition
def then do
      (t, df, d) <- (Type, [LocalDisplayForm], Defn)
-> ReduceM (Type, [LocalDisplayForm], Defn)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (Type
t, [LocalDisplayForm]
df, Defn
d)
      return $! def{ defType = t, defDisplay = df, theDef = d }
    else do
      Definition -> ReduceM Definition
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Definition
def

instance InstantiateFull NLPat where
  instantiateFull' :: NLPat -> ReduceM NLPat
instantiateFull' (PVar DefSing
s Int
x [Arg Int]
y)    = NLPat -> ReduceM NLPat
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (NLPat -> ReduceM NLPat) -> NLPat -> ReduceM NLPat
forall a b. (a -> b) -> a -> b
$ DefSing -> Int -> [Arg Int] -> NLPat
PVar DefSing
s Int
x [Arg Int]
y
  instantiateFull' (PDef QName
x PElims
y)      = QName -> PElims -> NLPat
PDef (QName -> PElims -> NLPat)
-> ReduceM QName -> ReduceM (PElims -> NLPat)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> QName -> ReduceM QName
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' QName
x ReduceM (PElims -> NLPat) -> ReduceM PElims -> ReduceM NLPat
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> PElims -> ReduceM PElims
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' PElims
y
  instantiateFull' (PLam ArgInfo
x Abs NLPat
y)      = ArgInfo -> Abs NLPat -> NLPat
PLam ArgInfo
x (Abs NLPat -> NLPat) -> ReduceM (Abs NLPat) -> ReduceM NLPat
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Abs NLPat -> ReduceM (Abs NLPat)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Abs NLPat
y
  instantiateFull' (PPi Dom' Term NLPType
x Abs NLPType
y)       = Dom' Term NLPType -> Abs NLPType -> NLPat
PPi (Dom' Term NLPType -> Abs NLPType -> NLPat)
-> ReduceM (Dom' Term NLPType) -> ReduceM (Abs NLPType -> NLPat)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Dom' Term NLPType -> ReduceM (Dom' Term NLPType)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Dom' Term NLPType
x ReduceM (Abs NLPType -> NLPat)
-> ReduceM (Abs NLPType) -> ReduceM NLPat
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Abs NLPType -> ReduceM (Abs NLPType)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Abs NLPType
y
  instantiateFull' (PSort NLPSort
x)       = NLPSort -> NLPat
PSort (NLPSort -> NLPat) -> ReduceM NLPSort -> ReduceM NLPat
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> NLPSort -> ReduceM NLPSort
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' NLPSort
x
  instantiateFull' (PBoundVar Int
x PElims
y) = Int -> PElims -> NLPat
PBoundVar Int
x (PElims -> NLPat) -> ReduceM PElims -> ReduceM NLPat
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> PElims -> ReduceM PElims
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' PElims
y
  instantiateFull' (PTerm Term
x)       = Term -> NLPat
PTerm (Term -> NLPat) -> ReduceM Term -> ReduceM NLPat
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
x

instance InstantiateFull NLPType where
  instantiateFull' :: NLPType -> ReduceM NLPType
instantiateFull' (NLPType NLPSort
s NLPat
a) = NLPSort -> NLPat -> NLPType
NLPType
    (NLPSort -> NLPat -> NLPType)
-> ReduceM NLPSort -> ReduceM (NLPat -> NLPType)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> NLPSort -> ReduceM NLPSort
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' NLPSort
s
    ReduceM (NLPat -> NLPType) -> ReduceM NLPat -> ReduceM NLPType
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> NLPat -> ReduceM NLPat
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' NLPat
a

instance InstantiateFull NLPSort where
  instantiateFull' :: NLPSort -> ReduceM NLPSort
instantiateFull' (PUniv Univ
u NLPat
x) = Univ -> NLPat -> NLPSort
PUniv Univ
u (NLPat -> NLPSort) -> ReduceM NLPat -> ReduceM NLPSort
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> NLPat -> ReduceM NLPat
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' NLPat
x
  instantiateFull' (PInf Univ
f Integer
n) = NLPSort -> ReduceM NLPSort
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (NLPSort -> ReduceM NLPSort) -> NLPSort -> ReduceM NLPSort
forall a b. (a -> b) -> a -> b
$ Univ -> Integer -> NLPSort
PInf Univ
f Integer
n
  instantiateFull' NLPSort
PSizeUniv = NLPSort -> ReduceM NLPSort
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return NLPSort
PSizeUniv
  instantiateFull' NLPSort
PLockUniv = NLPSort -> ReduceM NLPSort
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return NLPSort
PLockUniv
  instantiateFull' NLPSort
PLevelUniv = NLPSort -> ReduceM NLPSort
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return NLPSort
PLevelUniv
  instantiateFull' NLPSort
PIntervalUniv = NLPSort -> ReduceM NLPSort
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return NLPSort
PIntervalUniv

instance InstantiateFull GlobalRewriteRule where
  instantiateFull' :: GlobalRewriteRule -> ReduceM GlobalRewriteRule
instantiateFull' (GlobalRewriteRule QName
q Telescope
gamma QName
f PElims
ps Term
rhs Type
t Bool
c TopLevelModuleName
top) =
    QName
-> Telescope
-> QName
-> PElims
-> Term
-> Type
-> Bool
-> TopLevelModuleName
-> GlobalRewriteRule
GlobalRewriteRule QName
q
      (Telescope
 -> QName
 -> PElims
 -> Term
 -> Type
 -> Bool
 -> TopLevelModuleName
 -> GlobalRewriteRule)
-> ReduceM Telescope
-> ReduceM
     (QName
      -> PElims
      -> Term
      -> Type
      -> Bool
      -> TopLevelModuleName
      -> GlobalRewriteRule)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Telescope -> ReduceM Telescope
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Telescope
gamma
      ReduceM
  (QName
   -> PElims
   -> Term
   -> Type
   -> Bool
   -> TopLevelModuleName
   -> GlobalRewriteRule)
-> ReduceM QName
-> ReduceM
     (PElims
      -> Term -> Type -> Bool -> TopLevelModuleName -> GlobalRewriteRule)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> QName -> ReduceM QName
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure QName
f
      ReduceM
  (PElims
   -> Term -> Type -> Bool -> TopLevelModuleName -> GlobalRewriteRule)
-> ReduceM PElims
-> ReduceM
     (Term -> Type -> Bool -> TopLevelModuleName -> GlobalRewriteRule)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> PElims -> ReduceM PElims
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' PElims
ps
      ReduceM
  (Term -> Type -> Bool -> TopLevelModuleName -> GlobalRewriteRule)
-> ReduceM Term
-> ReduceM
     (Type -> Bool -> TopLevelModuleName -> GlobalRewriteRule)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
rhs
      ReduceM (Type -> Bool -> TopLevelModuleName -> GlobalRewriteRule)
-> ReduceM Type
-> ReduceM (Bool -> TopLevelModuleName -> GlobalRewriteRule)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
t
      ReduceM (Bool -> TopLevelModuleName -> GlobalRewriteRule)
-> ReduceM Bool
-> ReduceM (TopLevelModuleName -> GlobalRewriteRule)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Bool -> ReduceM Bool
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
c
      ReduceM (TopLevelModuleName -> GlobalRewriteRule)
-> ReduceM TopLevelModuleName -> ReduceM GlobalRewriteRule
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> TopLevelModuleName -> ReduceM TopLevelModuleName
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure TopLevelModuleName
top

instance InstantiateFull LocalEquation where
  instantiateFull' :: LocalEquation' Term -> ReduceM (LocalEquation' Term)
instantiateFull' (LocalEquation Telescope
a Term
b Term
c Type
d) =
    Telescope -> Term -> Term -> Type -> LocalEquation' Term
forall t.
Tele (Dom' t (Type'' t t))
-> t -> t -> Type'' t t -> LocalEquation' t
LocalEquation
      (Telescope -> Term -> Term -> Type -> LocalEquation' Term)
-> ReduceM Telescope
-> ReduceM (Term -> Term -> Type -> LocalEquation' Term)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Telescope -> ReduceM Telescope
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Telescope
a
      ReduceM (Term -> Term -> Type -> LocalEquation' Term)
-> ReduceM Term -> ReduceM (Term -> Type -> LocalEquation' Term)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
b
      ReduceM (Term -> Type -> LocalEquation' Term)
-> ReduceM Term -> ReduceM (Type -> LocalEquation' Term)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
c
      ReduceM (Type -> LocalEquation' Term)
-> ReduceM Type -> ReduceM (LocalEquation' Term)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
d

instance InstantiateFull RewriteRule where
  instantiateFull' :: RewriteRule -> ReduceM RewriteRule
instantiateFull' (RewriteRule Telescope
a RewriteHead
b PElims
c Term
d Type
e) =
    Telescope -> RewriteHead -> PElims -> Term -> Type -> RewriteRule
RewriteRule
      (Telescope -> RewriteHead -> PElims -> Term -> Type -> RewriteRule)
-> ReduceM Telescope
-> ReduceM (RewriteHead -> PElims -> Term -> Type -> RewriteRule)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Telescope -> ReduceM Telescope
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Telescope
a
      ReduceM (RewriteHead -> PElims -> Term -> Type -> RewriteRule)
-> ReduceM RewriteHead
-> ReduceM (PElims -> Term -> Type -> RewriteRule)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> RewriteHead -> ReduceM RewriteHead
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure RewriteHead
b
      ReduceM (PElims -> Term -> Type -> RewriteRule)
-> ReduceM PElims -> ReduceM (Term -> Type -> RewriteRule)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> PElims -> ReduceM PElims
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' PElims
c
      ReduceM (Term -> Type -> RewriteRule)
-> ReduceM Term -> ReduceM (Type -> RewriteRule)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
d
      ReduceM (Type -> RewriteRule)
-> ReduceM Type -> ReduceM RewriteRule
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
e

instance InstantiateFull RewDom where
  instantiateFull' :: RewDom' Term -> ReduceM (RewDom' Term)
instantiateFull' (RewDom LocalEquation' Term
a Maybe RewriteRule
b) =
    LocalEquation' Term -> Maybe RewriteRule -> RewDom' Term
forall t. LocalEquation' t -> Maybe RewriteRule -> RewDom' t
RewDom
      (LocalEquation' Term -> Maybe RewriteRule -> RewDom' Term)
-> ReduceM (LocalEquation' Term)
-> ReduceM (Maybe RewriteRule -> RewDom' Term)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> LocalEquation' Term -> ReduceM (LocalEquation' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' LocalEquation' Term
a
      ReduceM (Maybe RewriteRule -> RewDom' Term)
-> ReduceM (Maybe RewriteRule) -> ReduceM (RewDom' Term)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe RewriteRule -> ReduceM (Maybe RewriteRule)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe RewriteRule
b

instance InstantiateFull DisplayForm where
  instantiateFull' :: DisplayForm -> ReduceM DisplayForm
instantiateFull' (Display Int
n [Elim]
ps DisplayTerm
v) = ([Elim] -> DisplayTerm -> DisplayForm)
-> ([Elim], DisplayTerm) -> DisplayForm
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry (Int -> [Elim] -> DisplayTerm -> DisplayForm
Display Int
n) (([Elim], DisplayTerm) -> DisplayForm)
-> ReduceM ([Elim], DisplayTerm) -> ReduceM DisplayForm
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> ([Elim], DisplayTerm) -> ReduceM ([Elim], DisplayTerm)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' ([Elim]
ps, DisplayTerm
v)

instance InstantiateFull DisplayTerm where
  instantiateFull' :: DisplayTerm -> ReduceM DisplayTerm
instantiateFull' (DTerm' Term
v [Elim]
es)   = Term -> [Elim] -> DisplayTerm
DTerm' (Term -> [Elim] -> DisplayTerm)
-> ReduceM Term -> ReduceM ([Elim] -> DisplayTerm)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
v ReduceM ([Elim] -> DisplayTerm)
-> ReduceM [Elim] -> ReduceM DisplayTerm
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
es
  instantiateFull' (DDot' Term
v [Elim]
es)    = Term -> [Elim] -> DisplayTerm
DDot'  (Term -> [Elim] -> DisplayTerm)
-> ReduceM Term -> ReduceM ([Elim] -> DisplayTerm)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
v ReduceM ([Elim] -> DisplayTerm)
-> ReduceM [Elim] -> ReduceM DisplayTerm
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [Elim] -> ReduceM [Elim]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim]
es
  instantiateFull' (DCon ConHead
c ConInfo
ci [Arg DisplayTerm]
vs)  = ConHead -> ConInfo -> [Arg DisplayTerm] -> DisplayTerm
DCon ConHead
c ConInfo
ci ([Arg DisplayTerm] -> DisplayTerm)
-> ReduceM [Arg DisplayTerm] -> ReduceM DisplayTerm
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [Arg DisplayTerm] -> ReduceM [Arg DisplayTerm]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Arg DisplayTerm]
vs
  instantiateFull' (DDef QName
c [Elim' DisplayTerm]
es)     = QName -> [Elim' DisplayTerm] -> DisplayTerm
DDef QName
c ([Elim' DisplayTerm] -> DisplayTerm)
-> ReduceM [Elim' DisplayTerm] -> ReduceM DisplayTerm
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> [Elim' DisplayTerm] -> ReduceM [Elim' DisplayTerm]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Elim' DisplayTerm]
es
  instantiateFull' (DWithApp DisplayTerm
v NonEmpty DisplayTerm
vs [Elim]
ws) = (DisplayTerm -> NonEmpty DisplayTerm -> [Elim] -> DisplayTerm)
-> (DisplayTerm, NonEmpty DisplayTerm, [Elim]) -> DisplayTerm
forall a b c d. (a -> b -> c -> d) -> (a, b, c) -> d
uncurry3 DisplayTerm -> NonEmpty DisplayTerm -> [Elim] -> DisplayTerm
DWithApp ((DisplayTerm, NonEmpty DisplayTerm, [Elim]) -> DisplayTerm)
-> ReduceM (DisplayTerm, NonEmpty DisplayTerm, [Elim])
-> ReduceM DisplayTerm
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> (DisplayTerm, NonEmpty DisplayTerm, [Elim])
-> ReduceM (DisplayTerm, NonEmpty DisplayTerm, [Elim])
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' (DisplayTerm
v, NonEmpty DisplayTerm
vs, [Elim]
ws)

instance InstantiateFull Defn where
    instantiateFull' :: Defn -> ReduceM Defn
instantiateFull' Defn
d = case Defn
d of
      Axiom{} -> Defn -> ReduceM Defn
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Defn
d
      DataOrRecSig{} -> Defn -> ReduceM Defn
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Defn
d
      GeneralizableVar{} -> Defn -> ReduceM Defn
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Defn
d
      AbstractDefn Defn
d -> Defn -> Defn
AbstractDefn (Defn -> Defn) -> ReduceM Defn -> ReduceM Defn
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Defn -> ReduceM Defn
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Defn
d
      Function{ funClauses :: Defn -> [Clause]
funClauses = [Clause]
cs, funCompiled :: Defn -> Maybe CompiledClauses
funCompiled = Maybe CompiledClauses
cc, funCovering :: Defn -> [Clause]
funCovering = [Clause]
cov, funInv :: Defn -> FunctionInverse' Clause
funInv = FunctionInverse' Clause
inv, funExtLam :: Defn -> Maybe ExtLamInfo
funExtLam = Maybe ExtLamInfo
extLam } -> do
        (cs, cc, cov, inv) <- ([Clause], Maybe CompiledClauses, [Clause],
 FunctionInverse' Clause)
-> ReduceM
     ([Clause], Maybe CompiledClauses, [Clause],
      FunctionInverse' Clause)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' ([Clause]
cs, Maybe CompiledClauses
cc, [Clause]
cov, FunctionInverse' Clause
inv)
        extLam <- instantiateFull' extLam
        return $! d { funClauses = cs, funCompiled = cc, funCovering = cov, funInv = inv, funExtLam = extLam }
      Datatype{ dataSort :: Defn -> Sort' Term
dataSort = Sort' Term
s, dataClause :: Defn -> Maybe Clause
dataClause = Maybe Clause
cl } -> do
        s  <- Sort' Term -> ReduceM (Sort' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Sort' Term
s
        cl <- instantiateFull' cl
        return $! d { dataSort = s, dataClause = cl }
      Record{ recClause :: Defn -> Maybe Clause
recClause = Maybe Clause
cl, recTel :: Defn -> Telescope
recTel = Telescope
tel } -> do
        cl  <- Maybe Clause -> ReduceM (Maybe Clause)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe Clause
cl
        tel <- instantiateFull' tel
        return $! d { recClause = cl, recTel = tel }
      Constructor{} -> Defn -> ReduceM Defn
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Defn
d
      Primitive{ primClauses :: Defn -> [Clause]
primClauses = [Clause]
cs } -> do
        cs <- [Clause] -> ReduceM [Clause]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [Clause]
cs
        return $! d { primClauses = cs }
      PrimitiveSort{} -> Defn -> ReduceM Defn
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Defn
d

instance InstantiateFull ExtLamInfo where
  instantiateFull' :: ExtLamInfo -> ReduceM ExtLamInfo
instantiateFull' e :: ExtLamInfo
e@(ExtLamInfo { extLamSys :: ExtLamInfo -> Maybe System
extLamSys = Maybe System
sys}) = do
    sys <- Maybe System -> ReduceM (Maybe System)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe System
sys
    return $ e { extLamSys = sys}

instance InstantiateFull System where
  instantiateFull' :: System -> ReduceM System
instantiateFull' (System Telescope
tel [(Face, Term)]
sys) = Telescope -> [(Face, Term)] -> System
System (Telescope -> [(Face, Term)] -> System)
-> ReduceM Telescope -> ReduceM ([(Face, Term)] -> System)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Telescope -> ReduceM Telescope
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Telescope
tel ReduceM ([(Face, Term)] -> System)
-> ReduceM [(Face, Term)] -> ReduceM System
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [(Face, Term)] -> ReduceM [(Face, Term)]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [(Face, Term)]
sys

instance InstantiateFull FunctionInverse where
  instantiateFull' :: FunctionInverse' Clause -> ReduceM (FunctionInverse' Clause)
instantiateFull' FunctionInverse' Clause
NotInjective = FunctionInverse' Clause -> ReduceM (FunctionInverse' Clause)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return FunctionInverse' Clause
forall c. FunctionInverse' c
NotInjective
  instantiateFull' (Inverse Map TermHead [Clause]
inv) = Map TermHead [Clause] -> FunctionInverse' Clause
forall c. InversionMap c -> FunctionInverse' c
Inverse (Map TermHead [Clause] -> FunctionInverse' Clause)
-> ReduceM (Map TermHead [Clause])
-> ReduceM (FunctionInverse' Clause)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Map TermHead [Clause] -> ReduceM (Map TermHead [Clause])
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Map TermHead [Clause]
inv

instance InstantiateFull a => InstantiateFull (Case a) where
  instantiateFull' :: Case a -> ReduceM (Case a)
instantiateFull' (Branches Bool
cop Map QName (WithArity a)
cs Maybe (ConHead, WithArity a)
eta Map Literal a
ls Maybe a
m Maybe Bool
b Bool
lz) =
    Bool
-> Map QName (WithArity a)
-> Maybe (ConHead, WithArity a)
-> Map Literal a
-> Maybe a
-> Maybe Bool
-> Bool
-> Case a
forall c.
Bool
-> Map QName (WithArity c)
-> Maybe (ConHead, WithArity c)
-> Map Literal c
-> Maybe c
-> Maybe Bool
-> Bool
-> Case c
Branches Bool
cop
      (Map QName (WithArity a)
 -> Maybe (ConHead, WithArity a)
 -> Map Literal a
 -> Maybe a
 -> Maybe Bool
 -> Bool
 -> Case a)
-> ReduceM (Map QName (WithArity a))
-> ReduceM
     (Maybe (ConHead, WithArity a)
      -> Map Literal a -> Maybe a -> Maybe Bool -> Bool -> Case a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Map QName (WithArity a) -> ReduceM (Map QName (WithArity a))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Map QName (WithArity a)
cs
      ReduceM
  (Maybe (ConHead, WithArity a)
   -> Map Literal a -> Maybe a -> Maybe Bool -> Bool -> Case a)
-> ReduceM (Maybe (ConHead, WithArity a))
-> ReduceM
     (Map Literal a -> Maybe a -> Maybe Bool -> Bool -> Case a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe (ConHead, WithArity a)
-> ReduceM (Maybe (ConHead, WithArity a))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe (ConHead, WithArity a)
eta
      ReduceM (Map Literal a -> Maybe a -> Maybe Bool -> Bool -> Case a)
-> ReduceM (Map Literal a)
-> ReduceM (Maybe a -> Maybe Bool -> Bool -> Case a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Map Literal a -> ReduceM (Map Literal a)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Map Literal a
ls
      ReduceM (Maybe a -> Maybe Bool -> Bool -> Case a)
-> ReduceM (Maybe a) -> ReduceM (Maybe Bool -> Bool -> Case a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe a -> ReduceM (Maybe a)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe a
m
      ReduceM (Maybe Bool -> Bool -> Case a)
-> ReduceM (Maybe Bool) -> ReduceM (Bool -> Case a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe Bool -> ReduceM (Maybe Bool)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Maybe Bool
b
      ReduceM (Bool -> Case a) -> ReduceM Bool -> ReduceM (Case a)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Bool -> ReduceM Bool
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
lz

instance InstantiateFull CompiledClauses where
  instantiateFull' :: CompiledClauses -> ReduceM CompiledClauses
instantiateFull' = \case
    Fail [Arg [Char]]
xs        -> CompiledClauses -> ReduceM CompiledClauses
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return (CompiledClauses -> ReduceM CompiledClauses)
-> CompiledClauses -> ReduceM CompiledClauses
forall a b. (a -> b) -> a -> b
$ [Arg [Char]] -> CompiledClauses
forall a. [Arg [Char]] -> CompiledClauses' a
Fail [Arg [Char]]
xs
    Done Int
no ClauseRecursive
mr [Arg [Char]]
m Term
t -> Int -> ClauseRecursive -> [Arg [Char]] -> Term -> CompiledClauses
forall a.
Int -> ClauseRecursive -> [Arg [Char]] -> a -> CompiledClauses' a
Done Int
no ClauseRecursive
mr [Arg [Char]]
m (Term -> CompiledClauses)
-> ReduceM Term -> ReduceM CompiledClauses
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
t
    Case Arg Int
n Case CompiledClauses
bs      -> Arg Int -> Case CompiledClauses -> CompiledClauses
forall a.
Arg Int -> Case (CompiledClauses' a) -> CompiledClauses' a
Case Arg Int
n (Case CompiledClauses -> CompiledClauses)
-> ReduceM (Case CompiledClauses) -> ReduceM CompiledClauses
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Case CompiledClauses -> ReduceM (Case CompiledClauses)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Case CompiledClauses
bs

instance InstantiateFull Clause where
    instantiateFull' :: Clause -> ReduceM Clause
instantiateFull' (Clause Range
rl Range
rf Telescope
tel NAPs
ps Maybe Term
b Maybe (Arg Type)
t Catchall
catchall ClauseRecursive
recursive Maybe Bool
unreachable ExpandedEllipsis
ell Maybe ModuleName
wm) =
       Range
-> Range
-> Telescope
-> NAPs
-> Maybe Term
-> Maybe (Arg Type)
-> Catchall
-> ClauseRecursive
-> Maybe Bool
-> ExpandedEllipsis
-> Maybe ModuleName
-> Clause
Clause Range
rl Range
rf (Telescope
 -> NAPs
 -> Maybe Term
 -> Maybe (Arg Type)
 -> Catchall
 -> ClauseRecursive
 -> Maybe Bool
 -> ExpandedEllipsis
 -> Maybe ModuleName
 -> Clause)
-> ReduceM Telescope
-> ReduceM
     (NAPs
      -> Maybe Term
      -> Maybe (Arg Type)
      -> Catchall
      -> ClauseRecursive
      -> Maybe Bool
      -> ExpandedEllipsis
      -> Maybe ModuleName
      -> Clause)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Telescope -> ReduceM Telescope
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Telescope
tel
       ReduceM
  (NAPs
   -> Maybe Term
   -> Maybe (Arg Type)
   -> Catchall
   -> ClauseRecursive
   -> Maybe Bool
   -> ExpandedEllipsis
   -> Maybe ModuleName
   -> Clause)
-> ReduceM NAPs
-> ReduceM
     (Maybe Term
      -> Maybe (Arg Type)
      -> Catchall
      -> ClauseRecursive
      -> Maybe Bool
      -> ExpandedEllipsis
      -> Maybe ModuleName
      -> Clause)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> NAPs -> ReduceM NAPs
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' NAPs
ps
       ReduceM
  (Maybe Term
   -> Maybe (Arg Type)
   -> Catchall
   -> ClauseRecursive
   -> Maybe Bool
   -> ExpandedEllipsis
   -> Maybe ModuleName
   -> Clause)
-> ReduceM (Maybe Term)
-> ReduceM
     (Maybe (Arg Type)
      -> Catchall
      -> ClauseRecursive
      -> Maybe Bool
      -> ExpandedEllipsis
      -> Maybe ModuleName
      -> Clause)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe Term -> ReduceM (Maybe Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe Term
b
       ReduceM
  (Maybe (Arg Type)
   -> Catchall
   -> ClauseRecursive
   -> Maybe Bool
   -> ExpandedEllipsis
   -> Maybe ModuleName
   -> Clause)
-> ReduceM (Maybe (Arg Type))
-> ReduceM
     (Catchall
      -> ClauseRecursive
      -> Maybe Bool
      -> ExpandedEllipsis
      -> Maybe ModuleName
      -> Clause)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe (Arg Type) -> ReduceM (Maybe (Arg Type))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Maybe (Arg Type)
t
       ReduceM
  (Catchall
   -> ClauseRecursive
   -> Maybe Bool
   -> ExpandedEllipsis
   -> Maybe ModuleName
   -> Clause)
-> ReduceM Catchall
-> ReduceM
     (ClauseRecursive
      -> Maybe Bool -> ExpandedEllipsis -> Maybe ModuleName -> Clause)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Catchall -> ReduceM Catchall
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Catchall
catchall
       ReduceM
  (ClauseRecursive
   -> Maybe Bool -> ExpandedEllipsis -> Maybe ModuleName -> Clause)
-> ReduceM ClauseRecursive
-> ReduceM
     (Maybe Bool -> ExpandedEllipsis -> Maybe ModuleName -> Clause)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> ClauseRecursive -> ReduceM ClauseRecursive
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return ClauseRecursive
recursive
       ReduceM
  (Maybe Bool -> ExpandedEllipsis -> Maybe ModuleName -> Clause)
-> ReduceM (Maybe Bool)
-> ReduceM (ExpandedEllipsis -> Maybe ModuleName -> Clause)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe Bool -> ReduceM (Maybe Bool)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Bool
unreachable
       ReduceM (ExpandedEllipsis -> Maybe ModuleName -> Clause)
-> ReduceM ExpandedEllipsis -> ReduceM (Maybe ModuleName -> Clause)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> ExpandedEllipsis -> ReduceM ExpandedEllipsis
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return ExpandedEllipsis
ell
       ReduceM (Maybe ModuleName -> Clause)
-> ReduceM (Maybe ModuleName) -> ReduceM Clause
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe ModuleName -> ReduceM (Maybe ModuleName)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe ModuleName
wm

instance InstantiateFull Instantiation where
  instantiateFull' :: Instantiation -> ReduceM Instantiation
instantiateFull' (Instantiation [Arg [Char]]
a Term
b) =
    [Arg [Char]] -> Term -> Instantiation
Instantiation [Arg [Char]]
a (Term -> Instantiation) -> ReduceM Term -> ReduceM Instantiation
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
b

instance InstantiateFull (Judgement MetaId) where
  instantiateFull' :: Judgement MetaId -> ReduceM (Judgement MetaId)
instantiateFull' (HasType MetaId
a Comparison
b Type
c) =
    MetaId -> Comparison -> Type -> Judgement MetaId
forall a. a -> Comparison -> Type -> Judgement a
HasType MetaId
a Comparison
b (Type -> Judgement MetaId)
-> ReduceM Type -> ReduceM (Judgement MetaId)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
c
  instantiateFull' (IsSort MetaId
a Type
b) =
    MetaId -> Type -> Judgement MetaId
forall a. a -> Type -> Judgement a
IsSort MetaId
a (Type -> Judgement MetaId)
-> ReduceM Type -> ReduceM (Judgement MetaId)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
b

instance InstantiateFull RemoteMetaVariable where
  instantiateFull' :: RemoteMetaVariable -> ReduceM RemoteMetaVariable
instantiateFull' (RemoteMetaVariable Instantiation
a Modality
b Judgement MetaId
c) = Instantiation -> Modality -> Judgement MetaId -> RemoteMetaVariable
RemoteMetaVariable
    (Instantiation
 -> Modality -> Judgement MetaId -> RemoteMetaVariable)
-> ReduceM Instantiation
-> ReduceM (Modality -> Judgement MetaId -> RemoteMetaVariable)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Instantiation -> ReduceM Instantiation
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Instantiation
a
    ReduceM (Modality -> Judgement MetaId -> RemoteMetaVariable)
-> ReduceM Modality
-> ReduceM (Judgement MetaId -> RemoteMetaVariable)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Modality -> ReduceM Modality
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Modality
b
    ReduceM (Judgement MetaId -> RemoteMetaVariable)
-> ReduceM (Judgement MetaId) -> ReduceM RemoteMetaVariable
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Judgement MetaId -> ReduceM (Judgement MetaId)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Judgement MetaId
c

instance InstantiateFull Interface where
  instantiateFull' :: Interface -> ReduceM Interface
instantiateFull'
    (Interface Hash
h Text
s FileType
ft [(TopLevelModuleName, Hash)]
ms ModuleName
mod TopLevelModuleName
tlmod Map ModuleName Scope
scope ScopeInfo
inside Signature
sig HashMap MetaId RemoteMetaVariable
_ HashMap QName (List1 LocalDisplayForm)
display UserWarnings
userwarn
         Maybe Text
importwarn Map SomeBuiltin (Builtin (PrimitiveId, QName))
b Map Text ForeignCodeStack
foreignCode HighlightingInfo
highlighting [OptionsPragma]
libPragmas [OptionsPragma]
filePragmas
         PragmaOptions
usedOpts PatternSynDefns
patsyns Set TCWarning
warnings Set QName
partialdefs Map OpaqueId OpaqueBlock
oblocks Map QName OpaqueId
onames) = do
    Hash
-> Text
-> FileType
-> [(TopLevelModuleName, Hash)]
-> ModuleName
-> TopLevelModuleName
-> Map ModuleName Scope
-> ScopeInfo
-> Signature
-> HashMap MetaId RemoteMetaVariable
-> HashMap QName (List1 LocalDisplayForm)
-> UserWarnings
-> Maybe Text
-> Map SomeBuiltin (Builtin (PrimitiveId, QName))
-> Map Text ForeignCodeStack
-> HighlightingInfo
-> [OptionsPragma]
-> [OptionsPragma]
-> PragmaOptions
-> PatternSynDefns
-> Set TCWarning
-> Set QName
-> Map OpaqueId OpaqueBlock
-> Map QName OpaqueId
-> Interface
Interface Hash
h Text
s FileType
ft [(TopLevelModuleName, Hash)]
ms ModuleName
mod TopLevelModuleName
tlmod Map ModuleName Scope
scope ScopeInfo
inside
      (Signature
 -> HashMap MetaId RemoteMetaVariable
 -> HashMap QName (List1 LocalDisplayForm)
 -> UserWarnings
 -> Maybe Text
 -> Map SomeBuiltin (Builtin (PrimitiveId, QName))
 -> Map Text ForeignCodeStack
 -> HighlightingInfo
 -> [OptionsPragma]
 -> [OptionsPragma]
 -> PragmaOptions
 -> PatternSynDefns
 -> Set TCWarning
 -> Set QName
 -> Map OpaqueId OpaqueBlock
 -> Map QName OpaqueId
 -> Interface)
-> ReduceM Signature
-> ReduceM
     (HashMap MetaId RemoteMetaVariable
      -> HashMap QName (List1 LocalDisplayForm)
      -> UserWarnings
      -> Maybe Text
      -> Map SomeBuiltin (Builtin (PrimitiveId, QName))
      -> Map Text ForeignCodeStack
      -> HighlightingInfo
      -> [OptionsPragma]
      -> [OptionsPragma]
      -> PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Signature -> ReduceM Signature
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Signature
sig
      ReduceM
  (HashMap MetaId RemoteMetaVariable
   -> HashMap QName (List1 LocalDisplayForm)
   -> UserWarnings
   -> Maybe Text
   -> Map SomeBuiltin (Builtin (PrimitiveId, QName))
   -> Map Text ForeignCodeStack
   -> HighlightingInfo
   -> [OptionsPragma]
   -> [OptionsPragma]
   -> PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM (HashMap MetaId RemoteMetaVariable)
-> ReduceM
     (HashMap QName (List1 LocalDisplayForm)
      -> UserWarnings
      -> Maybe Text
      -> Map SomeBuiltin (Builtin (PrimitiveId, QName))
      -> Map Text ForeignCodeStack
      -> HighlightingInfo
      -> [OptionsPragma]
      -> [OptionsPragma]
      -> PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> HashMap MetaId RemoteMetaVariable
-> ReduceM (HashMap MetaId RemoteMetaVariable)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure HashMap MetaId RemoteMetaVariable
forall a. Monoid a => a
mempty               -- remote metas are dropped
      ReduceM
  (HashMap QName (List1 LocalDisplayForm)
   -> UserWarnings
   -> Maybe Text
   -> Map SomeBuiltin (Builtin (PrimitiveId, QName))
   -> Map Text ForeignCodeStack
   -> HighlightingInfo
   -> [OptionsPragma]
   -> [OptionsPragma]
   -> PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM (HashMap QName (List1 LocalDisplayForm))
-> ReduceM
     (UserWarnings
      -> Maybe Text
      -> Map SomeBuiltin (Builtin (PrimitiveId, QName))
      -> Map Text ForeignCodeStack
      -> HighlightingInfo
      -> [OptionsPragma]
      -> [OptionsPragma]
      -> PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> HashMap QName (List1 LocalDisplayForm)
-> ReduceM (HashMap QName (List1 LocalDisplayForm))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' HashMap QName (List1 LocalDisplayForm)
display
      ReduceM
  (UserWarnings
   -> Maybe Text
   -> Map SomeBuiltin (Builtin (PrimitiveId, QName))
   -> Map Text ForeignCodeStack
   -> HighlightingInfo
   -> [OptionsPragma]
   -> [OptionsPragma]
   -> PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM UserWarnings
-> ReduceM
     (Maybe Text
      -> Map SomeBuiltin (Builtin (PrimitiveId, QName))
      -> Map Text ForeignCodeStack
      -> HighlightingInfo
      -> [OptionsPragma]
      -> [OptionsPragma]
      -> PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> UserWarnings -> ReduceM UserWarnings
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return UserWarnings
userwarn
      ReduceM
  (Maybe Text
   -> Map SomeBuiltin (Builtin (PrimitiveId, QName))
   -> Map Text ForeignCodeStack
   -> HighlightingInfo
   -> [OptionsPragma]
   -> [OptionsPragma]
   -> PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM (Maybe Text)
-> ReduceM
     (Map SomeBuiltin (Builtin (PrimitiveId, QName))
      -> Map Text ForeignCodeStack
      -> HighlightingInfo
      -> [OptionsPragma]
      -> [OptionsPragma]
      -> PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Maybe Text -> ReduceM (Maybe Text)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Text
importwarn
      ReduceM
  (Map SomeBuiltin (Builtin (PrimitiveId, QName))
   -> Map Text ForeignCodeStack
   -> HighlightingInfo
   -> [OptionsPragma]
   -> [OptionsPragma]
   -> PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM (Map SomeBuiltin (Builtin (PrimitiveId, QName)))
-> ReduceM
     (Map Text ForeignCodeStack
      -> HighlightingInfo
      -> [OptionsPragma]
      -> [OptionsPragma]
      -> PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Map SomeBuiltin (Builtin (PrimitiveId, QName))
-> ReduceM (Map SomeBuiltin (Builtin (PrimitiveId, QName)))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Map SomeBuiltin (Builtin (PrimitiveId, QName))
b
      ReduceM
  (Map Text ForeignCodeStack
   -> HighlightingInfo
   -> [OptionsPragma]
   -> [OptionsPragma]
   -> PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM (Map Text ForeignCodeStack)
-> ReduceM
     (HighlightingInfo
      -> [OptionsPragma]
      -> [OptionsPragma]
      -> PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Map Text ForeignCodeStack -> ReduceM (Map Text ForeignCodeStack)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Map Text ForeignCodeStack
foreignCode
      ReduceM
  (HighlightingInfo
   -> [OptionsPragma]
   -> [OptionsPragma]
   -> PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM HighlightingInfo
-> ReduceM
     ([OptionsPragma]
      -> [OptionsPragma]
      -> PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> HighlightingInfo -> ReduceM HighlightingInfo
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return HighlightingInfo
highlighting
      ReduceM
  ([OptionsPragma]
   -> [OptionsPragma]
   -> PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM [OptionsPragma]
-> ReduceM
     ([OptionsPragma]
      -> PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [OptionsPragma] -> ReduceM [OptionsPragma]
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return [OptionsPragma]
libPragmas
      ReduceM
  ([OptionsPragma]
   -> PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM [OptionsPragma]
-> ReduceM
     (PragmaOptions
      -> PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> [OptionsPragma] -> ReduceM [OptionsPragma]
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return [OptionsPragma]
filePragmas
      ReduceM
  (PragmaOptions
   -> PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM PragmaOptions
-> ReduceM
     (PatternSynDefns
      -> Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> PragmaOptions -> ReduceM PragmaOptions
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return PragmaOptions
usedOpts
      ReduceM
  (PatternSynDefns
   -> Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM PatternSynDefns
-> ReduceM
     (Set TCWarning
      -> Set QName
      -> Map OpaqueId OpaqueBlock
      -> Map QName OpaqueId
      -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> PatternSynDefns -> ReduceM PatternSynDefns
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return PatternSynDefns
patsyns
      ReduceM
  (Set TCWarning
   -> Set QName
   -> Map OpaqueId OpaqueBlock
   -> Map QName OpaqueId
   -> Interface)
-> ReduceM (Set TCWarning)
-> ReduceM
     (Set QName
      -> Map OpaqueId OpaqueBlock -> Map QName OpaqueId -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Set TCWarning -> ReduceM (Set TCWarning)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Set TCWarning
warnings
      ReduceM
  (Set QName
   -> Map OpaqueId OpaqueBlock -> Map QName OpaqueId -> Interface)
-> ReduceM (Set QName)
-> ReduceM
     (Map OpaqueId OpaqueBlock -> Map QName OpaqueId -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Set QName -> ReduceM (Set QName)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Set QName
partialdefs
      ReduceM
  (Map OpaqueId OpaqueBlock -> Map QName OpaqueId -> Interface)
-> ReduceM (Map OpaqueId OpaqueBlock)
-> ReduceM (Map QName OpaqueId -> Interface)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Map OpaqueId OpaqueBlock -> ReduceM (Map OpaqueId OpaqueBlock)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Map OpaqueId OpaqueBlock
oblocks
      ReduceM (Map QName OpaqueId -> Interface)
-> ReduceM (Map QName OpaqueId) -> ReduceM Interface
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Map QName OpaqueId -> ReduceM (Map QName OpaqueId)
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return Map QName OpaqueId
onames

instance InstantiateFull a => InstantiateFull (Builtin a) where
    instantiateFull' :: Builtin a -> ReduceM (Builtin a)
instantiateFull' (Builtin Term
t) = Term -> Builtin a
forall pf. Term -> Builtin pf
Builtin (Term -> Builtin a) -> ReduceM Term -> ReduceM (Builtin a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
t
    instantiateFull' (Prim a
x)   = a -> Builtin a
forall pf. pf -> Builtin pf
Prim (a -> Builtin a) -> ReduceM a -> ReduceM (Builtin a)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> a -> ReduceM a
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' a
x
    instantiateFull' b :: Builtin a
b@(BuiltinRewriteRelations Set QName
xs) = Builtin a -> ReduceM (Builtin a)
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Builtin a
b

instance InstantiateFull Candidate where
  instantiateFull' :: Candidate -> ReduceM Candidate
instantiateFull' (Candidate CandidateKind
q Term
u Type
t OverlapMode
ov) =
    CandidateKind -> Term -> Type -> OverlapMode -> Candidate
Candidate CandidateKind
q (Term -> Type -> OverlapMode -> Candidate)
-> ReduceM Term -> ReduceM (Type -> OverlapMode -> Candidate)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Term -> ReduceM Term
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Term
u ReduceM (Type -> OverlapMode -> Candidate)
-> ReduceM Type -> ReduceM (OverlapMode -> Candidate)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
t ReduceM (OverlapMode -> Candidate)
-> ReduceM OverlapMode -> ReduceM Candidate
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> OverlapMode -> ReduceM OverlapMode
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure OverlapMode
ov

instance InstantiateFull EqualityView where
  instantiateFull' :: EqualityView -> ReduceM EqualityView
instantiateFull' (OtherType Type
t)            = Type -> EqualityView
OtherType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
t
  instantiateFull' (IdiomType Type
t)            = Type -> EqualityView
IdiomType
    (Type -> EqualityView) -> ReduceM Type -> ReduceM EqualityView
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
t
  instantiateFull' (EqualityType Range
r Sort' Term
s QName
eq Args
l Arg Term
t Arg Term
a Arg Term
b) = Range
-> Sort' Term
-> QName
-> Args
-> Arg Term
-> Arg Term
-> Arg Term
-> EqualityView
EqualityType Range
r
    (Sort' Term
 -> QName
 -> Args
 -> Arg Term
 -> Arg Term
 -> Arg Term
 -> EqualityView)
-> ReduceM (Sort' Term)
-> ReduceM
     (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall (m :: * -> *) a b. Monad m => (a -> b) -> m a -> m b
<$!> Sort' Term -> ReduceM (Sort' Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Sort' Term
s
    ReduceM
  (QName -> Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM QName
-> ReduceM
     (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> QName -> ReduceM QName
forall a. a -> ReduceM a
forall (m :: * -> *) a. Monad m => a -> m a
return QName
eq
    ReduceM (Args -> Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM Args
-> ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> (Arg Term -> ReduceM (Arg Term)) -> Args -> ReduceM Args
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 -> ReduceM (Arg Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Args
l
    ReduceM (Arg Term -> Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term)
-> ReduceM (Arg Term -> Arg Term -> EqualityView)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Arg Term -> ReduceM (Arg Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Arg Term
t
    ReduceM (Arg Term -> Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM (Arg Term -> EqualityView)
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Arg Term -> ReduceM (Arg Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Arg Term
a
    ReduceM (Arg Term -> EqualityView)
-> ReduceM (Arg Term) -> ReduceM EqualityView
forall (m :: * -> *) a b. Monad m => m (a -> b) -> m a -> m b
<*!> Arg Term -> ReduceM (Arg Term)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Arg Term
b