{-# LANGUAGE NondecreasingIndentation #-}

{-| Coverage checking, case splitting, and splitting for refine tactics.

 -}

module Agda.TypeChecking.Coverage
  ( SplitClause(..), clauseToSplitClause, insertTrailingArgs
  , Covering(..), splitClauses
  , coverageCheck
  , isCovered
  , splitClauseWithAbsurd
  , splitLast
  , splitResult
  , normaliseProjP
  ) where

import Prelude hiding (null, (!!))  -- do not use partial functions like !!

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

import Data.Foldable (for_)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet

import Agda.Syntax.Common
import Agda.Syntax.Position
import Agda.Syntax.Internal hiding (DataOrRecord(..))
import Agda.Syntax.Internal.Pattern
import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..))

import Agda.TypeChecking.Names
import Agda.TypeChecking.Primitive hiding (Nat)
import Agda.TypeChecking.Monad

import Agda.TypeChecking.Rules.LHS (DataOrRecord(..), checkSortOfSplitVar)
import Agda.TypeChecking.Rules.LHS.Problem (allFlexVars)
import Agda.TypeChecking.Rules.LHS.Unify
import Agda.TypeChecking.Rules.Term (unquoteTactic)

import Agda.TypeChecking.Coverage.Match
import Agda.TypeChecking.Coverage.SplitTree

import Agda.TypeChecking.Conversion (tryConversion, equalType)
import Agda.TypeChecking.Datatypes (getConForm)
import {-# SOURCE #-} Agda.TypeChecking.Empty ( checkEmptyTel, isEmptyTel, isEmptyType )
import Agda.TypeChecking.Irrelevance
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Records
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Telescope.Path
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.Warnings

import Agda.Interaction.Options

import Agda.Utils.Either
import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Pretty (prettyShow)
import Agda.Utils.Singleton
import Agda.Utils.Size
import Agda.Utils.WithDefault

import Agda.Utils.Impossible

data SplitClause = SClause
  { SplitClause -> Telescope
scTel    :: Telescope
    -- ^ Type of variables in @scPats@.
  , SplitClause -> [NamedArg SplitPattern]
scPats   :: [NamedArg SplitPattern]
    -- ^ The patterns leading to the currently considered branch of
    --   the split tree.
  , SplitClause -> Substitution' SplitPattern
scSubst  :: Substitution' SplitPattern
    -- ^ Substitution from 'scTel' to old context.
    --   Only needed directly after split on variable:
    --   * To update 'scTarget'
    --   * To rename other split variables when splitting on
    --     multiple variables.
    --   @scSubst@ is not ``transitive'', i.e., does not record
    --   the substitution from the original context to 'scTel'
    --   over a series of splits.  It is freshly computed
    --   after each split by 'computeNeighborhood'; also
    --   'splitResult', which does not split on a variable,
    --   should reset it to the identity 'idS', lest it be
    --   applied to 'scTarget' again, leading to Issue 1294.
  , SplitClause -> Map CheckpointId Substitution
scCheckpoints :: Map CheckpointId Substitution
    -- ^ We need to keep track of the module parameter checkpoints for the
    -- clause for the purpose of inferring missing instance clauses.
  , SplitClause -> Maybe (Dom Type)
scTarget :: Maybe (Dom Type)
    -- ^ The type of the rhs, living in context 'scTel'.
    --   'fixTargetType' computes the new 'scTarget' by applying
    --   substitution 'scSubst'.
  }

-- | A @Covering@ is the result of splitting a 'SplitClause'.
data Covering = Covering
  { Covering -> Arg Nat
covSplitArg     :: Arg Nat
     -- ^ De Bruijn level (counting dot patterns) of argument we split on.
  , Covering -> [(SplitTag, SplitClause)]
covSplitClauses :: [(SplitTag, SplitClause)]
      -- ^ Covering clauses, indexed by constructor/literal these clauses share.
  }

-- | Project the split clauses out of a covering.
splitClauses :: Covering -> [SplitClause]
splitClauses :: Covering -> [SplitClause]
splitClauses (Covering Arg Nat
_ [(SplitTag, SplitClause)]
qcs) = ((SplitTag, SplitClause) -> SplitClause)
-> [(SplitTag, SplitClause)] -> [SplitClause]
forall a b. (a -> b) -> [a] -> [b]
map (SplitTag, SplitClause) -> SplitClause
forall a b. (a, b) -> b
snd [(SplitTag, SplitClause)]
qcs

-- | Create a split clause from a clause in internal syntax. Used by make-case.
clauseToSplitClause :: Clause -> SplitClause
clauseToSplitClause :: Clause -> SplitClause
clauseToSplitClause Clause
cl = SClause :: Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause
  { scTel :: Telescope
scTel    = Clause -> Telescope
clauseTel Clause
cl
  , scPats :: [NamedArg SplitPattern]
scPats   = [NamedArg DeBruijnPattern] -> [NamedArg SplitPattern]
toSplitPatterns ([NamedArg DeBruijnPattern] -> [NamedArg SplitPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> a -> b
$ Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
cl
  , scSubst :: Substitution' SplitPattern
scSubst  = Substitution' SplitPattern
forall a. Substitution' a
idS  -- Andreas, 2014-07-15  TODO: Is this ok?
  , scCheckpoints :: Map CheckpointId Substitution
scCheckpoints = Map CheckpointId Substitution
forall k a. Map k a
Map.empty -- #2996: not __IMPOSSIBLE__ for debug printing
  , scTarget :: Maybe (Dom Type)
scTarget = Arg Type -> Dom Type
forall a. Arg a -> Dom a
domFromArg (Arg Type -> Dom Type) -> Maybe (Arg Type) -> Maybe (Dom Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clause -> Maybe (Arg Type)
clauseType Clause
cl
  }

type CoverM = ExceptT SplitError TCM

-- | Top-level function for checking pattern coverage.
--
--   Effects:
--
--   - Marks unreachable clauses as such in the signature.
--
--   - Adds missing instances clauses to the signature.
--
coverageCheck
  :: QName     -- ^ Name @f@ of definition.
  -> Type      -- ^ Absolute type (including the full parameter telescope).
  -> [Clause]  -- ^ Clauses of @f@.  These are the very clauses of @f@ in the signature.
  -> TCM SplitTree
coverageCheck :: QName -> Type -> [Clause] -> TCM SplitTree
coverageCheck QName
f Type
t [Clause]
cs = do
  VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.top" Nat
30 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"entering coverageCheck for " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow QName
f
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.top" Nat
75 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"  of type (raw): " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (Type -> VerboseKey) -> Type -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow) Type
t
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.top" Nat
45 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"  of type: " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
t
  TelV Telescope
gamma Type
a <- Nat -> Type -> TCMT IO (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Nat -> Type -> m (TelV Type)
telViewUpTo (-Nat
1) Type
t
  VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.top" Nat
30 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"coverageCheck: computed telView"

  let -- n             = arity
      -- xs            = variable patterns fitting lgamma
      n :: Nat
n            = Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
gamma
      xs :: [NamedArg SplitPattern]
xs           =  (NamedArg SplitPattern -> NamedArg SplitPattern)
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> [a] -> [b]
map (Origin -> NamedArg SplitPattern -> NamedArg SplitPattern
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted) ([NamedArg SplitPattern] -> [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> a -> b
$ Telescope -> [NamedArg SplitPattern]
forall a. DeBruijn a => Telescope -> [NamedArg a]
teleNamedArgs Telescope
gamma

  VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.top" Nat
30 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"coverageCheck: getDefFreeVars"

      -- The initial module parameter substitutions need to be weakened by the
      -- number of arguments that aren't module parameters.
  Nat
fv           <- QName -> TCMT IO Nat
forall (m :: * -> *).
(Functor m, Applicative m, ReadTCState m, MonadTCEnv m) =>
QName -> m Nat
getDefFreeVars QName
f

  VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.top" Nat
30 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"coverageCheck: getting checkpoints"

  -- TODO: does this make sense? Why are we weakening by n - fv?
  Map CheckpointId Substitution
checkpoints <- Substitution' (SubstArg (Map CheckpointId Substitution))
-> Map CheckpointId Substitution -> Map CheckpointId Substitution
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst (Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS (Nat
n Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
fv)) (Map CheckpointId Substitution -> Map CheckpointId Substitution)
-> TCMT IO (Map CheckpointId Substitution)
-> TCMT IO (Map CheckpointId Substitution)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' (Map CheckpointId Substitution) TCEnv
-> TCMT IO (Map CheckpointId Substitution)
forall (m :: * -> *) a. MonadTCEnv m => Lens' a TCEnv -> m a
viewTC Lens' (Map CheckpointId Substitution) TCEnv
eCheckpoints

      -- construct the initial split clause
  let sc :: SplitClause
sc = Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause Telescope
gamma [NamedArg SplitPattern]
xs Substitution' SplitPattern
forall a. Substitution' a
idS Map CheckpointId Substitution
checkpoints (Maybe (Dom Type) -> SplitClause)
-> Maybe (Dom Type) -> SplitClause
forall a b. (a -> b) -> a -> b
$ Dom Type -> Maybe (Dom Type)
forall a. a -> Maybe a
Just (Dom Type -> Maybe (Dom Type)) -> Dom Type -> Maybe (Dom Type)
forall a b. (a -> b) -> a -> b
$ Type -> Dom Type
forall a. a -> Dom a
defaultDom Type
a

  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.top" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    let prCl :: Clause -> m Doc
prCl Clause
cl = Telescope -> m Doc -> m Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext (Clause -> Telescope
clauseTel Clause
cl) (m Doc -> m Doc) -> m Doc -> m Doc
forall a b. (a -> b) -> a -> b
$
                  [NamedArg DeBruijnPattern] -> m Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg DeBruijnPattern] -> m Doc)
-> [NamedArg DeBruijnPattern] -> m Doc
forall a b. (a -> b) -> a -> b
$ Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
cl
    [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"Coverage checking " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow QName
f VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseKey
" with patterns:"
      , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ (Clause -> TCM Doc) -> [Clause] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map Clause -> TCM Doc
forall (m :: * -> *).
(PureTCM m, MonadInteractionPoints m, MonadFresh NameId m,
 MonadStConcreteNames m, IsString (m Doc), Null (m Doc),
 Semigroup (m Doc)) =>
Clause -> m Doc
prCl [Clause]
cs
      ]

  -- used = actually used clauses for cover
  -- pss  = non-covered cases
  CoverResult SplitTree
splitTree IntSet
used [(Telescope, [NamedArg DeBruijnPattern])]
pss [Clause]
qss IntSet
noex <- QName -> [Clause] -> SplitClause -> TCM CoverResult
cover QName
f [Clause]
cs SplitClause
sc

  -- Andreas, 2018-11-12, issue #378:
  -- some indices in @used@ and @noex@ point outside of @cs@,
  -- since missing hcomp clauses have been added during the course of @cover@.
  -- We simply delete theses indices from @noex@.
  [Nat]
noex <- [Nat] -> TCMT IO [Nat]
forall (m :: * -> *) a. Monad m => a -> m a
return ([Nat] -> TCMT IO [Nat]) -> [Nat] -> TCMT IO [Nat]
forall a b. (a -> b) -> a -> b
$ (Nat -> Bool) -> [Nat] -> [Nat]
forall a. (a -> Bool) -> [a] -> [a]
List.filter (Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
< [Clause] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [Clause]
cs) ([Nat] -> [Nat]) -> [Nat] -> [Nat]
forall a b. (a -> b) -> a -> b
$ IntSet -> [Nat]
IntSet.toList IntSet
noex

  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.top" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCM Doc
"cover computed!"
    , VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"used clauses: " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ IntSet -> VerboseKey
forall a. Show a => a -> VerboseKey
show IntSet
used
    , VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"non-exact clauses: " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ [Nat] -> VerboseKey
forall a. Show a => a -> VerboseKey
show [Nat]
noex
    ]
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.splittree" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCM Doc
"generated split tree for" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
f
    , VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ SplitTree -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow SplitTree
splitTree
    ]
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.covering" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"covering patterns for " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow QName
f
    , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ (Clause -> TCM Doc) -> [Clause] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map (\ Clause
cl -> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext (Clause -> Telescope
clauseTel Clause
cl) (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg DeBruijnPattern] -> TCM Doc)
-> [NamedArg DeBruijnPattern] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
cl) [Clause]
qss
    ]

  -- Storing the covering clauses so that checkIApplyConfluence_ can
  -- find them later.
  -- Andreas, 2019-03-27, only needed when --cubical
  TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Maybe Cubical -> Bool
forall a. Maybe a -> Bool
isJust (Maybe Cubical -> Bool)
-> (PragmaOptions -> Maybe Cubical) -> PragmaOptions -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PragmaOptions -> Maybe Cubical
optCubical (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    (Signature -> Signature) -> TCMT IO ()
forall (m :: * -> *).
MonadTCState m =>
(Signature -> Signature) -> m ()
modifySignature ((Signature -> Signature) -> TCMT IO ())
-> (Signature -> Signature) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> (Definition -> Definition) -> Signature -> Signature
updateDefinition QName
f ((Definition -> Definition) -> Signature -> Signature)
-> (Definition -> Definition) -> Signature -> Signature
forall a b. (a -> b) -> a -> b
$ (Defn -> Defn) -> Definition -> Definition
updateTheDef ((Defn -> Defn) -> Definition -> Definition)
-> (Defn -> Defn) -> Definition -> Definition
forall a b. (a -> b) -> a -> b
$ ([Clause] -> [Clause]) -> Defn -> Defn
updateCovering (([Clause] -> [Clause]) -> Defn -> Defn)
-> ([Clause] -> [Clause]) -> Defn -> Defn
forall a b. (a -> b) -> a -> b
$ [Clause] -> [Clause] -> [Clause]
forall a b. a -> b -> a
const [Clause]
qss


  -- filter out the missing clauses that are absurd.
  [(Telescope, [NamedArg DeBruijnPattern])]
pss <- (((Telescope, [NamedArg DeBruijnPattern]) -> TCMT IO Bool)
 -> [(Telescope, [NamedArg DeBruijnPattern])]
 -> TCMT IO [(Telescope, [NamedArg DeBruijnPattern])])
-> [(Telescope, [NamedArg DeBruijnPattern])]
-> ((Telescope, [NamedArg DeBruijnPattern]) -> TCMT IO Bool)
-> TCMT IO [(Telescope, [NamedArg DeBruijnPattern])]
forall a b c. (a -> b -> c) -> b -> a -> c
flip ((Telescope, [NamedArg DeBruijnPattern]) -> TCMT IO Bool)
-> [(Telescope, [NamedArg DeBruijnPattern])]
-> TCMT IO [(Telescope, [NamedArg DeBruijnPattern])]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM [(Telescope, [NamedArg DeBruijnPattern])]
pss (((Telescope, [NamedArg DeBruijnPattern]) -> TCMT IO Bool)
 -> TCMT IO [(Telescope, [NamedArg DeBruijnPattern])])
-> ((Telescope, [NamedArg DeBruijnPattern]) -> TCMT IO Bool)
-> TCMT IO [(Telescope, [NamedArg DeBruijnPattern])]
forall a b. (a -> b) -> a -> b
$ \(Telescope
tel,[NamedArg DeBruijnPattern]
ps) ->
    -- Andreas, 2019-04-13, issue #3692: when adding missing absurd
    -- clauses, also put the absurd pattern in.
    TCMT IO (Either ErrorNonEmpty Nat)
-> (ErrorNonEmpty -> TCMT IO Bool)
-> (Nat -> TCMT IO Bool)
-> TCMT IO Bool
forall (m :: * -> *) a b c.
Monad m =>
m (Either a b) -> (a -> m c) -> (b -> m c) -> m c
caseEitherM (Range -> Telescope -> TCMT IO (Either ErrorNonEmpty Nat)
checkEmptyTel Range
forall a. Range' a
noRange Telescope
tel) (\ ErrorNonEmpty
_ -> Bool -> TCMT IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) ((Nat -> TCMT IO Bool) -> TCMT IO Bool)
-> (Nat -> TCMT IO Bool) -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ \ Nat
l -> do
      -- Now, @l@ is the first type in @tel@ (counting from 0=leftmost)
      -- which is empty.  Turn it into a de Bruijn index @i@.
      let i :: Nat
i = Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1 Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
l
      -- Build a substitution mapping this pattern variable to the absurd pattern.
      let sub :: Substitution' DeBruijnPattern
sub = Nat -> DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. EndoSubst a => Nat -> a -> Substitution' a
inplaceS Nat
i (DeBruijnPattern -> Substitution' DeBruijnPattern)
-> DeBruijnPattern -> Substitution' DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ Nat -> DeBruijnPattern
absurdP Nat
i
        -- ifNotM (isEmptyTel tel) (return True) $ do
      -- Jesper, 2018-11-28, Issue #3407: if the clause is absurd,
      -- add the appropriate absurd clause to the definition.
      let cl :: Clause
cl = Clause :: Range
-> Range
-> Telescope
-> [NamedArg DeBruijnPattern]
-> Maybe Term
-> Maybe (Arg Type)
-> Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> ExpandedEllipsis
-> Clause
Clause { clauseLHSRange :: Range
clauseLHSRange    = Range
forall a. Range' a
noRange
                      , clauseFullRange :: Range
clauseFullRange   = Range
forall a. Range' a
noRange
                      , clauseTel :: Telescope
clauseTel         = Telescope
tel
                      , namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats   = Substitution' (SubstArg [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' DeBruijnPattern
Substitution' (SubstArg [NamedArg DeBruijnPattern])
sub [NamedArg DeBruijnPattern]
ps
                      , clauseBody :: Maybe Term
clauseBody        = Maybe Term
forall a. Maybe a
Nothing
                      , clauseType :: Maybe (Arg Type)
clauseType        = Maybe (Arg Type)
forall a. Maybe a
Nothing
                      , clauseCatchall :: Bool
clauseCatchall    = Bool
True       -- absurd clauses are safe as catch-all
                      , clauseExact :: Maybe Bool
clauseExact       = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
                      , clauseRecursive :: Maybe Bool
clauseRecursive   = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
                      , clauseUnreachable :: Maybe Bool
clauseUnreachable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
                      , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis    = ExpandedEllipsis
NoEllipsis
                      }
      VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.missing" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ do
        [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCM Doc
"adding missing absurd clause"
            , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ QNamed Clause -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (QNamed Clause -> TCM Doc) -> QNamed Clause -> TCM Doc
forall a b. (a -> b) -> a -> b
$ QName -> Clause -> QNamed Clause
forall a. QName -> a -> QNamed a
QNamed QName
f Clause
cl
            ]
      VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.missing" Nat
80 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCM Doc
"l   = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Nat -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Nat
l
        , TCM Doc
"i   = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Nat -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Nat
i
        , TCM Doc
"cl  = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QNamed Clause -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (QName -> Clause -> QNamed Clause
forall a. QName -> a -> QNamed a
QNamed QName
f Clause
cl)
        ]
      QName -> [Clause] -> TCMT IO ()
addClauses QName
f [Clause
cl]
      Bool -> TCMT IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  -- report a warning if there are uncovered cases,
  Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([(Telescope, [NamedArg DeBruijnPattern])] -> Bool
forall a. Null a => a -> Bool
null [(Telescope, [NamedArg DeBruijnPattern])]
pss) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    Lens' (Set QName) TCState
stLocalPartialDefs Lens' (Set QName) TCState -> (Set QName -> Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' a TCState -> (a -> a) -> m ()
`modifyTCLens` QName -> Set QName -> Set QName
forall a. Ord a => a -> Set a -> Set a
Set.insert QName
f
    TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ((CoverageCheck
YesCoverageCheck CoverageCheck -> CoverageCheck -> Bool
forall a. Eq a => a -> a -> Bool
==) (CoverageCheck -> Bool) -> TCMT IO CoverageCheck -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' CoverageCheck TCEnv -> TCMT IO CoverageCheck
forall (m :: * -> *) a. MonadTCEnv m => Lens' a TCEnv -> m a
viewTC Lens' CoverageCheck TCEnv
eCoverageCheck) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
      [Clause] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Clause]
cs (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> [(Telescope, [NamedArg DeBruijnPattern])] -> Warning
CoverageIssue QName
f [(Telescope, [NamedArg DeBruijnPattern])]
pss

  -- Andreas, 2017-08-28, issue #2723:
  -- Mark clauses as reachable or unreachable in the signature.
  -- Andreas, 2020-11-19, issue #5065
  -- Remember whether clauses are exact or not.
  let ([Maybe Nat]
is0, [Clause]
cs1) = [(Maybe Nat, Clause)] -> ([Maybe Nat], [Clause])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(Maybe Nat, Clause)] -> ([Maybe Nat], [Clause]))
-> [(Maybe Nat, Clause)] -> ([Maybe Nat], [Clause])
forall a b. (a -> b) -> a -> b
$ [(Nat, Clause)]
-> ((Nat, Clause) -> (Maybe Nat, Clause)) -> [(Maybe Nat, Clause)]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for ([Nat] -> [Clause] -> [(Nat, Clause)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Nat
0..] [Clause]
cs) (((Nat, Clause) -> (Maybe Nat, Clause)) -> [(Maybe Nat, Clause)])
-> ((Nat, Clause) -> (Maybe Nat, Clause)) -> [(Maybe Nat, Clause)]
forall a b. (a -> b) -> a -> b
$ \ (Nat
i, Clause
cl) -> let
          unreachable :: Bool
unreachable = Nat
i Nat -> IntSet -> Bool
`IntSet.notMember` IntSet
used
          exact :: Bool
exact       = Nat
i Nat -> IntSet -> Bool
`IntSet.notMember` ([Nat] -> IntSet
IntSet.fromList [Nat]
noex)
        in (Bool -> Nat -> Maybe Nat
forall a. Bool -> a -> Maybe a
boolToMaybe Bool
unreachable Nat
i, Clause
cl
             { clauseUnreachable :: Maybe Bool
clauseUnreachable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
unreachable
             , clauseExact :: Maybe Bool
clauseExact       = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
exact
             })
  -- is = indices of unreachable clauses
  let is :: [Nat]
is = [Maybe Nat] -> [Nat]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Nat]
is0
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.top" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"unreachable clauses: " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ if [Nat] -> Bool
forall a. Null a => a -> Bool
null [Nat]
is then VerboseKey
"(none)" else [Nat] -> VerboseKey
forall a. Show a => a -> VerboseKey
show [Nat]
is
    ]
  -- Replace the first clauses by @cs1@.  There might be more
  -- added by @inferMissingClause@.
  QName -> ([Clause] -> [Clause]) -> TCMT IO ()
modifyFunClauses QName
f (([Clause] -> [Clause]) -> TCMT IO ())
-> ([Clause] -> [Clause]) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ [Clause]
cs0 -> [Clause]
cs1 [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++ Nat -> [Clause] -> [Clause]
forall a. Nat -> [a] -> [a]
drop ([Clause] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [Clause]
cs1) [Clause]
cs0

  -- Warn if there are unreachable clauses and mark them as unreachable.
  Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Nat] -> Bool
forall a. Null a => a -> Bool
null [Nat]
is) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    -- Warn about unreachable clauses.
    let unreached :: [Clause]
unreached = (Clause -> Bool) -> [Clause] -> [Clause]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True Maybe Bool -> Maybe Bool -> Bool
forall a. Eq a => a -> a -> Bool
==) (Maybe Bool -> Bool) -> (Clause -> Maybe Bool) -> Clause -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Clause -> Maybe Bool
clauseUnreachable) [Clause]
cs1
    let ranges :: [Range]
ranges    = (Clause -> Range) -> [Clause] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map Clause -> Range
clauseFullRange [Clause]
unreached
    [Range] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Range]
ranges (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> [Range] -> Warning
UnreachableClauses QName
f [Range]
ranges

  -- report a warning if there are clauses that are not preserved as
  -- definitional equalities and --exact-split is enabled
  Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Nat] -> Bool
forall a. Null a => a -> Bool
null [Nat]
noex) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
      let noexclauses :: [Clause]
noexclauses = (Nat -> Clause) -> [Nat] -> [Clause]
forall a b. (a -> b) -> [a] -> [b]
map (Clause -> [Clause] -> Nat -> Clause
forall a. a -> [a] -> Nat -> a
indexWithDefault Clause
forall a. HasCallStack => a
__IMPOSSIBLE__ [Clause]
cs1) [Nat]
noex
      [Range] -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange ((Clause -> Range) -> [Clause] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map Clause -> Range
clauseLHSRange [Clause]
noexclauses) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> Warning -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> [Clause] -> Warning
CoverageNoExactSplit QName
f ([Clause] -> Warning) -> [Clause] -> Warning
forall a b. (a -> b) -> a -> b
$ [Clause]
noexclauses
  SplitTree -> TCM SplitTree
forall (m :: * -> *) a. Monad m => a -> m a
return SplitTree
splitTree

-- | Top-level function for eliminating redundant clauses in the interactive
--   case splitter
isCovered :: QName -> [Clause] -> SplitClause -> TCM Bool
isCovered :: QName -> [Clause] -> SplitClause -> TCMT IO Bool
isCovered QName
f [Clause]
cs SplitClause
sc = do
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.isCovered" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCM Doc
"isCovered"
    , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
      [ TCM Doc
"f  = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
f
      , TCM Doc
"cs = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ((Clause -> TCM Doc) -> [Clause] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> (Clause -> TCM Doc) -> Clause -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedClause -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (NamedClause -> TCM Doc)
-> (Clause -> NamedClause) -> Clause -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool -> Clause -> NamedClause
NamedClause QName
f Bool
True) [Clause]
cs)
      , TCM Doc
"sc = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> SplitClause -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM SplitClause
sc
      ]
    ]
  -- Jesper, 2019-10: introduce trailing arguments (see #3828)
  (Telescope
_ , SplitClause
sc') <- Bool -> SplitClause -> TCM (Telescope, SplitClause)
insertTrailingArgs Bool
True SplitClause
sc
  CoverResult { coverMissingClauses :: CoverResult -> [(Telescope, [NamedArg DeBruijnPattern])]
coverMissingClauses = [(Telescope, [NamedArg DeBruijnPattern])]
missing } <- QName -> [Clause] -> SplitClause -> TCM CoverResult
cover QName
f [Clause]
cs SplitClause
sc'
  Bool -> TCMT IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool -> TCMT IO Bool) -> Bool -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ [(Telescope, [NamedArg DeBruijnPattern])] -> Bool
forall a. Null a => a -> Bool
null [(Telescope, [NamedArg DeBruijnPattern])]
missing
 -- Andreas, 2019-08-08 and 2020-02-11
 -- If there is an error (e.g. unification error), don't report it
 -- to the user.  Rather, assume the clause is not already covered.
 TCMT IO Bool -> (TCErr -> TCMT IO Bool) -> TCMT IO Bool
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ TCErr
_ -> Bool -> TCMT IO Bool
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

data CoverResult = CoverResult
  { CoverResult -> SplitTree
coverSplitTree       :: SplitTree
  , CoverResult -> IntSet
coverUsedClauses     :: IntSet -- Set Nat
  , CoverResult -> [(Telescope, [NamedArg DeBruijnPattern])]
coverMissingClauses  :: [(Telescope, [NamedArg DeBruijnPattern])]
  , CoverResult -> [Clause]
coverPatterns        :: [Clause]
  -- ^ The set of patterns used as cover.
  , CoverResult -> IntSet
coverNoExactClauses  :: IntSet -- Set Nat
  }

-- | @cover f cs (SClause _ _ ps _) = return (splitTree, used, pss)@.
--   checks that the list of clauses @cs@ covers the given split clause.
--   Returns the @splitTree@, the @used@ clauses, and missing cases @pss@.
--
--   Effect: adds missing instance clauses for @f@ to signature.
--
cover :: QName -> [Clause] -> SplitClause ->
         TCM CoverResult
cover :: QName -> [Clause] -> SplitClause -> TCM CoverResult
cover QName
f [Clause]
cs sc :: SplitClause
sc@(SClause Telescope
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId Substitution
_ Maybe (Dom Type)
target) = TCM CoverResult -> TCM CoverResult
forall a. TCM a -> TCM a
updateRelevance (TCM CoverResult -> TCM CoverResult)
-> TCM CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ do
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.cover" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCM Doc
"checking coverage of pattern:"
    , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ SplitClause -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM SplitClause
sc
    , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"target sort =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc -> (Dom Type -> TCM Doc) -> Maybe (Dom Type) -> TCM Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"<none>") (Sort -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Sort -> TCM Doc) -> (Dom Type -> Sort) -> Dom Type -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Sort
forall a. LensSort a => a -> Sort
getSort (Type -> Sort) -> (Dom Type -> Type) -> Dom Type -> Sort
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Type
forall t e. Dom' t e -> e
unDom) Maybe (Dom Type)
target
    ]
  VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.cover" Nat
80 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"raw target =\n" VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Maybe (Dom Type) -> VerboseKey
forall a. Show a => a -> VerboseKey
show Maybe (Dom Type)
target
  [Clause]
-> [NamedArg SplitPattern]
-> TCMT IO (Match (Nat, SplitInstantiation))
forall (m :: * -> *).
PureTCM m =>
[Clause]
-> [NamedArg SplitPattern] -> m (Match (Nat, SplitInstantiation))
match [Clause]
cs [NamedArg SplitPattern]
ps TCMT IO (Match (Nat, SplitInstantiation))
-> (Match (Nat, SplitInstantiation) -> TCM CoverResult)
-> TCM CoverResult
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Yes (Nat
i,SplitInstantiation
mps) -> do
      VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.cover" Nat
10 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"pattern covered by clause " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Nat -> VerboseKey
forall a. Show a => a -> VerboseKey
show Nat
i
      VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.cover" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"with mps = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ SplitInstantiation -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty SplitInstantiation
mps
      Bool
exact <- SplitInstantiation
-> ((Nat, SplitPattern) -> TCMT IO Bool) -> TCMT IO Bool
forall (f :: * -> *) (m :: * -> *) a.
(Functor f, Foldable f, Monad m) =>
f a -> (a -> m Bool) -> m Bool
allM SplitInstantiation
mps (((Nat, SplitPattern) -> TCMT IO Bool) -> TCMT IO Bool)
-> ((Nat, SplitPattern) -> TCMT IO Bool) -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ SplitPattern -> TCMT IO Bool
forall (m :: * -> *) a. HasConstInfo m => Pattern' a -> m Bool
isTrivialPattern (SplitPattern -> TCMT IO Bool)
-> ((Nat, SplitPattern) -> SplitPattern)
-> (Nat, SplitPattern)
-> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Nat, SplitPattern) -> SplitPattern
forall a b. (a, b) -> b
snd
      let cl0 :: Clause
cl0 = Clause -> [Clause] -> Nat -> Clause
forall a. a -> [a] -> Nat -> a
indexWithDefault Clause
forall a. HasCallStack => a
__IMPOSSIBLE__ [Clause]
cs Nat
i
      Clause
cl <- SplitClause -> Clause -> SplitInstantiation -> TCM Clause
applyCl SplitClause
sc Clause
cl0 SplitInstantiation
mps
      CoverResult -> TCM CoverResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverResult -> TCM CoverResult) -> CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ CoverResult :: SplitTree
-> IntSet
-> [(Telescope, [NamedArg DeBruijnPattern])]
-> [Clause]
-> IntSet
-> CoverResult
CoverResult
        { coverSplitTree :: SplitTree
coverSplitTree      = Nat -> SplitTree
forall a. Nat -> SplitTree' a
SplittingDone (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel)
        , coverUsedClauses :: IntSet
coverUsedClauses    = Nat -> IntSet
forall el coll. Singleton el coll => el -> coll
singleton Nat
i
        , coverMissingClauses :: [(Telescope, [NamedArg DeBruijnPattern])]
coverMissingClauses = []
        , coverPatterns :: [Clause]
coverPatterns       = [Clause
cl]
        , coverNoExactClauses :: IntSet
coverNoExactClauses = [Nat] -> IntSet
IntSet.fromList [ Nat
i | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ Bool
exact Bool -> Bool -> Bool
|| Clause -> Bool
clauseCatchall Clause
cl0 ]
        }

    Match (Nat, SplitInstantiation)
No        ->  do
      VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover" Nat
20 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"pattern is not covered"
      let infer :: Dom' a e -> Bool
infer Dom' a e
dom = Dom' a e -> Bool
forall a. LensHiding a => a -> Bool
isInstance Dom' a e
dom Bool -> Bool -> Bool
|| Maybe a -> Bool
forall a. Maybe a -> Bool
isJust (Dom' a e -> Maybe a
forall t e. Dom' t e -> Maybe t
domTactic Dom' a e
dom)
      if Bool -> (Dom Type -> Bool) -> Maybe (Dom Type) -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False Dom Type -> Bool
forall a e. Dom' a e -> Bool
infer Maybe (Dom Type)
target
        then do
          -- Ulf, 2016-10-31: For now we only infer instance clauses. It would
          -- make sense to do it also for hidden, but since the value of a
          -- hidden clause is expected to be forced by later clauses, it's too
          -- late to add it now. If it was inferrable we would have gotten a
          -- type error before getting to this point.
          -- Ulf, 2019-11-21: Also @tactic clauses.
          Clause
cl <- QName -> SplitClause -> TCM Clause
inferMissingClause QName
f SplitClause
sc
          CoverResult -> TCM CoverResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverResult -> TCM CoverResult) -> CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ SplitTree
-> IntSet
-> [(Telescope, [NamedArg DeBruijnPattern])]
-> [Clause]
-> IntSet
-> CoverResult
CoverResult (Nat -> SplitTree
forall a. Nat -> SplitTree' a
SplittingDone (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel)) IntSet
forall a. Null a => a
empty [] [Clause
cl] IntSet
forall a. Null a => a
empty
        else do
          let ps' :: [NamedArg DeBruijnPattern]
ps' = [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps
          CoverResult -> TCM CoverResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverResult -> TCM CoverResult) -> CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ SplitTree
-> IntSet
-> [(Telescope, [NamedArg DeBruijnPattern])]
-> [Clause]
-> IntSet
-> CoverResult
CoverResult (Nat -> SplitTree
forall a. Nat -> SplitTree' a
SplittingDone (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel)) IntSet
forall a. Null a => a
empty [(Telescope
tel, [NamedArg DeBruijnPattern]
ps')] [] IntSet
forall a. Null a => a
empty

    -- We need to split!
    -- If all clauses have an unsplit copattern, we try that first.
    Block BlockedOnResult
res BlockingVars
bs -> BlockedOnResult
-> Bool
-> (SplitError -> TCM CoverResult)
-> TCM CoverResult
-> TCM CoverResult
trySplitRes BlockedOnResult
res (BlockingVars -> Bool
forall a. Null a => a -> Bool
null BlockingVars
bs) SplitError -> TCM CoverResult
forall a. SplitError -> TCM a
splitError (TCM CoverResult -> TCM CoverResult)
-> TCM CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ do
      Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (BlockingVars -> Bool
forall a. Null a => a -> Bool
null BlockingVars
bs) TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      -- Otherwise, if there are variables to split, we try them
      -- in the order determined by a split strategy.
      VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.strategy" Nat
20 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"blocking vars = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ BlockingVars -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow BlockingVars
bs
      -- xs is a non-empty lists of blocking variables
      -- try splitting on one of them
      BlockingVars
xs <- BlockingVars -> Telescope -> TCM BlockingVars
splitStrategy BlockingVars
bs Telescope
tel
      -- Andreas, 2017-10-08, issue #2594
      -- First, try to find split order for complete coverage.
      -- If this fails, try to at least carry out the splitting to the end.
      BlockingVars
-> AllowPartialCover
-> (SplitError -> TCM CoverResult)
-> TCM CoverResult
continue BlockingVars
xs AllowPartialCover
NoAllowPartialCover ((SplitError -> TCM CoverResult) -> TCM CoverResult)
-> (SplitError -> TCM CoverResult) -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ \ SplitError
_err -> do
        BlockingVars
-> AllowPartialCover
-> (SplitError -> TCM CoverResult)
-> TCM CoverResult
continue BlockingVars
xs AllowPartialCover
YesAllowPartialCover ((SplitError -> TCM CoverResult) -> TCM CoverResult)
-> (SplitError -> TCM CoverResult) -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ \ SplitError
err -> do
          SplitError -> TCM CoverResult
forall a. SplitError -> TCM a
splitError SplitError
err
  where
    -- Andreas, 2019-08-07, issue #3966
    -- When we get a SplitError, tighten the error Range to the clauses
    -- that are still candidates for covering the SplitClause.
    splitError :: SplitError -> TCM a
    splitError :: SplitError -> TCM a
splitError = TCM a -> TCM a
forall a. TCM a -> TCM a
withRangeOfCandidateClauses (TCM a -> TCM a) -> (SplitError -> TCM a) -> SplitError -> TCM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeError -> TCM a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM a)
-> (SplitError -> TypeError) -> SplitError -> TCM a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SplitError -> TypeError
SplitError

    -- This repeats the matching, but since we are crashing anyway,
    -- the extra work just to compute a better Range does not matter.
    withRangeOfCandidateClauses :: TCM a -> TCM a
    withRangeOfCandidateClauses :: TCM a -> TCM a
withRangeOfCandidateClauses TCM a
cont = do
      [Clause]
cands <- ((Clause, Match SplitInstantiation) -> Maybe Clause)
-> [(Clause, Match SplitInstantiation)] -> [Clause]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Clause -> Match SplitInstantiation -> Maybe Clause)
-> (Clause, Match SplitInstantiation) -> Maybe Clause
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Clause -> Match SplitInstantiation -> Maybe Clause
forall a. Clause -> Match a -> Maybe Clause
notNo) ([(Clause, Match SplitInstantiation)] -> [Clause])
-> ([Match SplitInstantiation]
    -> [(Clause, Match SplitInstantiation)])
-> [Match SplitInstantiation]
-> [Clause]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Clause]
-> [Match SplitInstantiation]
-> [(Clause, Match SplitInstantiation)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Clause]
cs ([Match SplitInstantiation] -> [Clause])
-> TCMT IO [Match SplitInstantiation] -> TCMT IO [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Clause -> TCMT IO (Match SplitInstantiation))
-> [Clause] -> TCMT IO [Match SplitInstantiation]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ([NamedArg SplitPattern]
-> Clause -> TCMT IO (Match SplitInstantiation)
forall (m :: * -> *).
PureTCM m =>
[NamedArg SplitPattern] -> Clause -> m (Match SplitInstantiation)
matchClause [NamedArg SplitPattern]
ps) [Clause]
cs
      [Clause] -> TCM a -> TCM a
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange [Clause]
cands TCM a
cont
      where
        notNo :: Clause -> Match a -> Maybe Clause
        notNo :: Clause -> Match a -> Maybe Clause
notNo Clause
c = \case
          Yes{}   -> Clause -> Maybe Clause
forall a. a -> Maybe a
Just Clause
c
          Block{} -> Clause -> Maybe Clause
forall a. a -> Maybe a
Just Clause
c
          No{}    -> Maybe Clause
forall a. Maybe a
Nothing

    applyCl :: SplitClause -> Clause -> [(Nat, SplitPattern)] -> TCM Clause
    applyCl :: SplitClause -> Clause -> SplitInstantiation -> TCM Clause
applyCl SClause{scTel :: SplitClause -> Telescope
scTel = Telescope
tel, scPats :: SplitClause -> [NamedArg SplitPattern]
scPats = [NamedArg SplitPattern]
sps} Clause
cl SplitInstantiation
mps = Telescope -> TCM Clause -> TCM Clause
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Clause -> TCM Clause) -> TCM Clause -> TCM Clause
forall a b. (a -> b) -> a -> b
$ do
        let ps :: [NamedArg DeBruijnPattern]
ps = Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
cl
        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.applyCl" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"applyCl"
        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.applyCl" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"tel    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.applyCl" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"ps     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
ps
        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.applyCl" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"mps    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> SplitInstantiation -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty SplitInstantiation
mps
        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.applyCl" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"s      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' DeBruijnPattern -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Substitution' DeBruijnPattern
s
        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.applyCl" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"ps[s]  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Substitution' DeBruijnPattern
Substitution' (SubstArg [NamedArg DeBruijnPattern])
s Substitution' (SubstArg [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` [NamedArg DeBruijnPattern]
ps)

        -- If a matching clause has fewer patterns than the split
        -- clause we ought to copy over the extra ones.
        -- e.g. if the user wrote:
        --
        --   bar : Bool -> Bool
        --   bar false = false
        --   bar = \ _ -> true
        --
        -- then for the second clause the @extra@ patterns will be @[true]@.

        let extra :: [NamedArg DeBruijnPattern]
extra = Nat -> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Nat -> [a] -> [a]
drop ([NamedArg DeBruijnPattern] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [NamedArg DeBruijnPattern]
ps) ([NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
sps
            n_extra :: Nat
n_extra = [NamedArg DeBruijnPattern] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [NamedArg DeBruijnPattern]
extra

        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.applyCl" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"extra  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
extra

        -- When we add the extra patterns we also update the type
        -- and the body of the clause.

        Maybe (Arg (TelV Type))
mtv <- ((Arg Type -> TCMT IO (Arg (TelV Type)))
-> Maybe (Arg Type) -> TCMT IO (Maybe (Arg (TelV Type)))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Arg Type -> TCMT IO (Arg (TelV Type)))
 -> Maybe (Arg Type) -> TCMT IO (Maybe (Arg (TelV Type))))
-> ((Type -> TCMT IO (TelV Type))
    -> Arg Type -> TCMT IO (Arg (TelV Type)))
-> (Type -> TCMT IO (TelV Type))
-> Maybe (Arg Type)
-> TCMT IO (Maybe (Arg (TelV Type)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Type -> TCMT IO (TelV Type))
-> Arg Type -> TCMT IO (Arg (TelV Type))
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse) (Nat -> Type -> TCMT IO (TelV Type)
forall (m :: * -> *). PureTCM m => Nat -> Type -> m (TelV Type)
telViewUpToPath Nat
n_extra) (Maybe (Arg Type) -> TCMT IO (Maybe (Arg (TelV Type))))
-> Maybe (Arg Type) -> TCMT IO (Maybe (Arg (TelV Type)))
forall a b. (a -> b) -> a -> b
$ Clause -> Maybe (Arg Type)
clauseType Clause
cl
        let ty :: Maybe (Arg Type)
ty = ((Arg (TelV Type) -> Arg Type)
-> Maybe (Arg (TelV Type)) -> Maybe (Arg Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Arg (TelV Type) -> Arg Type)
 -> Maybe (Arg (TelV Type)) -> Maybe (Arg Type))
-> ((TelV Type -> Type) -> Arg (TelV Type) -> Arg Type)
-> (TelV Type -> Type)
-> Maybe (Arg (TelV Type))
-> Maybe (Arg Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (TelV Type -> Type) -> Arg (TelV Type) -> Arg Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) (([DeBruijnPattern] -> Substitution' DeBruijnPattern
forall a. DeBruijn a => [a] -> Substitution' a
parallelS ([DeBruijnPattern] -> [DeBruijnPattern]
forall a. [a] -> [a]
reverse ([DeBruijnPattern] -> [DeBruijnPattern])
-> [DeBruijnPattern] -> [DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ (NamedArg DeBruijnPattern -> DeBruijnPattern)
-> [NamedArg DeBruijnPattern] -> [DeBruijnPattern]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg DeBruijnPattern -> DeBruijnPattern
forall a. NamedArg a -> a
namedArg [NamedArg DeBruijnPattern]
extra) Substitution' DeBruijnPattern
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Nat
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
n_extra Substitution' DeBruijnPattern
s Substitution' DeBruijnPattern -> Type -> Type
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
`applyPatSubst`) (Type -> Type) -> (TelV Type -> Type) -> TelV Type -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TelV Type -> Type
forall a. TelV a -> a
theCore) Maybe (Arg (TelV Type))
mtv

        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.applyCl" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"new ty =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Maybe (Arg Type) -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Maybe (Arg Type)
ty

        Clause -> TCM Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> TCM Clause) -> Clause -> TCM Clause
forall a b. (a -> b) -> a -> b
$
             Clause :: Range
-> Range
-> Telescope
-> [NamedArg DeBruijnPattern]
-> Maybe Term
-> Maybe (Arg Type)
-> Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> ExpandedEllipsis
-> Clause
Clause { clauseLHSRange :: Range
clauseLHSRange  = Clause -> Range
clauseLHSRange Clause
cl
                    , clauseFullRange :: Range
clauseFullRange = Clause -> Range
clauseFullRange Clause
cl
                    , clauseTel :: Telescope
clauseTel       = Telescope
tel
                    , namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = (Substitution' DeBruijnPattern
Substitution' (SubstArg [NamedArg DeBruijnPattern])
s Substitution' (SubstArg [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` [NamedArg DeBruijnPattern]
ps) [NamedArg DeBruijnPattern]
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern]
extra
                    , clauseBody :: Maybe Term
clauseBody      = (Term -> Elims -> Term
forall t. Apply t => t -> Elims -> t
`applyE` [NamedArg DeBruijnPattern] -> Elims
patternsToElims [NamedArg DeBruijnPattern]
extra) (Term -> Term) -> (Term -> Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Substitution' DeBruijnPattern
s Substitution' DeBruijnPattern -> Term -> Term
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
`applyPatSubst`) (Term -> Term) -> Maybe Term -> Maybe Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Clause -> Maybe Term
clauseBody Clause
cl
                    , clauseType :: Maybe (Arg Type)
clauseType      = Maybe (Arg Type)
ty
                    , clauseCatchall :: Bool
clauseCatchall  = Clause -> Bool
clauseCatchall Clause
cl
                    , clauseExact :: Maybe Bool
clauseExact     = Clause -> Maybe Bool
clauseExact Clause
cl
                    , clauseRecursive :: Maybe Bool
clauseRecursive = Clause -> Maybe Bool
clauseRecursive Clause
cl
                    , clauseUnreachable :: Maybe Bool
clauseUnreachable = Clause -> Maybe Bool
clauseUnreachable Clause
cl
                    , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis  = Clause -> ExpandedEllipsis
clauseEllipsis Clause
cl
                    }
      where
        ([Nat]
vs,[SplitPattern]
qs) = SplitInstantiation -> ([Nat], [SplitPattern])
forall a b. [(a, b)] -> ([a], [b])
unzip SplitInstantiation
mps
        mps' :: [(Nat, DeBruijnPattern)]
mps' = [Nat] -> [DeBruijnPattern] -> [(Nat, DeBruijnPattern)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Nat]
vs ([DeBruijnPattern] -> [(Nat, DeBruijnPattern)])
-> [DeBruijnPattern] -> [(Nat, DeBruijnPattern)]
forall a b. (a -> b) -> a -> b
$ (NamedArg DeBruijnPattern -> DeBruijnPattern)
-> [NamedArg DeBruijnPattern] -> [DeBruijnPattern]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg DeBruijnPattern -> DeBruijnPattern
forall a. NamedArg a -> a
namedArg ([NamedArg DeBruijnPattern] -> [DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ (SplitPattern -> NamedArg SplitPattern)
-> [SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> [a] -> [b]
map SplitPattern -> NamedArg SplitPattern
forall a. a -> NamedArg a
defaultNamedArg [SplitPattern]
qs
        s :: Substitution' DeBruijnPattern
s = [DeBruijnPattern] -> Substitution' DeBruijnPattern
forall a. DeBruijn a => [a] -> Substitution' a
parallelS ([Nat] -> (Nat -> DeBruijnPattern) -> [DeBruijnPattern]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [Nat
0..[Nat] -> Nat
forall (t :: * -> *) a. (Foldable t, Ord a) => t a -> a
maximum (-Nat
1Nat -> [Nat] -> [Nat]
forall a. a -> [a] -> [a]
:[Nat]
vs)] ((Nat -> DeBruijnPattern) -> [DeBruijnPattern])
-> (Nat -> DeBruijnPattern) -> [DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ (\ Nat
i -> DeBruijnPattern -> Maybe DeBruijnPattern -> DeBruijnPattern
forall a. a -> Maybe a -> a
fromMaybe (Nat -> DeBruijnPattern
forall a. DeBruijn a => Nat -> a
deBruijnVar Nat
i) (Nat -> [(Nat, DeBruijnPattern)] -> Maybe DeBruijnPattern
forall a b. Eq a => a -> [(a, b)] -> Maybe b
List.lookup Nat
i [(Nat, DeBruijnPattern)]
mps')))

    updateRelevance :: TCM a -> TCM a
    updateRelevance :: TCM a -> TCM a
updateRelevance TCM a
cont =
      -- Don't do anything if there is no target type info.
      Maybe (Dom Type) -> TCM a -> (Dom Type -> TCM a) -> TCM a
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Dom Type)
target TCM a
cont ((Dom Type -> TCM a) -> TCM a) -> (Dom Type -> TCM a) -> TCM a
forall a b. (a -> b) -> a -> b
$ \ Dom Type
b -> do
        -- TODO (2018-10-16): if proofs get erased in the compiler, also wake erased vars!
        let m :: Modality
m = Dom Type -> Modality
forall a. LensModality a => a -> Modality
getModality Dom Type
b
        Modality -> TCM a -> TCM a
forall (tcm :: * -> *) m a.
(MonadTCEnv tcm, LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext Modality
m TCM a
cont

    continue
      :: [BlockingVar]
      -> AllowPartialCover
      -> (SplitError -> TCM CoverResult)
      -> TCM CoverResult
    continue :: BlockingVars
-> AllowPartialCover
-> (SplitError -> TCM CoverResult)
-> TCM CoverResult
continue BlockingVars
xs AllowPartialCover
allowPartialCover SplitError -> TCM CoverResult
handle = do
      Either SplitError (Covering, BlockingVar)
r <- (BlockingVar
 -> TCMT IO (Either SplitError (Covering, BlockingVar)))
-> BlockingVars
-> TCMT IO (Either SplitError (Covering, BlockingVar))
forall (m :: * -> *) a err b.
Monad m =>
(a -> m (Either err b)) -> [a] -> m (Either err b)
altM1 (\ BlockingVar
x -> (Covering -> (Covering, BlockingVar))
-> Either SplitError Covering
-> Either SplitError (Covering, BlockingVar)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,BlockingVar
x) (Either SplitError Covering
 -> Either SplitError (Covering, BlockingVar))
-> TCMT IO (Either SplitError Covering)
-> TCMT IO (Either SplitError (Covering, BlockingVar))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Induction
-> AllowPartialCover
-> SplitClause
-> BlockingVar
-> TCMT IO (Either SplitError Covering)
split Induction
Inductive AllowPartialCover
allowPartialCover SplitClause
sc BlockingVar
x) BlockingVars
xs
      case Either SplitError (Covering, BlockingVar)
r of
        Left SplitError
err -> SplitError -> TCM CoverResult
handle SplitError
err
        -- If we get the empty covering, we have reached an impossible case
        -- and are done.
        Right (Covering Arg Nat
n [], BlockingVar
_) ->
         do
          -- TODO Andrea: I guess an empty pattern is not part of the cover?
          let qs :: [a]
qs = []
          CoverResult -> TCM CoverResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverResult -> TCM CoverResult) -> CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ SplitTree
-> IntSet
-> [(Telescope, [NamedArg DeBruijnPattern])]
-> [Clause]
-> IntSet
-> CoverResult
CoverResult (Nat -> SplitTree
forall a. Nat -> SplitTree' a
SplittingDone (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel)) IntSet
forall a. Null a => a
empty [] [Clause]
forall a. [a]
qs IntSet
forall a. Null a => a
empty
        Right (Covering Arg Nat
n [(SplitTag, SplitClause)]
scs, BlockingVar
x) -> do
          [Clause]
cs <- do
            let fallback :: TCMT IO [Clause]
fallback = [Clause] -> TCMT IO [Clause]
forall (m :: * -> *) a. Monad m => a -> m a
return [Clause]
cs
            TCMT IO (Maybe QName)
-> TCMT IO [Clause]
-> (QName -> TCMT IO [Clause])
-> TCMT IO [Clause]
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (VerboseKey -> TCMT IO (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
VerboseKey -> m (Maybe QName)
getPrimitiveName' VerboseKey
builtinHComp) TCMT IO [Clause]
fallback ((QName -> TCMT IO [Clause]) -> TCMT IO [Clause])
-> (QName -> TCMT IO [Clause]) -> TCMT IO [Clause]
forall a b. (a -> b) -> a -> b
$ \ QName
comp -> do
            let isComp :: SplitTag -> Bool
isComp = \case
                  SplitCon QName
c -> QName
comp QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
c
                  SplitTag
_ -> Bool
False
            Maybe (SplitTag, SplitClause)
-> TCMT IO [Clause]
-> ((SplitTag, SplitClause) -> TCMT IO [Clause])
-> TCMT IO [Clause]
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (((SplitTag, SplitClause) -> Bool)
-> [(SplitTag, SplitClause)] -> Maybe (SplitTag, SplitClause)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find (SplitTag -> Bool
isComp (SplitTag -> Bool)
-> ((SplitTag, SplitClause) -> SplitTag)
-> (SplitTag, SplitClause)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SplitTag, SplitClause) -> SplitTag
forall a b. (a, b) -> a
fst) [(SplitTag, SplitClause)]
scs) TCMT IO [Clause]
fallback (((SplitTag, SplitClause) -> TCMT IO [Clause]) -> TCMT IO [Clause])
-> ((SplitTag, SplitClause) -> TCMT IO [Clause])
-> TCMT IO [Clause]
forall a b. (a -> b) -> a -> b
$ \ (SplitTag
_, SplitClause
newSc) -> do
            [Clause] -> Clause -> [Clause]
forall a. [a] -> a -> [a]
snoc [Clause]
cs (Clause -> [Clause]) -> TCM Clause -> TCMT IO [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName
-> Arg Nat
-> BlockingVar
-> SplitClause
-> SplitClause
-> TCM Clause
createMissingHCompClause QName
f Arg Nat
n BlockingVar
x SplitClause
sc SplitClause
newSc
          [CoverResult]
results <- ((SplitTag, SplitClause) -> TCM CoverResult)
-> [(SplitTag, SplitClause)] -> TCMT IO [CoverResult]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((QName -> [Clause] -> SplitClause -> TCM CoverResult
cover QName
f [Clause]
cs) (SplitClause -> TCM CoverResult)
-> ((SplitTag, SplitClause) -> SplitClause)
-> (SplitTag, SplitClause)
-> TCM CoverResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SplitTag, SplitClause) -> SplitClause
forall a b. (a, b) -> b
snd) [(SplitTag, SplitClause)]
scs
          let trees :: [SplitTree]
trees = (CoverResult -> SplitTree) -> [CoverResult] -> [SplitTree]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> SplitTree
coverSplitTree      [CoverResult]
results
              useds :: [IntSet]
useds = (CoverResult -> IntSet) -> [CoverResult] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> IntSet
coverUsedClauses    [CoverResult]
results
              psss :: [[(Telescope, [NamedArg DeBruijnPattern])]]
psss  = (CoverResult -> [(Telescope, [NamedArg DeBruijnPattern])])
-> [CoverResult] -> [[(Telescope, [NamedArg DeBruijnPattern])]]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> [(Telescope, [NamedArg DeBruijnPattern])]
coverMissingClauses [CoverResult]
results
              qsss :: [[Clause]]
qsss  = (CoverResult -> [Clause]) -> [CoverResult] -> [[Clause]]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> [Clause]
coverPatterns       [CoverResult]
results
              noex :: [IntSet]
noex  = (CoverResult -> IntSet) -> [CoverResult] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> IntSet
coverNoExactClauses [CoverResult]
results
          -- Jesper, 2016-03-10  We need to remember which variables were
          -- eta-expanded by the unifier in order to generate a correct split
          -- tree (see Issue 1872).
          VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.split.eta" Nat
60 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
            [ TCM Doc
"etaRecordSplits"
            , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
              [ TCM Doc
"n   = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (Arg Nat -> VerboseKey
forall a. Show a => a -> VerboseKey
show Arg Nat
n)
              , TCM Doc
"scs = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [(SplitTag, SplitClause)] -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [(SplitTag, SplitClause)]
scs
              , TCM Doc
"ps  = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps)
              ]
            ]
          -- TODO Andrea: do something with etaRecordSplits and qsss?
          let trees' :: [(SplitTag, SplitTree)]
trees' = ((SplitTag, SplitClause) -> SplitTree -> (SplitTag, SplitTree))
-> [(SplitTag, SplitClause)]
-> [SplitTree]
-> [(SplitTag, SplitTree)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith (Nat
-> [NamedArg SplitPattern]
-> (SplitTag, SplitClause)
-> SplitTree
-> (SplitTag, SplitTree)
etaRecordSplits (Arg Nat -> Nat
forall e. Arg e -> e
unArg Arg Nat
n) [NamedArg SplitPattern]
ps) [(SplitTag, SplitClause)]
scs [SplitTree]
trees
              tree :: SplitTree
tree   = Arg Nat -> LazySplit -> [(SplitTag, SplitTree)] -> SplitTree
forall a. Arg Nat -> LazySplit -> SplitTrees' a -> SplitTree' a
SplitAt Arg Nat
n LazySplit
StrictSplit [(SplitTag, SplitTree)]
trees'   -- TODO: Lazy?
          CoverResult -> TCM CoverResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverResult -> TCM CoverResult) -> CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ SplitTree
-> IntSet
-> [(Telescope, [NamedArg DeBruijnPattern])]
-> [Clause]
-> IntSet
-> CoverResult
CoverResult SplitTree
tree ([IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions [IntSet]
useds) ([[(Telescope, [NamedArg DeBruijnPattern])]]
-> [(Telescope, [NamedArg DeBruijnPattern])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Telescope, [NamedArg DeBruijnPattern])]]
psss) ([[Clause]] -> [Clause]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Clause]]
qsss) ([IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions [IntSet]
noex)

    -- Try to split result
    trySplitRes
      :: BlockedOnResult                  -- Are we blocked on the result?
      -> Bool                             -- Is this the last thing we try?
      -> (SplitError -> TCM CoverResult)  -- Handler for 'SplitError'
      -> TCM CoverResult                  -- Continuation
      -> TCM CoverResult
    -- not blocked on result: try regular splits
    trySplitRes :: BlockedOnResult
-> Bool
-> (SplitError -> TCM CoverResult)
-> TCM CoverResult
-> TCM CoverResult
trySplitRes BlockedOnResult
NotBlockedOnResult Bool
finalSplit SplitError -> TCM CoverResult
splitError TCM CoverResult
cont
      | Bool
finalSplit = TCM CoverResult
forall a. HasCallStack => a
__IMPOSSIBLE__ -- there must be *some* reason we are blocked
      | Bool
otherwise  = TCM CoverResult
cont
    -- blocked on arguments that are not yet introduced:

    -- we must split on a variable so that the target type becomes a pi type
    trySplitRes (BlockedOnApply ApplyOrIApply
IsApply) Bool
finalSplit SplitError -> TCM CoverResult
splitError TCM CoverResult
cont = do
      -- Andreas, 2021-12-31, issue #5712.
      -- If there is a tactic to solve the clause, we might not have inserted
      -- trailing args (due to #5358).  Now we force it!
      (Telescope
tel, SplitClause
sc') <- Bool -> SplitClause -> TCM (Telescope, SplitClause)
insertTrailingArgs Bool
True SplitClause
sc
      if Telescope -> Bool
forall a. Null a => a -> Bool
null Telescope
tel then
        if Bool
finalSplit then TCM CoverResult
forall a. HasCallStack => a
__IMPOSSIBLE__ -- already ruled out by lhs checker
        else TCM CoverResult
cont
      else QName -> [Clause] -> SplitClause -> TCM CoverResult
cover QName
f [Clause]
cs SplitClause
sc'

    -- ...or it was an IApply pattern, so we might just need to introduce the variable now.
    trySplitRes (BlockedOnApply ApplyOrIApply
IsIApply) Bool
finalSplit SplitError -> TCM CoverResult
splitError TCM CoverResult
cont
       = do
         TCMT IO (Maybe SplitClause)
-> TCM CoverResult
-> (SplitClause -> TCM CoverResult)
-> TCM CoverResult
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (QName -> SplitClause -> TCMT IO (Maybe SplitClause)
splitResultPath QName
f SplitClause
sc) TCM CoverResult
fallback ((SplitClause -> TCM CoverResult) -> TCM CoverResult)
-> (SplitClause -> TCM CoverResult) -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ (QName -> [Clause] -> SplitClause -> TCM CoverResult
cover QName
f [Clause]
cs (SplitClause -> TCM CoverResult)
-> ((Telescope, SplitClause) -> SplitClause)
-> (Telescope, SplitClause)
-> TCM CoverResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Telescope, SplitClause) -> SplitClause
forall a b. (a, b) -> b
snd) ((Telescope, SplitClause) -> TCM CoverResult)
-> (SplitClause -> TCM (Telescope, SplitClause))
-> SplitClause
-> TCM CoverResult
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Bool -> SplitClause -> TCM (Telescope, SplitClause)
insertTrailingArgs Bool
False
      where
        fallback :: TCM CoverResult
fallback | Bool
finalSplit = TCM CoverResult
forall a. HasCallStack => a
__IMPOSSIBLE__ -- already ruled out by lhs checker?
                 | Bool
otherwise  = TCM CoverResult
cont

    -- blocked on result but there are catchalls:
    -- try regular splits if there are any, or else throw an error,
    -- this is nicer than continuing and reporting unreachable clauses
    -- (see issue #2833)
    trySplitRes (BlockedOnProj Bool
True) Bool
finalSplit SplitError -> TCM CoverResult
splitError TCM CoverResult
cont
      | Bool
finalSplit = SplitError -> TCM CoverResult
splitError SplitError
CosplitCatchall
      | Bool
otherwise  = TCM CoverResult
cont
    -- all clauses have an unsplit copattern: try to split
    trySplitRes (BlockedOnProj Bool
False) Bool
finalSplit SplitError -> TCM CoverResult
splitError TCM CoverResult
cont = do
      VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover" Nat
20 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"blocked by projection pattern"
      -- forM is a monadic map over a Maybe here
      Either SplitError Covering
mcov <- QName -> SplitClause -> TCMT IO (Either SplitError Covering)
splitResultRecord QName
f SplitClause
sc
      case Either SplitError Covering
mcov of
        Left SplitError
err
          | Bool
finalSplit -> SplitError -> TCM CoverResult
splitError SplitError
err
          | Bool
otherwise  -> TCM CoverResult
cont
        Right (Covering Arg Nat
n [(SplitTag, SplitClause)]
scs) -> do
          -- If result splitting was successful, continue coverage checking.
          ([SplitTag]
projs, [CoverResult]
results) <- [(SplitTag, CoverResult)] -> ([SplitTag], [CoverResult])
forall a b. [(a, b)] -> ([a], [b])
unzip ([(SplitTag, CoverResult)] -> ([SplitTag], [CoverResult]))
-> TCMT IO [(SplitTag, CoverResult)]
-> TCMT IO ([SplitTag], [CoverResult])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
            ((SplitTag, SplitClause) -> TCMT IO (SplitTag, CoverResult))
-> [(SplitTag, SplitClause)] -> TCMT IO [(SplitTag, CoverResult)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM ((SplitClause -> TCM CoverResult)
-> (SplitTag, SplitClause) -> TCMT IO (SplitTag, CoverResult)
forall (t :: * -> *) (m :: * -> *) a b.
(Decoration t, Functor m) =>
(a -> m b) -> t a -> m (t b)
traverseF ((SplitClause -> TCM CoverResult)
 -> (SplitTag, SplitClause) -> TCMT IO (SplitTag, CoverResult))
-> (SplitClause -> TCM CoverResult)
-> (SplitTag, SplitClause)
-> TCMT IO (SplitTag, CoverResult)
forall a b. (a -> b) -> a -> b
$ QName -> [Clause] -> SplitClause -> TCM CoverResult
cover QName
f [Clause]
cs (SplitClause -> TCM CoverResult)
-> (SplitClause -> TCMT IO SplitClause)
-> SplitClause
-> TCM CoverResult
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< ((Telescope, SplitClause) -> SplitClause
forall a b. (a, b) -> b
snd ((Telescope, SplitClause) -> SplitClause)
-> (SplitClause -> TCM (Telescope, SplitClause))
-> SplitClause
-> TCMT IO SplitClause
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Bool -> SplitClause -> TCM (Telescope, SplitClause)
insertTrailingArgs Bool
False)) [(SplitTag, SplitClause)]
scs
            -- OR:
            -- forM scs $ \ (proj, sc') -> (proj,) <$> do
            --   cover f cs =<< do
            --     snd <$> fixTarget sc'
          let trees :: [SplitTree]
trees = (CoverResult -> SplitTree) -> [CoverResult] -> [SplitTree]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> SplitTree
coverSplitTree [CoverResult]
results
              useds :: [IntSet]
useds = (CoverResult -> IntSet) -> [CoverResult] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> IntSet
coverUsedClauses [CoverResult]
results
              psss :: [[(Telescope, [NamedArg DeBruijnPattern])]]
psss  = (CoverResult -> [(Telescope, [NamedArg DeBruijnPattern])])
-> [CoverResult] -> [[(Telescope, [NamedArg DeBruijnPattern])]]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> [(Telescope, [NamedArg DeBruijnPattern])]
coverMissingClauses [CoverResult]
results
              qsss :: [[Clause]]
qsss  = (CoverResult -> [Clause]) -> [CoverResult] -> [[Clause]]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> [Clause]
coverPatterns [CoverResult]
results
              noex :: [IntSet]
noex  = (CoverResult -> IntSet) -> [CoverResult] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map CoverResult -> IntSet
coverNoExactClauses [CoverResult]
results
              tree :: SplitTree
tree  = Arg Nat -> LazySplit -> [(SplitTag, SplitTree)] -> SplitTree
forall a. Arg Nat -> LazySplit -> SplitTrees' a -> SplitTree' a
SplitAt Arg Nat
n LazySplit
StrictSplit ([(SplitTag, SplitTree)] -> SplitTree)
-> [(SplitTag, SplitTree)] -> SplitTree
forall a b. (a -> b) -> a -> b
$ [SplitTag] -> [SplitTree] -> [(SplitTag, SplitTree)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SplitTag]
projs [SplitTree]
trees   -- TODO: Lazy?
          CoverResult -> TCM CoverResult
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverResult -> TCM CoverResult) -> CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ SplitTree
-> IntSet
-> [(Telescope, [NamedArg DeBruijnPattern])]
-> [Clause]
-> IntSet
-> CoverResult
CoverResult SplitTree
tree ([IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions [IntSet]
useds) ([[(Telescope, [NamedArg DeBruijnPattern])]]
-> [(Telescope, [NamedArg DeBruijnPattern])]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[(Telescope, [NamedArg DeBruijnPattern])]]
psss) ([[Clause]] -> [Clause]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat [[Clause]]
qsss) ([IntSet] -> IntSet
forall (f :: * -> *). Foldable f => f IntSet -> IntSet
IntSet.unions [IntSet]
noex)

    gatherEtaSplits :: Int -> SplitClause
                    -> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
    gatherEtaSplits :: Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Nat
n SplitClause
sc []
       | Nat
n Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
>= Nat
0    = [NamedArg SplitPattern]
forall a. HasCallStack => a
__IMPOSSIBLE__ -- we should have encountered the main
                                    -- split by now already
       | Bool
otherwise = []
    gatherEtaSplits Nat
n SplitClause
sc (NamedArg SplitPattern
p:[NamedArg SplitPattern]
ps) = case NamedArg SplitPattern -> SplitPattern
forall a. NamedArg a -> a
namedArg NamedArg SplitPattern
p of
      VarP PatternInfo
_ SplitPatVar
x
       | Nat
n Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0    -> case SplitPattern
p' of -- this is the main split
           VarP  PatternInfo
_ SplitPatVar
_    -> NamedArg SplitPattern
p NamedArg SplitPattern
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. a -> [a] -> [a]
: Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (-Nat
1) SplitClause
sc [NamedArg SplitPattern]
ps
           DotP  PatternInfo
_ Term
_    -> [NamedArg SplitPattern]
forall a. HasCallStack => a
__IMPOSSIBLE__
           ConP  ConHead
_ ConPatternInfo
_ [NamedArg SplitPattern]
qs -> [NamedArg SplitPattern]
qs [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++ Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (-Nat
1) SplitClause
sc [NamedArg SplitPattern]
ps
           LitP{}       -> Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (-Nat
1) SplitClause
sc [NamedArg SplitPattern]
ps
           ProjP{}      -> [NamedArg SplitPattern]
forall a. HasCallStack => a
__IMPOSSIBLE__
           IApplyP{}    -> [NamedArg SplitPattern]
forall a. HasCallStack => a
__IMPOSSIBLE__
           DefP  PatternInfo
_ QName
_ [NamedArg SplitPattern]
qs -> [NamedArg SplitPattern]
qs [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++ Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (-Nat
1) SplitClause
sc [NamedArg SplitPattern]
ps -- __IMPOSSIBLE__ -- Andrea: maybe?
       | Bool
otherwise ->
           (SplitPattern -> SplitPattern)
-> NamedArg SplitPattern -> NamedArg SplitPattern
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg (\ SplitPattern
_ -> SplitPattern
p') NamedArg SplitPattern
p NamedArg SplitPattern
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. a -> [a] -> [a]
: Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (Nat
nNat -> Nat -> Nat
forall a. Num a => a -> a -> a
-Nat
1) SplitClause
sc [NamedArg SplitPattern]
ps
        where p' :: SplitPattern
p' = Substitution' SplitPattern -> Nat -> SplitPattern
forall a. EndoSubst a => Substitution' a -> Nat -> a
lookupS (SplitClause -> Substitution' SplitPattern
scSubst SplitClause
sc) (Nat -> SplitPattern) -> Nat -> SplitPattern
forall a b. (a -> b) -> a -> b
$ SplitPatVar -> Nat
splitPatVarIndex SplitPatVar
x
      IApplyP{}   ->
           (SplitPattern -> SplitPattern)
-> NamedArg SplitPattern -> NamedArg SplitPattern
forall a b. (a -> b) -> NamedArg a -> NamedArg b
updateNamedArg (Substitution' (SubstArg SplitPattern)
-> SplitPattern -> SplitPattern
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst (SplitClause -> Substitution' SplitPattern
scSubst SplitClause
sc)) NamedArg SplitPattern
p NamedArg SplitPattern
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. a -> [a] -> [a]
: Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (Nat
nNat -> Nat -> Nat
forall a. Num a => a -> a -> a
-Nat
1) SplitClause
sc [NamedArg SplitPattern]
ps
      DotP  PatternInfo
_ Term
_    -> NamedArg SplitPattern
p NamedArg SplitPattern
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. a -> [a] -> [a]
: Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (Nat
nNat -> Nat -> Nat
forall a. Num a => a -> a -> a
-Nat
1) SplitClause
sc [NamedArg SplitPattern]
ps -- count dot patterns
      ConP  ConHead
_ ConPatternInfo
_ [NamedArg SplitPattern]
qs -> Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Nat
n SplitClause
sc ([NamedArg SplitPattern]
qs [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++ [NamedArg SplitPattern]
ps)
      DefP  PatternInfo
_ QName
_ [NamedArg SplitPattern]
qs -> Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Nat
n SplitClause
sc ([NamedArg SplitPattern]
qs [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++ [NamedArg SplitPattern]
ps)
      LitP{}       -> Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Nat
n SplitClause
sc [NamedArg SplitPattern]
ps
      ProjP{}      -> Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Nat
n SplitClause
sc [NamedArg SplitPattern]
ps

    addEtaSplits :: Int -> [NamedArg SplitPattern] -> SplitTree -> SplitTree
    addEtaSplits :: Nat -> [NamedArg SplitPattern] -> SplitTree -> SplitTree
addEtaSplits Nat
k []     SplitTree
t = SplitTree
t
    addEtaSplits Nat
k (NamedArg SplitPattern
p:[NamedArg SplitPattern]
ps) SplitTree
t = case NamedArg SplitPattern -> SplitPattern
forall a. NamedArg a -> a
namedArg NamedArg SplitPattern
p of
      VarP  PatternInfo
_ SplitPatVar
_     -> Nat -> [NamedArg SplitPattern] -> SplitTree -> SplitTree
addEtaSplits (Nat
kNat -> Nat -> Nat
forall a. Num a => a -> a -> a
+Nat
1) [NamedArg SplitPattern]
ps SplitTree
t
      DotP  PatternInfo
_ Term
_     -> Nat -> [NamedArg SplitPattern] -> SplitTree -> SplitTree
addEtaSplits (Nat
kNat -> Nat -> Nat
forall a. Num a => a -> a -> a
+Nat
1) [NamedArg SplitPattern]
ps SplitTree
t
      ConP ConHead
c ConPatternInfo
cpi [NamedArg SplitPattern]
qs -> Arg Nat -> LazySplit -> [(SplitTag, SplitTree)] -> SplitTree
forall a. Arg Nat -> LazySplit -> SplitTrees' a -> SplitTree' a
SplitAt (NamedArg SplitPattern
p NamedArg SplitPattern -> Nat -> Arg Nat
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Nat
k) LazySplit
LazySplit [(QName -> SplitTag
SplitCon (ConHead -> QName
conName ConHead
c) , Nat -> [NamedArg SplitPattern] -> SplitTree -> SplitTree
addEtaSplits Nat
k ([NamedArg SplitPattern]
qs [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++ [NamedArg SplitPattern]
ps) SplitTree
t)]
      LitP{}        -> SplitTree
forall a. HasCallStack => a
__IMPOSSIBLE__
      ProjP{}       -> SplitTree
forall a. HasCallStack => a
__IMPOSSIBLE__
      DefP{}        -> SplitTree
forall a. HasCallStack => a
__IMPOSSIBLE__ -- Andrea: maybe?
      IApplyP{}     -> Nat -> [NamedArg SplitPattern] -> SplitTree -> SplitTree
addEtaSplits (Nat
kNat -> Nat -> Nat
forall a. Num a => a -> a -> a
+Nat
1) [NamedArg SplitPattern]
ps SplitTree
t

    etaRecordSplits :: Int -> [NamedArg SplitPattern] -> (SplitTag,SplitClause)
                    -> SplitTree -> (SplitTag,SplitTree)
    etaRecordSplits :: Nat
-> [NamedArg SplitPattern]
-> (SplitTag, SplitClause)
-> SplitTree
-> (SplitTag, SplitTree)
etaRecordSplits Nat
n [NamedArg SplitPattern]
ps (SplitTag
q , SplitClause
sc) SplitTree
t =
      (SplitTag
q , Nat -> [NamedArg SplitPattern] -> SplitTree -> SplitTree
addEtaSplits Nat
0 (Nat
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Nat
n SplitClause
sc [NamedArg SplitPattern]
ps) SplitTree
t)




-- | Append an hcomp clause to the clauses of a function.
createMissingHCompClause
  :: QName
       -- ^ Function name.
  -> Arg Nat -- ^ index of hcomp pattern
  -> BlockingVar -- ^ Blocking var that lead to hcomp split.
  -> SplitClause -- ^ Clause before the hcomp split
  -> SplitClause
       -- ^ Clause to add.
   -> TCM Clause
createMissingHCompClause :: QName
-> Arg Nat
-> BlockingVar
-> SplitClause
-> SplitClause
-> TCM Clause
createMissingHCompClause QName
f Arg Nat
n BlockingVar
x SplitClause
old_sc (SClause Telescope
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_sigma' Map CheckpointId Substitution
cps (Just Dom Type
t)) = QName -> TCM Clause -> TCM Clause
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
f (TCM Clause -> TCM Clause) -> TCM Clause -> TCM Clause
forall a b. (a -> b) -> a -> b
$ do
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"Trying to create right-hand side of type" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Dom Type
t
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"ps = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps)
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"tel = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel

  Term
io      <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> TCM (Maybe Term) -> TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> TCM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => VerboseKey -> m (Maybe Term)
getTerm' VerboseKey
builtinIOne
  Term
iz      <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> TCM (Maybe Term) -> TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> TCM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => VerboseKey -> m (Maybe Term)
getTerm' VerboseKey
builtinIZero
  let
    cannotCreate :: forall m a. (MonadTCEnv m, ReadTCState m, MonadError TCErr m) => Doc -> Closure (Abs Type) -> m a
    cannotCreate :: Doc -> Closure (Abs Type) -> m a
cannotCreate Doc
doc Closure (Abs Type)
t = do
      TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m a)
-> (SplitError -> TypeError) -> SplitError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SplitError -> TypeError
SplitError (SplitError -> m a) -> SplitError -> m a
forall a b. (a -> b) -> a -> b
$ QName
-> (Telescope, [NamedArg DeBruijnPattern])
-> Doc
-> Closure (Abs Type)
-> SplitError
CannotCreateMissingClause QName
f (Telescope
tel,[NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps) Doc
doc Closure (Abs Type)
t
  let old_ps :: Elims
old_ps = [NamedArg DeBruijnPattern] -> Elims
patternsToElims ([NamedArg DeBruijnPattern] -> Elims)
-> [NamedArg DeBruijnPattern] -> Elims
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc
      old_t :: Dom Type
old_t  = Maybe (Dom Type) -> Dom Type
forall a. HasCallStack => Maybe a -> a
fromJust (Maybe (Dom Type) -> Dom Type) -> Maybe (Dom Type) -> Dom Type
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe (Dom Type)
scTarget SplitClause
old_sc
      old_tel :: Telescope
old_tel = SplitClause -> Telescope
scTel SplitClause
old_sc
      -- old_tel = Γ(x:H)Δ
      -- Γ(x:H)Δ ⊢ old_t
      -- vs = iApplyVars old_ps
      -- [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]

      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]
      -- Γ(x:H)Δ ⊢ f old_ps : old_t [ α ⇒ b ]
      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ rhs_we_define : (old_t[ α ⇒ b ])(x = hcomp φ u u0)

      -- Extra assumption:
      -- tel = Γ,φ,u,u0,Δ(x = hcomp φ u u0),Δ'
      -- ps = old_ps[x = hcomp φ u u0],ps'
      -- with Δ' and ps' introduced by fixTarget.
      -- So final clause will be:
      -- tel ⊢ ps ↦ rhs_we_define{wkS ..} ps'
      getLevel :: a -> m Term
getLevel a
t = do
        Sort
s <- Sort -> m Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> m Sort) -> Sort -> m Sort
forall a b. (a -> b) -> a -> b
$ a -> Sort
forall a. LensSort a => a -> Sort
getSort a
t
        case Sort
s of
          Type Level' Term
l -> Term -> m Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Level' Term -> Term
Level Level' Term
l)
          Sort
s      -> do
            VerboseKey -> Nat -> TCM Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
20 (TCM Doc -> m ()) -> TCM Doc -> m ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"getLevel, s = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Sort
s
            TypeError -> m Term
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m Term) -> (Doc -> TypeError) -> Doc -> m Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> m Term) -> m Doc -> m Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
                    (VerboseKey -> m Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"The sort of" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
t m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> VerboseKey -> m Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"should be of the form \"Set l\"")

      -- Γ ⊢ hdelta = (x : H)(δ : Δ)
      (Telescope
gamma,hdelta :: Telescope
hdelta@(ExtendTel Dom Type
hdom Abs Telescope
delta)) = Nat -> Telescope -> (Telescope, Telescope)
splitTelescopeAt (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
old_tel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- (BlockingVar -> Nat
blockingVarNo BlockingVar
x Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
1)) Telescope
old_tel

      -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢
      (Telescope
working_tel,Telescope
_deltaEx) = Nat -> Telescope -> (Telescope, Telescope)
splitTelescopeAt (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
gamma Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
3 Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Abs Telescope -> Nat
forall a. Sized a => a -> Nat
size Abs Telescope
delta) Telescope
tel

      -- Γ,φ,u,u0,(x:H)(δ : Δ) ⊢ rhoS : Γ(x:H)(δ : Δ)
      {- rhoS = liftS (size hdelta) $ raiseS 3 -}
      vs :: [Nat]
vs = [NamedArg SplitPattern] -> [Nat]
forall a. DeBruijn a => [NamedArg (Pattern' a)] -> [Nat]
iApplyVars (SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
old_sc)

  -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ] = [(i,f old_ps (i=0),f old_ps (i=1)) | i <- vs]
  [(Term, (Term, Term))]
alphab <- [Nat]
-> (Nat -> TCM (Term, (Term, Term))) -> TCM [(Term, (Term, Term))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Nat]
vs ((Nat -> TCM (Term, (Term, Term))) -> TCM [(Term, (Term, Term))])
-> (Nat -> TCM (Term, (Term, Term))) -> TCM [(Term, (Term, Term))]
forall a b. (a -> b) -> a -> b
$ \ Nat
i -> do
               let
                 -- Γ(x:H)(δ : Δ) ⊢
                 tm :: Term
tm = QName -> Elims -> Term
Def QName
f Elims
old_ps
               -- TODO only reduce IApply _ _ (0/1), as to avoid termination problems
               (Term
l,Term
r) <- (Term, Term) -> TCM (Term, Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Nat -> Term -> Substitution
forall a. EndoSubst a => Nat -> a -> Substitution' a
inplaceS Nat
i Term
iz Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm, Nat -> Term -> Substitution
forall a. EndoSubst a => Nat -> a -> Substitution' a
inplaceS Nat
i Term
io Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
tm)
               (Term, (Term, Term)) -> TCM (Term, (Term, Term))
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term, (Term, Term)) -> TCM (Term, (Term, Term)))
-> (Term, (Term, Term)) -> TCM (Term, (Term, Term))
forall a b. (a -> b) -> a -> b
$ (Nat -> Term
var Nat
i, (Term
l, Term
r))



  Clause
cl <- do
    (Type
ty,Term
rhs) <- Telescope -> TCM (Type, Term) -> TCM (Type, Term)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
working_tel (TCM (Type, Term) -> TCM (Type, Term))
-> TCM (Type, Term) -> TCM (Type, Term)
forall a b. (a -> b) -> a -> b
$ do
      -- Γ(x:H)Δ ⊢ g = f old_ps : old_t [ α ⇒ b ]
      -- Γ(x:H)(δ : Δ) ⊢ [ α ⇒ b ]
      -- Γ,φ,u,u0 ⊢ Δf = i.Δ[x = hfill φ u u0 i]
      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ δ_fill     = i.tFillTel (i. Δf[~i]) δ (~ i) : i.Δf[i]
      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ old_t_fill = i.old_t[x = hfill φ u u0 i, δ_fill[i]]
      -- Γ,φ,u,u0,δ : Δ(x = hcomp φ u u0) ⊢ comp (\ i. old_t_fill[i])
      --                 (\ i. [ φ ↦ g[x = hfill φ u u0 i,δ_fill[i]] = g[u i,δ_fill[i]]
      --                         α ↦ b[x = hfill φ u u0 i,δ_fill[i]]
      --                        ])
      --                 (g[x = u0,δ_fill[0]]) : old_t[x = hcomp φ u u0,δ]

      Names -> NamesT TCM (Type, Term) -> TCM (Type, Term)
forall (m :: * -> *) a. Names -> NamesT m a -> m a
runNamesT [] (NamesT TCM (Type, Term) -> TCM (Type, Term))
-> NamesT TCM (Type, Term) -> TCM (Type, Term)
forall a b. (a -> b) -> a -> b
$ do
          Term
tPOr <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> NamesT TCM (Maybe Term) -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> NamesT TCM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => VerboseKey -> m (Maybe Term)
getTerm' VerboseKey
builtinPOr
          Term
tIMax <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> NamesT TCM (Maybe Term) -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> NamesT TCM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => VerboseKey -> m (Maybe Term)
getTerm' VerboseKey
builtinIMax
          Term
tIMin <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> NamesT TCM (Maybe Term) -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> NamesT TCM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => VerboseKey -> m (Maybe Term)
getTerm' VerboseKey
builtinIMin
          Term
tINeg <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> NamesT TCM (Maybe Term) -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> NamesT TCM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => VerboseKey -> m (Maybe Term)
getTerm' VerboseKey
builtinINeg
          Term
tHComp <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> NamesT TCM (Maybe Term) -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> NamesT TCM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => VerboseKey -> m (Maybe Term)
getTerm' VerboseKey
builtinHComp
          Term
tTrans <- Term -> Maybe Term -> Term
forall a. a -> Maybe a -> a
fromMaybe Term
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Term -> Term) -> NamesT TCM (Maybe Term) -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> NamesT TCM (Maybe Term)
forall (m :: * -> *). HasBuiltins m => VerboseKey -> m (Maybe Term)
getTerm' VerboseKey
builtinTrans
          NamesT TCM Elims
extra_ps <- Elims -> NamesT TCM (NamesT TCM Elims)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Elims -> NamesT TCM (NamesT TCM Elims))
-> Elims -> NamesT TCM (NamesT TCM Elims)
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> Elims
patternsToElims ([NamedArg DeBruijnPattern] -> Elims)
-> [NamedArg DeBruijnPattern] -> Elims
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ Nat -> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Nat -> [a] -> [a]
drop (Elims -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length Elims
old_ps) [NamedArg SplitPattern]
ps
          let
            ineg :: NamesT TCM Term -> NamesT TCM Term
ineg NamesT TCM Term
j = Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
j
            imax :: NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
imax NamesT TCM Term
i NamesT TCM Term
j = Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
j
            trFillTel' :: t TCM (Abs Telescope)
-> t TCM Term -> t TCM Args -> t TCM Term -> t TCM Args
trFillTel' t TCM (Abs Telescope)
a t TCM Term
b t TCM Args
c t TCM Term
d = do
              ExceptT (Closure (Abs Type)) TCM Args
m <- Abs Telescope
-> Term -> Args -> Term -> ExceptT (Closure (Abs Type)) TCM Args
trFillTel (Abs Telescope
 -> Term -> Args -> Term -> ExceptT (Closure (Abs Type)) TCM Args)
-> t TCM (Abs Telescope)
-> t TCM
     (Term -> Args -> Term -> ExceptT (Closure (Abs Type)) TCM Args)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> t TCM (Abs Telescope)
a t TCM
  (Term -> Args -> Term -> ExceptT (Closure (Abs Type)) TCM Args)
-> t TCM Term
-> t TCM (Args -> Term -> ExceptT (Closure (Abs Type)) TCM Args)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t TCM Term
b t TCM (Args -> Term -> ExceptT (Closure (Abs Type)) TCM Args)
-> t TCM Args
-> t TCM (Term -> ExceptT (Closure (Abs Type)) TCM Args)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t TCM Args
c t TCM (Term -> ExceptT (Closure (Abs Type)) TCM Args)
-> t TCM Term -> t TCM (ExceptT (Closure (Abs Type)) TCM Args)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> t TCM Term
d
              Either (Closure (Abs Type)) Args
x <- TCM (Either (Closure (Abs Type)) Args)
-> t TCM (Either (Closure (Abs Type)) Args)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM (Either (Closure (Abs Type)) Args)
 -> t TCM (Either (Closure (Abs Type)) Args))
-> TCM (Either (Closure (Abs Type)) Args)
-> t TCM (Either (Closure (Abs Type)) Args)
forall a b. (a -> b) -> a -> b
$ ExceptT (Closure (Abs Type)) TCM Args
-> TCM (Either (Closure (Abs Type)) Args)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT (Closure (Abs Type)) TCM Args
m
              case Either (Closure (Abs Type)) Args
x of
                Left Closure (Abs Type)
bad_t -> Doc -> Closure (Abs Type) -> t TCM Args
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
Doc -> Closure (Abs Type) -> m a
cannotCreate Doc
"Cannot transport with type family:" Closure (Abs Type)
bad_t
                Right Args
args -> Args -> t TCM Args
forall (m :: * -> *) a. Monad m => a -> m a
return Args
args
          NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
comp <- do
            let forward :: NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
forward NamesT TCM Term
la NamesT TCM Term
bA NamesT TCM Term
r NamesT TCM Term
u = Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tTrans NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam VerboseKey
"i" (\ NamesT TCM Term
i -> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
i NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
`imax` NamesT TCM Term
r))
                                              NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam VerboseKey
"i" (\ NamesT TCM Term
i -> NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT TCM Term
i NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
`imax` NamesT TCM Term
r))
                                              NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
r
                                              NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
u
            (NamesT TCM Term
 -> NamesT TCM Term
 -> NamesT TCM Term
 -> NamesT TCM Term
 -> NamesT TCM Term
 -> NamesT TCM Term)
-> NamesT
     TCM
     (NamesT TCM Term
      -> NamesT TCM Term
      -> NamesT TCM Term
      -> NamesT TCM Term
      -> NamesT TCM Term
      -> NamesT TCM Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT TCM Term
  -> NamesT TCM Term
  -> NamesT TCM Term
  -> NamesT TCM Term
  -> NamesT TCM Term
  -> NamesT TCM Term)
 -> NamesT
      TCM
      (NamesT TCM Term
       -> NamesT TCM Term
       -> NamesT TCM Term
       -> NamesT TCM Term
       -> NamesT TCM Term
       -> NamesT TCM Term))
-> (NamesT TCM Term
    -> NamesT TCM Term
    -> NamesT TCM Term
    -> NamesT TCM Term
    -> NamesT TCM Term
    -> NamesT TCM Term)
-> NamesT
     TCM
     (NamesT TCM Term
      -> NamesT TCM Term
      -> NamesT TCM Term
      -> NamesT TCM Term
      -> NamesT TCM Term
      -> NamesT TCM Term)
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
la NamesT TCM Term
bA NamesT TCM Term
phi NamesT TCM Term
u NamesT TCM Term
u0 ->
              Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT TCM Term
bA NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
phi
                        NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam VerboseKey
"i" (\ NamesT TCM Term
i -> VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam VerboseKey
"o" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o ->
                                NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
forward NamesT TCM Term
la NamesT TCM Term
bA NamesT TCM Term
i (NamesT TCM Term
u NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT TCM Term
o))
                        NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
forward NamesT TCM Term
la NamesT TCM Term
bA (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT TCM Term
u0
          let
            hcomp :: NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
hcomp NamesT TCM Term
la NamesT TCM Term
bA NamesT TCM Term
phi NamesT TCM Term
u NamesT TCM Term
u0 = Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
bA
                                               NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
phi
                                               NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
u
                                               NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
u0

            hfill :: NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
hfill NamesT TCM Term
la NamesT TCM Term
bA NamesT TCM Term
phi NamesT TCM Term
u NamesT TCM Term
u0 NamesT TCM Term
i = NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
hcomp NamesT TCM Term
la NamesT TCM Term
bA
                                               (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMax NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i))
                                               (VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam VerboseKey
"j" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
j -> Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT TCM Term
la NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tINeg NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam VerboseKey
"o" (\ NamesT TCM Term
_ -> NamesT TCM Term
bA)
                                                     NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam VerboseKey
"o" (\ NamesT TCM Term
o -> NamesT TCM Term
u NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tIMin NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
j) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT TCM Term
o)
                                                     NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam VerboseKey
"o" (\ NamesT TCM Term
_ -> NamesT TCM Term
u0)
                                                   )
                                               NamesT TCM Term
u0
          -- Γ,φ,u,u0,(δ : Δ(x = hcomp φ u u0)) ⊢ hcompS : Γ(x:H)(δ : Δ)
          Substitution
hcompS <- TCM Substitution -> NamesT TCM Substitution
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM Substitution -> NamesT TCM Substitution)
-> TCM Substitution -> NamesT TCM Substitution
forall a b. (a -> b) -> a -> b
$ do
            Dom Type
hdom <- Dom Type -> TCM (Dom Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dom Type -> TCM (Dom Type)) -> Dom Type -> TCM (Dom Type)
forall a b. (a -> b) -> a -> b
$ Nat -> Dom Type -> Dom Type
forall a. Subst a => Nat -> a -> a
raise Nat
3 Dom Type
hdom
            let
              [TCM Term
phi,TCM Term
u,TCM Term
u0] = (Nat -> TCM Term) -> [Nat] -> [TCM Term]
forall a b. (a -> b) -> [a] -> [b]
map (Term -> TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCM Term) -> (Nat -> Term) -> Nat -> TCM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nat -> Term
var) [Nat
2,Nat
1,Nat
0]
              htype :: TCM Term
htype = Term -> TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCM Term) -> Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> (Dom Type -> Type) -> Dom Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Term) -> Dom Type -> Term
forall a b. (a -> b) -> a -> b
$ Dom Type
hdom
              lvl :: TCM Term
lvl = Type -> TCM Term
forall (m :: * -> *) a.
(LensSort a, MonadError TCErr m, PrettyTCM a, PureTCM m,
 MonadInteractionPoints m, MonadFresh NameId m,
 MonadStConcreteNames m, IsString (m Doc), Null (m Doc),
 Semigroup (m Doc)) =>
a -> m Term
getLevel (Type -> TCM Term) -> Type -> TCM Term
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
hdom
            Term
hc <- Term -> TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tHComp TCM Term -> TCM Term -> TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> TCM Term
lvl TCM Term -> TCM Term -> TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> TCM Term
htype
                                      TCM Term -> TCM Term -> TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> TCM Term
phi
                                      TCM Term -> TCM Term -> TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCM Term
u
                                      TCM Term -> TCM Term -> TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCM Term
u0
            Substitution -> TCM Substitution
forall (m :: * -> *) a. Monad m => a -> m a
return (Substitution -> TCM Substitution)
-> Substitution -> TCM Substitution
forall a b. (a -> b) -> a -> b
$ Nat -> Substitution -> Substitution
forall a. Nat -> Substitution' a -> Substitution' a
liftS (Abs Telescope -> Nat
forall a. Sized a => a -> Nat
size Abs Telescope
delta) (Substitution -> Substitution) -> Substitution -> Substitution
forall a b. (a -> b) -> a -> b
$ Term
hc Term -> Substitution -> Substitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
`consS` Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS Nat
3
          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ raise 3+|Δ| hdom
          Dom Type
hdom <- Dom Type -> NamesT TCM (Dom Type)
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Dom Type -> NamesT TCM (Dom Type))
-> Dom Type -> NamesT TCM (Dom Type)
forall a b. (a -> b) -> a -> b
$ Nat -> Dom Type -> Dom Type
forall a. Subst a => Nat -> a -> a
raise (Nat
3Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+Abs Telescope -> Nat
forall a. Sized a => a -> Nat
size Abs Telescope
delta) Dom Type
hdom
          NamesT TCM Term
htype <- Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT TCM (NamesT TCM Term))
-> Term -> NamesT TCM (NamesT TCM Term)
forall a b. (a -> b) -> a -> b
$ Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> (Dom Type -> Type) -> Dom Type -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Term) -> Dom Type -> Term
forall a b. (a -> b) -> a -> b
$ Dom Type
hdom
          NamesT TCM Term
lvl <- Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT TCM (NamesT TCM Term))
-> NamesT TCM Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (TCM Term -> NamesT TCM Term
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM Term -> NamesT TCM Term)
-> (Type -> TCM Term) -> Type -> NamesT TCM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> TCM Term
forall (m :: * -> *) a.
(LensSort a, MonadError TCErr m, PrettyTCM a, PureTCM m,
 MonadInteractionPoints m, MonadFresh NameId m,
 MonadStConcreteNames m, IsString (m Doc), Null (m Doc),
 Semigroup (m Doc)) =>
a -> m Term
getLevel (Type -> NamesT TCM Term) -> Type -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
hdom)

          -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢
          [NamesT TCM Term
phi,NamesT TCM Term
u,NamesT TCM Term
u0] <- (Nat -> NamesT TCM (NamesT TCM Term))
-> [Nat] -> NamesT TCM [NamesT TCM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT TCM (NamesT TCM Term))
-> (Nat -> Term) -> Nat -> NamesT TCM (NamesT TCM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise (Abs Telescope -> Nat
forall a. Sized a => a -> Nat
size Abs Telescope
delta) (Term -> Term) -> (Nat -> Term) -> Nat -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nat -> Term
var) [Nat
2,Nat
1,Nat
0]
          -- Γ,x,Δ ⊢ f old_ps
          -- Γ ⊢ abstract hdelta (f old_ps)
          NamesT TCM Term
g <- Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT TCM (NamesT TCM Term))
-> Term -> NamesT TCM (NamesT TCM Term)
forall a b. (a -> b) -> a -> b
$ Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise (Nat
3Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+Abs Telescope -> Nat
forall a. Sized a => a -> Nat
size Abs Telescope
delta) (Term -> Term) -> Term -> Term
forall a b. (a -> b) -> a -> b
$ Telescope -> Term -> Term
forall t. Abstract t => Telescope -> t -> t
abstract Telescope
hdelta (QName -> Elims -> Term
Def QName
f Elims
old_ps)
          NamesT TCM Type
old_t <- Type -> NamesT TCM (NamesT TCM Type)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Type -> NamesT TCM (NamesT TCM Type))
-> Type -> NamesT TCM (NamesT TCM Type)
forall a b. (a -> b) -> a -> b
$ Nat -> Type -> Type
forall a. Subst a => Nat -> a -> a
raise (Nat
3Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+Abs Telescope -> Nat
forall a. Sized a => a -> Nat
size Abs Telescope
delta) (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Telescope -> Type -> Type
forall t. Abstract t => Telescope -> t -> t
abstract Telescope
hdelta (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
old_t)
          let bapp :: f (Abs b) -> f (SubstArg b) -> f b
bapp f (Abs b)
a f (SubstArg b)
x = Abs b -> SubstArg b -> b
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs b -> SubstArg b -> b) -> f (Abs b) -> f (SubstArg b -> b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f (Abs b)
a f (SubstArg b -> b) -> f (SubstArg b) -> f b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> f (SubstArg b)
x
          (NamesT TCM (Abs Args)
delta_fill :: NamesT TCM (Abs Args)) <- (Abs Args -> NamesT TCM (NamesT TCM (Abs Args))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Args -> NamesT TCM (NamesT TCM (Abs Args)))
-> NamesT TCM (Abs Args) -> NamesT TCM (NamesT TCM (Abs Args))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT TCM (Abs Args) -> NamesT TCM (NamesT TCM (Abs Args)))
-> NamesT TCM (Abs Args) -> NamesT TCM (NamesT TCM (Abs Args))
forall a b. (a -> b) -> a -> b
$ do
            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ x.Δ
            NamesT TCM (Abs Telescope)
delta <- Abs Telescope -> NamesT TCM (NamesT TCM (Abs Telescope))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Telescope -> NamesT TCM (NamesT TCM (Abs Telescope)))
-> Abs Telescope -> NamesT TCM (NamesT TCM (Abs Telescope))
forall a b. (a -> b) -> a -> b
$ Nat -> Abs Telescope -> Abs Telescope
forall a. Subst a => Nat -> a -> a
raise (Nat
3Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+Abs Telescope -> Nat
forall a. Sized a => a -> Nat
size Abs Telescope
delta) Abs Telescope
delta
            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ i.Δ(x = hfill phi u u0 (~ i))
            NamesT TCM (Abs Telescope)
deltaf <- Abs Telescope -> NamesT TCM (NamesT TCM (Abs Telescope))
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Abs Telescope -> NamesT TCM (NamesT TCM (Abs Telescope)))
-> NamesT TCM (Abs Telescope)
-> NamesT TCM (NamesT TCM (Abs Telescope))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< VerboseKey
-> (NamesT TCM Term -> NamesT TCM Telescope)
-> NamesT TCM (Abs Telescope)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
VerboseKey -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind VerboseKey
"i" (\ NamesT TCM Term
i ->
                           (NamesT TCM (Abs Telescope)
delta NamesT TCM (Abs Telescope)
-> NamesT TCM (SubstArg Telescope) -> NamesT TCM Telescope
forall (f :: * -> *) b.
(Applicative f, Subst b) =>
f (Abs b) -> f (SubstArg b) -> f b
`bapp` NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
hfill NamesT TCM Term
lvl NamesT TCM Term
htype NamesT TCM Term
phi NamesT TCM Term
u NamesT TCM Term
u0 (NamesT TCM Term -> NamesT TCM Term
ineg NamesT TCM Term
i)))
            -- Γ,φ,u,u0,Δ(x = hcomp phi u u0) ⊢ Δ(x = hcomp phi u u0) = Δf[0]
            NamesT TCM Args
args <- (Args -> NamesT TCM (NamesT TCM Args)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Args -> NamesT TCM (NamesT TCM Args))
-> NamesT TCM Args -> NamesT TCM (NamesT TCM Args)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<) (NamesT TCM Args -> NamesT TCM (NamesT TCM Args))
-> NamesT TCM Args -> NamesT TCM (NamesT TCM Args)
forall a b. (a -> b) -> a -> b
$ Telescope -> Args
forall a t. DeBruijn a => Tele (Dom t) -> [Arg a]
teleArgs (Telescope -> Args) -> NamesT TCM Telescope -> NamesT TCM Args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Abs Telescope -> Term -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp (Abs Telescope -> Term -> Telescope)
-> NamesT TCM (Abs Telescope) -> NamesT TCM (Term -> Telescope)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM (Abs Telescope)
deltaf NamesT TCM (Term -> Telescope)
-> NamesT TCM Term -> NamesT TCM Telescope
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz)
            VerboseKey
-> (NamesT TCM Term -> NamesT TCM Args) -> NamesT TCM (Abs Args)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
VerboseKey -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind VerboseKey
"i" ((NamesT TCM Term -> NamesT TCM Args) -> NamesT TCM (Abs Args))
-> (NamesT TCM Term -> NamesT TCM Args) -> NamesT TCM (Abs Args)
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
i -> VerboseKey -> NamesT TCM Args -> NamesT TCM Args
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext (VerboseKey
"i" :: String) (NamesT TCM Args -> NamesT TCM Args)
-> NamesT TCM Args -> NamesT TCM Args
forall a b. (a -> b) -> a -> b
$ do -- for error messages.
              -- Γ,φ,u,u0,Δ(x = hcomp phi u u0),(i:I) ⊢ ... : Δ(x = hfill phi u u0 i)
              NamesT TCM (Abs Telescope)
-> NamesT TCM Term
-> NamesT TCM Args
-> NamesT TCM Term
-> NamesT TCM Args
forall (t :: (* -> *) -> * -> *).
(MonadTrans t, MonadTCEnv (t TCM), ReadTCState (t TCM),
 MonadError TCErr (t TCM)) =>
t TCM (Abs Telescope)
-> t TCM Term -> t TCM Args -> t TCM Term -> t TCM Args
trFillTel' NamesT TCM (Abs Telescope)
deltaf (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) NamesT TCM Args
args (NamesT TCM Term -> NamesT TCM Term
ineg NamesT TCM Term
i)
          let
            apply_delta_fill :: NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
apply_delta_fill NamesT TCM Term
i NamesT TCM Term
f = Term -> Args -> Term
forall t. Apply t => t -> Args -> t
apply (Term -> Args -> Term)
-> NamesT TCM Term -> NamesT TCM (Args -> Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term
f NamesT TCM (Args -> Term) -> NamesT TCM Args -> NamesT TCM Term
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> (NamesT TCM (Abs Args)
delta_fill NamesT TCM (Abs Args)
-> NamesT TCM (SubstArg Args) -> NamesT TCM Args
forall (f :: * -> *) b.
(Applicative f, Subst b) =>
f (Abs b) -> f (SubstArg b) -> f b
`bapp` NamesT TCM Term
NamesT TCM (SubstArg Args)
i)
            call :: NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
call NamesT TCM Term
v NamesT TCM Term
i = NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
apply_delta_fill NamesT TCM Term
i (NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM Term -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
g NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
v
          NamesT TCM Term -> NamesT TCM Type
ty <- do
                (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM (NamesT TCM Term -> NamesT TCM Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT TCM Term -> NamesT TCM Type)
 -> NamesT TCM (NamesT TCM Term -> NamesT TCM Type))
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM (NamesT TCM Term -> NamesT TCM Type)
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
i -> do
                    Term
v <- NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
hfill NamesT TCM Term
lvl NamesT TCM Term
htype NamesT TCM Term
phi NamesT TCM Term
u NamesT TCM Term
u0 NamesT TCM Term
i
                    Type
hd <- NamesT TCM Type
old_t
                    Args
args <- NamesT TCM (Abs Args)
delta_fill NamesT TCM (Abs Args)
-> NamesT TCM (SubstArg Args) -> NamesT TCM Args
forall (f :: * -> *) b.
(Applicative f, Subst b) =>
f (Abs b) -> f (SubstArg b) -> f b
`bapp` NamesT TCM Term
NamesT TCM (SubstArg Args)
i
                    TCM Type -> NamesT TCM Type
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM Type -> NamesT TCM Type) -> TCM Type -> NamesT TCM Type
forall a b. (a -> b) -> a -> b
$ Type -> Args -> TCM Type
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
piApplyM Type
hd (Args -> TCM Type) -> Args -> TCM Type
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg (Dom Type -> ArgInfo
forall t e. Dom' t e -> ArgInfo
domInfo Dom Type
hdom) Term
v Arg Term -> Args -> Args
forall a. a -> [a] -> [a]
: Args
args
          NamesT TCM Term
ty_level <- do
            Abs Type
t <- VerboseKey
-> (NamesT TCM Term -> NamesT TCM Type) -> NamesT TCM (Abs Type)
forall (m :: * -> *) b a.
(MonadFail m, Subst b, DeBruijn b, Subst a, Free a) =>
VerboseKey -> (NamesT m b -> NamesT m a) -> NamesT m (Abs a)
bind VerboseKey
"i" NamesT TCM Term -> NamesT TCM Type
ty
            Sort
s <- Sort -> NamesT TCM Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort -> NamesT TCM Sort) -> Sort -> NamesT TCM Sort
forall a b. (a -> b) -> a -> b
$ Type -> Sort
forall a. LensSort a => a -> Sort
getSort (Abs Type -> Type
forall a. Subst a => Abs a -> a
absBody Abs Type
t)
            VerboseKey -> Nat -> TCM Doc -> NamesT TCM ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
20 (TCM Doc -> NamesT TCM ()) -> TCM Doc -> NamesT TCM ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"ty_level, s = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Sort -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Sort
s
            case Sort
s of
              Type Level' Term
l -> Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT TCM (NamesT TCM Term))
-> NamesT TCM Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam VerboseKey
"i" (\ NamesT TCM Term
_ -> Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> NamesT TCM Term) -> Term -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ Level' Term -> Term
Level Level' Term
l)
              Sort
_      -> Doc -> Closure (Abs Type) -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
Doc -> Closure (Abs Type) -> m a
cannotCreate Doc
"Cannot compose with type family:" (Closure (Abs Type) -> NamesT TCM (NamesT TCM Term))
-> NamesT TCM (Closure (Abs Type)) -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCM (Closure (Abs Type)) -> NamesT TCM (Closure (Abs Type))
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (Abs Type -> TCM (Closure (Abs Type))
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Abs Type
t)

          let
            pOr_ty :: NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
pOr_ty NamesT TCM Term
i NamesT TCM Term
phi NamesT TCM Term
psi NamesT TCM Term
u0 NamesT TCM Term
u1 = Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
tPOr NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT TCM Term
ty_level NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i)
                                               NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
psi
                                               NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam VerboseKey
"o" (\ NamesT TCM Term
_ -> Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> NamesT TCM Type -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term -> NamesT TCM Type
ty NamesT TCM Term
i) NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
u0 NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
u1
          NamesT TCM Term
alpha <- do
            [NamesT TCM Term]
vars <- ((Term, (Term, Term)) -> NamesT TCM (NamesT TCM Term))
-> [(Term, (Term, Term))] -> NamesT TCM [NamesT TCM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT TCM (NamesT TCM Term))
-> ((Term, (Term, Term)) -> Term)
-> (Term, (Term, Term))
-> NamesT TCM (NamesT TCM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg Term)
hcompS (Term -> Term)
-> ((Term, (Term, Term)) -> Term) -> (Term, (Term, Term)) -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term, (Term, Term)) -> Term
forall a b. (a, b) -> a
fst) [(Term, (Term, Term))]
alphab
            NamesT TCM Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a. Monad m => a -> m a
return (NamesT TCM Term -> NamesT TCM (NamesT TCM Term))
-> NamesT TCM Term -> NamesT TCM (NamesT TCM Term)
forall a b. (a -> b) -> a -> b
$ (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM Term -> [NamesT TCM Term] -> NamesT TCM Term
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
imax (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ NamesT TCM Term
v -> NamesT TCM Term
v NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
`imax` NamesT TCM Term -> NamesT TCM Term
ineg NamesT TCM Term
v)) (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) [NamesT TCM Term]
vars

          -- Γ,φ,u,u0,Δ(x = hcomp φ u u0) ⊢ b : (i : I) → [α] -> old_t[x = hfill φ u u0 i,δ_fill[i]]
          NamesT TCM Term -> NamesT TCM Term
b <- do
             [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
sides <- [(Term, (Term, Term))]
-> ((Term, (Term, Term))
    -> NamesT
         TCM (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term))
-> NamesT
     TCM [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Term, (Term, Term))]
alphab (((Term, (Term, Term))
  -> NamesT
       TCM (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term))
 -> NamesT
      TCM [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)])
-> ((Term, (Term, Term))
    -> NamesT
         TCM (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term))
-> NamesT
     TCM [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
forall a b. (a -> b) -> a -> b
$ \ (Term
psi,(Term
side0,Term
side1)) -> do
                NamesT TCM Term
psi <- Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT TCM (NamesT TCM Term))
-> Term -> NamesT TCM (NamesT TCM Term)
forall a b. (a -> b) -> a -> b
$ Substitution
Substitution' (SubstArg Term)
hcompS Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst` Term
psi

                [NamesT TCM Term
side0,NamesT TCM Term
side1] <- (Term -> NamesT TCM (NamesT TCM Term))
-> [Term] -> NamesT TCM [NamesT TCM Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Term -> NamesT TCM (NamesT TCM Term)
forall (m :: * -> *) a.
(MonadFail m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT TCM (NamesT TCM Term))
-> (Term -> Term) -> Term -> NamesT TCM (NamesT TCM Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise (Nat
3Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+Abs Telescope -> Nat
forall a. Sized a => a -> Nat
size Abs Telescope
delta) (Term -> Term) -> (Term -> Term) -> Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> Term -> Term
forall t. Abstract t => Telescope -> t -> t
abstract Telescope
hdelta) [Term
side0,Term
side1]
                (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)
 -> NamesT
      TCM (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term))
-> (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)
forall a b. (a -> b) -> a -> b
$ (NamesT TCM Term -> NamesT TCM Term
ineg NamesT TCM Term
psi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
`imax` NamesT TCM Term
psi, \ NamesT TCM Term
i -> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
pOr_ty NamesT TCM Term
i (NamesT TCM Term -> NamesT TCM Term
ineg NamesT TCM Term
psi) NamesT TCM Term
psi (VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam VerboseKey
"o" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
apply_delta_fill NamesT TCM Term
i (NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM Term -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
side0 NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
hfill NamesT TCM Term
lvl NamesT TCM Term
htype NamesT TCM Term
phi NamesT TCM Term
u NamesT TCM Term
u0 NamesT TCM Term
i)
                                                            (VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam VerboseKey
"o" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
_ -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
apply_delta_fill NamesT TCM Term
i (NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM Term -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ NamesT TCM Term
side1 NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
hfill NamesT TCM Term
lvl NamesT TCM Term
htype NamesT TCM Term
phi NamesT TCM Term
u NamesT TCM Term
u0 NamesT TCM Term
i))
             let recurse :: [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
-> NamesT TCM Term -> NamesT TCM Term
recurse []           NamesT TCM Term
i = NamesT TCM Term
forall a. HasCallStack => a
__IMPOSSIBLE__
                 recurse [(NamesT TCM Term
psi,NamesT TCM Term -> NamesT TCM Term
u)]    NamesT TCM Term
i = NamesT TCM Term -> NamesT TCM Term
u NamesT TCM Term
i
                 recurse ((NamesT TCM Term
psi,NamesT TCM Term -> NamesT TCM Term
u):[(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
xs) NamesT TCM Term
i = NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
pOr_ty NamesT TCM Term
i NamesT TCM Term
psi (((NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)
 -> NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM Term
-> [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
-> NamesT TCM Term
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
imax (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term)
-> ((NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)
    -> NamesT TCM Term)
-> (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM Term
-> NamesT TCM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM Term
forall a b. (a, b) -> a
fst) (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz) [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
xs) (NamesT TCM Term -> NamesT TCM Term
u NamesT TCM Term
i) ([(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
-> NamesT TCM Term -> NamesT TCM Term
recurse [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
xs NamesT TCM Term
i)
             (NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM (NamesT TCM Term -> NamesT TCM Term)
forall (m :: * -> *) a. Monad m => a -> m a
return ((NamesT TCM Term -> NamesT TCM Term)
 -> NamesT TCM (NamesT TCM Term -> NamesT TCM Term))
-> (NamesT TCM Term -> NamesT TCM Term)
-> NamesT TCM (NamesT TCM Term -> NamesT TCM Term)
forall a b. (a -> b) -> a -> b
$ [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
-> NamesT TCM Term -> NamesT TCM Term
recurse [(NamesT TCM Term, NamesT TCM Term -> NamesT TCM Term)]
sides

          ((,) (Type -> Term -> (Type, Term))
-> NamesT TCM Type -> NamesT TCM (Term -> (Type, Term))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> NamesT TCM Term -> NamesT TCM Type
ty (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
io) NamesT TCM (Term -> (Type, Term))
-> NamesT TCM Term -> NamesT TCM (Type, Term)
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*>) (NamesT TCM Term -> NamesT TCM (Type, Term))
-> NamesT TCM Term -> NamesT TCM (Type, Term)
forall a b. (a -> b) -> a -> b
$ do
            NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
comp NamesT TCM Term
ty_level
               (VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam VerboseKey
"i" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ (Type -> Term) -> NamesT TCM Type -> NamesT TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Type -> Term
forall t a. Type'' t a -> a
unEl (NamesT TCM Type -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Type)
-> NamesT TCM Term
-> NamesT TCM Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamesT TCM Term -> NamesT TCM Type
ty)
                           (NamesT TCM Term
phi NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
`imax` NamesT TCM Term
alpha)
                           (VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam VerboseKey
"i" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
i ->
                               let rhs :: NamesT TCM Term
rhs = (VerboseKey
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall (m :: * -> *).
MonadFail m =>
VerboseKey -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
ilam VerboseKey
"o" ((NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term)
-> (NamesT TCM Term -> NamesT TCM Term) -> NamesT TCM Term
forall a b. (a -> b) -> a -> b
$ \ NamesT TCM Term
o -> NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
call (NamesT TCM Term
u NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT TCM Term
i NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT TCM Term
o) NamesT TCM Term
i)
                               in if [(Term, (Term, Term))] -> Bool
forall a. Null a => a -> Bool
null [(Term, (Term, Term))]
alphab then NamesT TCM Term
rhs else
                                   NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
-> NamesT TCM Term
pOr_ty NamesT TCM Term
i NamesT TCM Term
phi NamesT TCM Term
alpha NamesT TCM Term
rhs (NamesT TCM Term -> NamesT TCM Term
b NamesT TCM Term
i)
                           )
                           (NamesT TCM Term -> NamesT TCM Term -> NamesT TCM Term
call NamesT TCM Term
u0 (Term -> NamesT TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
iz))
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"old_tel =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
    let n :: Nat
n = Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
gamma Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
3 Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Abs Telescope -> Nat
forall a. Sized a => a -> Nat
size Abs Telescope
delta)
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"n =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (Nat -> VerboseKey
forall a. Show a => a -> VerboseKey
show Nat
n)
    (TelV Telescope
deltaEx Type
t,[(Term, (Term, Term))]
bs) <- Nat -> Type -> TCM (TelV Type, [(Term, (Term, Term))])
forall (m :: * -> *).
PureTCM m =>
Nat -> Type -> m (TelV Type, [(Term, (Term, Term))])
telViewUpToPathBoundary' Nat
n Type
ty
    Term
rhs <- Term -> TCM Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Term -> TCM Term) -> Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ Nat -> Term -> Term
forall a. Subst a => Nat -> a -> a
raise Nat
n Term
rhs Term -> Elims -> Term
forall t. Apply t => t -> Elims -> t
`applyE` Telescope -> [(Term, (Term, Term))] -> Elims
forall a. DeBruijn a => Telescope -> Boundary' (a, a) -> [Elim' a]
teleElims Telescope
deltaEx [(Term, (Term, Term))]
bs

    Telescope
cxt <- TCM Telescope
forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Telescope
getContextTelescope
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"cxt = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
cxt
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"tel = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"t = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
t
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.hcomp" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"rhs = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
rhs

    Clause -> TCM Clause
forall (m :: * -> *) a. Monad m => a -> m a
return (Clause -> TCM Clause) -> Clause -> TCM Clause
forall a b. (a -> b) -> a -> b
$ Clause :: Range
-> Range
-> Telescope
-> [NamedArg DeBruijnPattern]
-> Maybe Term
-> Maybe (Arg Type)
-> Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> ExpandedEllipsis
-> Clause
Clause { clauseLHSRange :: Range
clauseLHSRange  = Range
forall a. Range' a
noRange
                    , clauseFullRange :: Range
clauseFullRange = Range
forall a. Range' a
noRange
                    , clauseTel :: Telescope
clauseTel       = Telescope
tel
                    , namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps
                    , clauseBody :: Maybe Term
clauseBody      = Term -> Maybe Term
forall a. a -> Maybe a
Just (Term -> Maybe Term) -> Term -> Maybe Term
forall a b. (a -> b) -> a -> b
$ Term
rhs
                    , clauseType :: Maybe (Arg Type)
clauseType      = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Arg Type -> Maybe (Arg Type)) -> Arg Type -> Maybe (Arg Type)
forall a b. (a -> b) -> a -> b
$ Type -> Arg Type
forall a. a -> Arg a
defaultArg Type
t
                    , clauseCatchall :: Bool
clauseCatchall  = Bool
False
                    , clauseExact :: Maybe Bool
clauseExact       = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
                    , clauseRecursive :: Maybe Bool
clauseRecursive   = Maybe Bool
forall a. Maybe a
Nothing     -- TODO: can it be recursive?
                    , clauseUnreachable :: Maybe Bool
clauseUnreachable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False  -- missing, thus, not unreachable
                    , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis  = ExpandedEllipsis
NoEllipsis
                    }
  QName -> [Clause] -> TCMT IO ()
addClauses QName
f [Clause
cl]  -- Important: add at the end.
  Clause -> TCM Clause
forall (m :: * -> *) a. Monad m => a -> m a
return Clause
cl
createMissingHCompClause QName
_ Arg Nat
_ BlockingVar
_ SplitClause
_ (SClause Telescope
_ [NamedArg SplitPattern]
_ Substitution' SplitPattern
_ Map CheckpointId Substitution
_ Maybe (Dom Type)
Nothing) = TCM Clause
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | Append a instance clause to the clauses of a function.
inferMissingClause
  :: QName
       -- ^ Function name.
  -> SplitClause
       -- ^ Clause to add.  Clause hiding (in 'clauseType') must be 'Instance'.
   -> TCM Clause
inferMissingClause :: QName -> SplitClause -> TCM Clause
inferMissingClause QName
f (SClause Telescope
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId Substitution
cps (Just Dom Type
t)) = QName -> TCM Clause -> TCM Clause
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange QName
f (TCM Clause -> TCM Clause) -> TCM Clause -> TCM Clause
forall a b. (a -> b) -> a -> b
$ do
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.infer" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"Trying to infer right-hand side of type" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Dom Type
t
  Term
rhs <-
    Telescope -> TCM Term -> TCM Term
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel
    (TCM Term -> TCM Term) -> TCM Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ Lens' (Map CheckpointId Substitution) TCEnv
-> (Map CheckpointId Substitution -> Map CheckpointId Substitution)
-> TCM Term
-> TCM Term
forall (m :: * -> *) a b.
MonadTCEnv m =>
Lens' a TCEnv -> (a -> a) -> m b -> m b
locallyTC Lens' (Map CheckpointId Substitution) TCEnv
eCheckpoints (Map CheckpointId Substitution
-> Map CheckpointId Substitution -> Map CheckpointId Substitution
forall a b. a -> b -> a
const Map CheckpointId Substitution
cps)
    (TCM Term -> TCM Term) -> TCM Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ Substitution -> TCM Term -> TCM Term
forall (tcm :: * -> *) a.
(MonadDebug tcm, MonadTCM tcm, MonadFresh CheckpointId tcm,
 ReadTCState tcm) =>
Substitution -> tcm a -> tcm a
checkpoint Substitution
forall a. Substitution' a
IdS    -- introduce a fresh checkpoint
    (TCM Term -> TCM Term) -> TCM Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ case Dom Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom Type
t of
        Hiding
_ | Just Term
tac <- Dom Type -> Maybe Term
forall t e. Dom' t e -> Maybe t
domTactic Dom Type
t -> do
          VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.infer" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
            [ TCM Doc
"@tactic rhs"
            , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"target =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Dom Type
t ]
          (MetaId
_, Term
v) <- RunMetaOccursCheck -> Comparison -> Type -> TCMT IO (MetaId, Term)
forall (m :: * -> *).
MonadMetaSolver m =>
RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)
newValueMeta RunMetaOccursCheck
DontRunMetaOccursCheck Comparison
CmpLeq (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)
          Term
v Term -> TCMT IO () -> TCM Term
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Term -> Term -> Type -> TCMT IO ()
unquoteTactic Term
tac Term
v (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)
        Instance{} -> (MetaId, Term) -> Term
forall a b. (a, b) -> b
snd ((MetaId, Term) -> Term) -> TCMT IO (MetaId, Term) -> TCM Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> Type -> TCMT IO (MetaId, Term)
forall (m :: * -> *).
MonadMetaSolver m =>
VerboseKey -> Type -> m (MetaId, Term)
newInstanceMeta VerboseKey
"" (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)
        Hiding
Hidden     -> TCM Term
forall a. HasCallStack => a
__IMPOSSIBLE__
        Hiding
NotHidden  -> TCM Term
forall a. HasCallStack => a
__IMPOSSIBLE__
  let cl :: Clause
cl = Clause :: Range
-> Range
-> Telescope
-> [NamedArg DeBruijnPattern]
-> Maybe Term
-> Maybe (Arg Type)
-> Bool
-> Maybe Bool
-> Maybe Bool
-> Maybe Bool
-> ExpandedEllipsis
-> Clause
Clause { clauseLHSRange :: Range
clauseLHSRange  = Range
forall a. Range' a
noRange
                  , clauseFullRange :: Range
clauseFullRange = Range
forall a. Range' a
noRange
                  , clauseTel :: Telescope
clauseTel       = Telescope
tel
                  , namedClausePats :: [NamedArg DeBruijnPattern]
namedClausePats = [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps
                  , clauseBody :: Maybe Term
clauseBody      = Term -> Maybe Term
forall a. a -> Maybe a
Just Term
rhs
                  , clauseType :: Maybe (Arg Type)
clauseType      = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Dom Type -> Arg Type
forall t a. Dom' t a -> Arg a
argFromDom Dom Type
t)
                  , clauseCatchall :: Bool
clauseCatchall  = Bool
False
                  , clauseExact :: Maybe Bool
clauseExact       = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
True
                  , clauseRecursive :: Maybe Bool
clauseRecursive   = Maybe Bool
forall a. Maybe a
Nothing     -- could be recursive
                  , clauseUnreachable :: Maybe Bool
clauseUnreachable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False  -- missing, thus, not unreachable
                  , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis  = ExpandedEllipsis
NoEllipsis
                  }
  QName -> [Clause] -> TCMT IO ()
addClauses QName
f [Clause
cl]  -- Important: add at the end.
  Clause -> TCM Clause
forall (m :: * -> *) a. Monad m => a -> m a
return Clause
cl
inferMissingClause QName
_ (SClause Telescope
_ [NamedArg SplitPattern]
_ Substitution' SplitPattern
_ Map CheckpointId Substitution
_ Maybe (Dom Type)
Nothing) = TCM Clause
forall a. HasCallStack => a
__IMPOSSIBLE__

splitStrategy :: BlockingVars -> Telescope -> TCM BlockingVars
splitStrategy :: BlockingVars -> Telescope -> TCM BlockingVars
splitStrategy BlockingVars
bs Telescope
tel = BlockingVars -> TCM BlockingVars
forall (m :: * -> *) a. Monad m => a -> m a
return (BlockingVars -> TCM BlockingVars)
-> BlockingVars -> TCM BlockingVars
forall a b. (a -> b) -> a -> b
$ (BlockingVar -> BlockingVar) -> BlockingVars -> BlockingVars
forall a. (a -> a) -> [a] -> [a]
updateLast BlockingVar -> BlockingVar
setBlockingVarOverlap BlockingVars
xs
  -- Make sure we do not insists on precomputed coverage when
  -- we make our last try to split.
  -- Otherwise, we will not get a nice error message.
  where
    xs :: BlockingVars
xs             = BlockingVars
strict BlockingVars -> BlockingVars -> BlockingVars
forall a. [a] -> [a] -> [a]
++ BlockingVars
lazy
    (BlockingVars
lazy, BlockingVars
strict) = (BlockingVar -> Bool)
-> BlockingVars -> (BlockingVars, BlockingVars)
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition BlockingVar -> Bool
blockingVarLazy BlockingVars
bs
{- KEEP!
--  Andreas, 2012-10-13
--  The following split strategy which prefers all-constructor columns
--  fails on test/fail/CoverStrategy
    xs       = ys ++ zs
    (ys, zs) = partition allConstructors bs
    allConstructors :: BlockingVar -> Bool
    allConstructors = isJust . snd
-}


-- | Check that a type is a non-irrelevant datatype or a record with
-- named constructor. Unless the 'Induction' argument is 'CoInductive'
-- the data type must be inductive.
isDatatype :: (MonadTCM tcm, MonadError SplitError tcm) =>
              Induction -> Dom Type ->
              tcm (DataOrRecord, QName, [Arg Term], [Arg Term], [QName], Bool)
isDatatype :: Induction
-> Dom Type -> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
isDatatype Induction
ind Dom Type
at = do
  let t :: Type
t       = Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
at
      throw :: (Closure Type -> SplitError)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
throw Closure Type -> SplitError
f = SplitError -> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SplitError
 -> tcm (DataOrRecord, QName, Args, Args, [QName], Bool))
-> (Closure Type -> SplitError)
-> Closure Type
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure Type -> SplitError
f (Closure Type
 -> tcm (DataOrRecord, QName, Args, Args, [QName], Bool))
-> tcm (Closure Type)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do TCM (Closure Type) -> tcm (Closure Type)
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Closure Type) -> tcm (Closure Type))
-> TCM (Closure Type) -> tcm (Closure Type)
forall a b. (a -> b) -> a -> b
$ Type -> TCM (Closure Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Type
t
  Type
t' <- TCM Type -> tcm Type
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Type -> tcm Type) -> TCM Type -> tcm Type
forall a b. (a -> b) -> a -> b
$ Type -> TCM Type
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Type
t
  Maybe QName
mInterval <- TCMT IO (Maybe QName) -> tcm (Maybe QName)
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (Maybe QName) -> tcm (Maybe QName))
-> TCMT IO (Maybe QName) -> tcm (Maybe QName)
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCMT IO (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
VerboseKey -> m (Maybe QName)
getBuiltinName' VerboseKey
builtinInterval
  Maybe QName
mIsOne <- TCMT IO (Maybe QName) -> tcm (Maybe QName)
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (Maybe QName) -> tcm (Maybe QName))
-> TCMT IO (Maybe QName) -> tcm (Maybe QName)
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCMT IO (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
VerboseKey -> m (Maybe QName)
getBuiltinName' VerboseKey
builtinIsOne
  case Type -> Term
forall t a. Type'' t a -> a
unEl Type
t' of
    Def QName
d [] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
d Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mInterval -> (Closure Type -> SplitError)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
throw Closure Type -> SplitError
NotADatatype
    Def QName
d [Apply Arg Term
phi] | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
d Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mIsOne -> do
                [(Map Nat Bool, [Term])]
xs <- TCM [(Map Nat Bool, [Term])] -> tcm [(Map Nat Bool, [Term])]
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM [(Map Nat Bool, [Term])] -> tcm [(Map Nat Bool, [Term])])
-> TCM [(Map Nat Bool, [Term])] -> tcm [(Map Nat Bool, [Term])]
forall a b. (a -> b) -> a -> b
$ Term -> TCM [(Map Nat Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(Map Nat Bool, [Term])]
decomposeInterval (Term -> TCM [(Map Nat Bool, [Term])])
-> TCM Term -> TCM [(Map Nat Bool, [Term])]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> TCM Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
phi)
                if [(Map Nat Bool, [Term])] -> Bool
forall a. Null a => a -> Bool
null [(Map Nat Bool, [Term])]
xs
                   then (DataOrRecord, QName, Args, Args, [QName], Bool)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return ((DataOrRecord, QName, Args, Args, [QName], Bool)
 -> tcm (DataOrRecord, QName, Args, Args, [QName], Bool))
-> (DataOrRecord, QName, Args, Args, [QName], Bool)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
forall a b. (a -> b) -> a -> b
$ (DataOrRecord
IsData, QName
d, [Arg Term
phi], [], [], Bool
False)
                   else (Closure Type -> SplitError)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
throw Closure Type -> SplitError
NotADatatype
    Def QName
d Elims
es -> do
      let ~(Just Args
args) = Elims -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
      Defn
def <- TCM Defn -> tcm Defn
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Defn -> tcm Defn) -> TCM Defn -> tcm Defn
forall a b. (a -> b) -> a -> b
$ Definition -> Defn
theDef (Definition -> Defn) -> TCMT IO Definition -> TCM Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
      case Defn
def of
        Datatype{dataPars :: Defn -> Nat
dataPars = Nat
np, dataCons :: Defn -> [QName]
dataCons = [QName]
cs}
          | Bool
otherwise -> do
              let (Args
ps, Args
is) = Nat -> Args -> (Args, Args)
forall a. Nat -> [a] -> ([a], [a])
splitAt Nat
np Args
args
              (DataOrRecord, QName, Args, Args, [QName], Bool)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (DataOrRecord
IsData, QName
d, Args
ps, Args
is, [QName]
cs, Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [QName] -> Bool
forall a. Null a => a -> Bool
null (Defn -> [QName]
dataPathCons Defn
def))
        Record{recPars :: Defn -> Nat
recPars = Nat
np, recConHead :: Defn -> ConHead
recConHead = ConHead
con, recInduction :: Defn -> Maybe Induction
recInduction = Maybe Induction
i, EtaEquality
recEtaEquality' :: Defn -> EtaEquality
recEtaEquality' :: EtaEquality
recEtaEquality'}
          | Maybe Induction
i Maybe Induction -> Maybe Induction -> Bool
forall a. Eq a => a -> a -> Bool
== Induction -> Maybe Induction
forall a. a -> Maybe a
Just Induction
CoInductive Bool -> Bool -> Bool
&& Induction
ind Induction -> Induction -> Bool
forall a. Eq a => a -> a -> Bool
/= Induction
CoInductive ->
              (Closure Type -> SplitError)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
throw Closure Type -> SplitError
CoinductiveDatatype
          | Bool
otherwise ->
              (DataOrRecord, QName, Args, Args, [QName], Bool)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Induction -> EtaEquality -> DataOrRecord
IsRecord Maybe Induction
i EtaEquality
recEtaEquality', QName
d, Args
args, [], [ConHead -> QName
conName ConHead
con], Bool
False)
        Defn
_ -> (Closure Type -> SplitError)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
throw Closure Type -> SplitError
NotADatatype
    Term
_ -> (Closure Type -> SplitError)
-> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
throw Closure Type -> SplitError
NotADatatype

-- | Update the target type of the split clause after a case split.
fixTargetType
  :: Quantity  -- ^ The quantity of the thing that is split.
  -> SplitTag -> SplitClause -> Dom Type -> TCM SplitClause
fixTargetType :: Quantity
-> SplitTag -> SplitClause -> Dom Type -> TCMT IO SplitClause
fixTargetType Quantity
q SplitTag
tag sc :: SplitClause
sc@SClause{ scTel :: SplitClause -> Telescope
scTel = Telescope
sctel, scSubst :: SplitClause -> Substitution' SplitPattern
scSubst = Substitution' SplitPattern
sigma } Dom Type
target = do
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.target" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCM Doc
"split clause telescope: " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
sctel
      ]
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.target" Nat
60 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCM Doc
"substitution          : " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' SplitPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Substitution' SplitPattern
sigma
      ]
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.target" Nat
60 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCM Doc
"target type before substitution:" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Dom Type
target
      , TCM Doc
"             after substitution:" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Substitution' SplitPattern -> Dom Type -> Dom Type
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
sigma Dom Type
target)
      ]

    -- We update the target quantity to 0 for erased constructors, but
    -- not if the match is made in an erased position, or if the
    -- original constructor definition is not erased.
    Dom Type -> Dom Type
updQuant <- do
      let erased :: Bool
erased = case Quantity
q of
            Quantity0{} -> Bool
True
            Quantity1{} -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
            Quantityω{} -> Bool
False
      if Bool
erased then (Dom Type -> Dom Type) -> TCMT IO (Dom Type -> Dom Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Dom Type -> Dom Type
forall a. a -> a
id else case SplitTag
tag of
        SplitCon QName
c -> do
          Quantity
q <- Definition -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity (Definition -> Quantity) -> TCMT IO Definition -> TCMT IO Quantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *).
(ReadTCState m, HasConstInfo m) =>
QName -> m Definition
getOriginalConstInfo QName
c
          case Quantity
q of
            Quantity0{} -> (Dom Type -> Dom Type) -> TCMT IO (Dom Type -> Dom Type)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Dom Type -> Dom Type) -> TCMT IO (Dom Type -> Dom Type))
-> (Dom Type -> Dom Type) -> TCMT IO (Dom Type -> Dom Type)
forall a b. (a -> b) -> a -> b
$ (Quantity -> Quantity) -> Dom Type -> Dom Type
forall a. LensQuantity a => (Quantity -> Quantity) -> a -> a
mapQuantity (Quantity -> Quantity -> Quantity
composeQuantity Quantity
q)
            Quantity1{} -> (Dom Type -> Dom Type) -> TCMT IO (Dom Type -> Dom Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Dom Type -> Dom Type
forall a. a -> a
id
            Quantityω{} -> (Dom Type -> Dom Type) -> TCMT IO (Dom Type -> Dom Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Dom Type -> Dom Type
forall a. a -> a
id
        SplitLit{} -> (Dom Type -> Dom Type) -> TCMT IO (Dom Type -> Dom Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Dom Type -> Dom Type
forall a. a -> a
id
        SplitCatchall{} -> (Dom Type -> Dom Type) -> TCMT IO (Dom Type -> Dom Type)
forall (m :: * -> *) a. Monad m => a -> m a
return Dom Type -> Dom Type
forall a. a -> a
id

    SplitClause -> TCMT IO SplitClause
forall (m :: * -> *) a. Monad m => a -> m a
return (SplitClause -> TCMT IO SplitClause)
-> SplitClause -> TCMT IO SplitClause
forall a b. (a -> b) -> a -> b
$ SplitClause
sc { scTarget :: Maybe (Dom Type)
scTarget = Dom Type -> Maybe (Dom Type)
forall a. a -> Maybe a
Just (Dom Type -> Maybe (Dom Type)) -> Dom Type -> Maybe (Dom Type)
forall a b. (a -> b) -> a -> b
$ Dom Type -> Dom Type
updQuant (Dom Type -> Dom Type) -> Dom Type -> Dom Type
forall a b. (a -> b) -> a -> b
$ Substitution' SplitPattern -> Dom Type -> Dom Type
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
sigma Dom Type
target }


-- | Add more patterns to split clause if the target type is a function type.
--   Returns the domains of the function type (if any).
insertTrailingArgs
  :: Bool         -- ^ Force insertion even when there is a 'domTactic'?
  -> SplitClause
  -> TCM (Telescope, SplitClause)
insertTrailingArgs :: Bool -> SplitClause -> TCM (Telescope, SplitClause)
insertTrailingArgs Bool
force sc :: SplitClause
sc@SClause{ scTel :: SplitClause -> Telescope
scTel = Telescope
sctel, scPats :: SplitClause -> [NamedArg SplitPattern]
scPats = [NamedArg SplitPattern]
ps, scSubst :: SplitClause -> Substitution' SplitPattern
scSubst = Substitution' SplitPattern
sigma, scCheckpoints :: SplitClause -> Map CheckpointId Substitution
scCheckpoints = Map CheckpointId Substitution
cps, scTarget :: SplitClause -> Maybe (Dom Type)
scTarget = Maybe (Dom Type)
target } = do
  let fallback :: TCM (Telescope, SplitClause)
fallback = (Telescope, SplitClause) -> TCM (Telescope, SplitClause)
forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope
forall a. Null a => a
empty, SplitClause
sc)
  Maybe (Dom Type)
-> TCM (Telescope, SplitClause)
-> (Dom Type -> TCM (Telescope, SplitClause))
-> TCM (Telescope, SplitClause)
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Dom Type)
target TCM (Telescope, SplitClause)
fallback ((Dom Type -> TCM (Telescope, SplitClause))
 -> TCM (Telescope, SplitClause))
-> (Dom Type -> TCM (Telescope, SplitClause))
-> TCM (Telescope, SplitClause)
forall a b. (a -> b) -> a -> b
$ \ Dom Type
a -> do
    if Maybe Term -> Bool
forall a. Maybe a -> Bool
isJust (Dom Type -> Maybe Term
forall t e. Dom' t e -> Maybe t
domTactic Dom Type
a) Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
force then TCM (Telescope, SplitClause)
fallback else do
    (TelV Telescope
tel Type
b) <- Nat -> Type -> TCMT IO (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Nat -> Type -> m (TelV Type)
telViewUpTo (-Nat
1) (Type -> TCMT IO (TelV Type)) -> Type -> TCMT IO (TelV Type)
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
a
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.target" Nat
15 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCM Doc
"target type telescope: " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do
          Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
sctel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
      , TCM Doc
"target type core     : " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do
          Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
sctel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
b
      ]
    let n :: Nat
n         = Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel
        -- Andreas, 2016-10-04 issue #2236
        -- Need to set origin to "Inserted" to avoid printing of hidden patterns.
        xs :: [NamedArg SplitPattern]
xs        = (NamedArg SplitPattern -> NamedArg SplitPattern)
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> [a] -> [b]
map ((ArgInfo -> ArgInfo)
-> NamedArg SplitPattern -> NamedArg SplitPattern
forall a. LensArgInfo a => (ArgInfo -> ArgInfo) -> a -> a
mapArgInfo ArgInfo -> ArgInfo
hiddenInserted) ([NamedArg SplitPattern] -> [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> a -> b
$ Telescope -> [NamedArg SplitPattern]
forall a. DeBruijn a => Telescope -> [NamedArg a]
teleNamedArgs Telescope
tel
        -- Compute new split clause
        sctel' :: Telescope
sctel'    = ListTel -> Telescope
telFromList (ListTel -> Telescope) -> ListTel -> Telescope
forall a b. (a -> b) -> a -> b
$ Telescope -> ListTel
forall t. Tele (Dom t) -> [Dom (VerboseKey, t)]
telToList (Nat -> Telescope -> Telescope
forall a. Subst a => Nat -> a -> a
raise Nat
n Telescope
sctel) ListTel -> ListTel -> ListTel
forall a. [a] -> [a] -> [a]
++ Telescope -> ListTel
forall t. Tele (Dom t) -> [Dom (VerboseKey, t)]
telToList Telescope
tel
        -- Dot patterns in @ps@ need to be raised!  (Issue 1298)
        ps' :: [NamedArg SplitPattern]
ps'       = Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst (Nat -> Substitution' SplitPattern
forall a. Nat -> Substitution' a
raiseS Nat
n) [NamedArg SplitPattern]
ps [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++ [NamedArg SplitPattern]
xs
        newTarget :: Maybe (Dom Type)
newTarget = Dom Type -> Maybe (Dom Type)
forall a. a -> Maybe a
Just (Dom Type -> Maybe (Dom Type)) -> Dom Type -> Maybe (Dom Type)
forall a b. (a -> b) -> a -> b
$ (if Bool -> Bool
not (Telescope -> Bool
forall a. Null a => a -> Bool
null Telescope
tel) then Dom Type
a{ domTactic :: Maybe Term
domTactic = Maybe Term
forall a. Maybe a
Nothing } else Dom Type
a) Dom Type -> Type -> Dom Type
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Type
b
        sc' :: SplitClause
sc'       = SClause :: Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause
          { scTel :: Telescope
scTel    = Telescope
sctel'
          , scPats :: [NamedArg SplitPattern]
scPats   = [NamedArg SplitPattern]
ps'
          , scSubst :: Substitution' SplitPattern
scSubst  = Nat -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Nat -> Substitution' a -> Substitution' a
wkS Nat
n (Substitution' SplitPattern -> Substitution' SplitPattern)
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a b. (a -> b) -> a -> b
$ Substitution' SplitPattern
sigma -- Should be wkS instead of liftS since
                                     -- variables are only added to new tel.
          , scCheckpoints :: Map CheckpointId Substitution
scCheckpoints        = Substitution' (SubstArg (Map CheckpointId Substitution))
-> Map CheckpointId Substitution -> Map CheckpointId Substitution
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst (Nat -> Substitution
forall a. Nat -> Substitution' a
raiseS Nat
n) Map CheckpointId Substitution
cps
          , scTarget :: Maybe (Dom Type)
scTarget = Maybe (Dom Type)
newTarget
          }
    -- Separate debug printing to find cause of crash (Issue 1374)
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.target" Nat
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCM Doc
"new split clause telescope   : " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
sctel'
      ]
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.target" Nat
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCM Doc
"new split clause patterns    : " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do
          Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
sctel' (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg DeBruijnPattern] -> TCM Doc)
-> [NamedArg DeBruijnPattern] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps'
      ]
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.target" Nat
60 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCM Doc
"new split clause substitution: " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' SplitPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (SplitClause -> Substitution' SplitPattern
scSubst SplitClause
sc')
      ]
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.target" Nat
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCM Doc
"new split clause target      : " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do
          Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
sctel' (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Dom Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Dom Type -> TCM Doc) -> Dom Type -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Maybe (Dom Type) -> Dom Type
forall a. HasCallStack => Maybe a -> a
fromJust Maybe (Dom Type)
newTarget
      ]
    VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.target" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCM Doc
"new split clause"
      , SplitClause -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM SplitClause
sc'
      ]
    (Telescope, SplitClause) -> TCM (Telescope, SplitClause)
forall (m :: * -> *) a. Monad m => a -> m a
return ((Telescope, SplitClause) -> TCM (Telescope, SplitClause))
-> (Telescope, SplitClause) -> TCM (Telescope, SplitClause)
forall a b. (a -> b) -> a -> b
$ if Nat
n Nat -> Nat -> Bool
forall a. Eq a => a -> a -> Bool
== Nat
0 then (Telescope
forall a. Null a => a
empty, SplitClause
sc { scTarget :: Maybe (Dom Type)
scTarget = Maybe (Dom Type)
newTarget }) else (Telescope
tel, SplitClause
sc')

-- Andreas, 2017-01-18, issue #819, set visible arguments to UserWritten.
-- Otherwise, they will be printed as _.
hiddenInserted :: ArgInfo -> ArgInfo
hiddenInserted :: ArgInfo -> ArgInfo
hiddenInserted ArgInfo
ai
  | ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
visible ArgInfo
ai = Origin -> ArgInfo -> ArgInfo
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
UserWritten ArgInfo
ai
  | Bool
otherwise  = Origin -> ArgInfo -> ArgInfo
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted ArgInfo
ai

computeHCompSplit  :: Telescope   -- ^ Telescope before split point.
  -> PatVarName                   -- ^ Name of pattern variable at split point.
  -> Telescope                    -- ^ Telescope after split point.
  -> QName                        -- ^ Name of datatype to split at.
  -> Args                         -- ^ Data type parameters.
  -> Args                         -- ^ Data type indices.
  -> Nat                          -- ^ Index of split variable.
  -> Telescope                    -- ^ Telescope for the patterns.
  -> [NamedArg SplitPattern]      -- ^ Patterns before doing the split.
  -> Map CheckpointId Substitution -- ^ Current checkpoints
  -- -> QName                        -- ^ Constructor to fit into hole.
  -> CoverM (Maybe (SplitTag,SplitClause))   -- ^ New split clause if successful.
computeHCompSplit :: Telescope
-> VerboseKey
-> Telescope
-> QName
-> Args
-> Args
-> Nat
-> Telescope
-> [NamedArg SplitPattern]
-> Map CheckpointId Substitution
-> CoverM (Maybe (SplitTag, SplitClause))
computeHCompSplit Telescope
delta1 VerboseKey
n Telescope
delta2 QName
d Args
pars Args
ixs Nat
hix Telescope
tel [NamedArg SplitPattern]
ps Map CheckpointId Substitution
cps = do
    -- Get the type of the datatype
  -- Δ1 ⊢ dtype
  Sort
dsort <- TCM Sort -> ExceptT SplitError TCM Sort
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Sort -> ExceptT SplitError TCM Sort)
-> TCM Sort -> ExceptT SplitError TCM Sort
forall a b. (a -> b) -> a -> b
$ ([Term] -> Substitution
forall a. DeBruijn a => [a] -> Substitution' a
parallelS ([Term] -> [Term]
forall a. [a] -> [a]
reverse ([Term] -> [Term]) -> [Term] -> [Term]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> Term) -> Args -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Term
forall e. Arg e -> e
unArg Args
pars) Substitution' (SubstArg Sort) -> Sort -> Sort
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
`applySubst`) (Sort -> Sort) -> (Definition -> Sort) -> Definition -> Sort
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defn -> Sort
dataSort (Defn -> Sort) -> (Definition -> Defn) -> Definition -> Sort
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Defn
theDef (Definition -> Sort) -> TCMT IO Definition -> TCM Sort
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
  QName
hCompName <- QName -> Maybe QName -> QName
forall a. a -> Maybe a -> a
fromMaybe QName
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe QName -> QName)
-> ExceptT SplitError TCM (Maybe QName)
-> ExceptT SplitError TCM QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> VerboseKey -> ExceptT SplitError TCM (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
VerboseKey -> m (Maybe QName)
getPrimitiveName' VerboseKey
builtinHComp
  Type
theHCompT <- Definition -> Type
defType (Definition -> Type)
-> ExceptT SplitError TCM Definition -> ExceptT SplitError TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ExceptT SplitError TCM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
hCompName
  let
    dlvl :: Term
dlvl = Level' Term -> Term
Level (Level' Term -> Term) -> (Sort -> Level' Term) -> Sort -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (\ (Type Level' Term
s) -> Level' Term
s) (Sort -> Term) -> Sort -> Term
forall a b. (a -> b) -> a -> b
$ Sort
dsort
    dterm :: Term
dterm = QName -> Elims -> Term
Def QName
d [] Term -> Args -> Term
forall t. Apply t => t -> Args -> t
`apply` (Args
pars Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ Args
ixs)
  -- Δ1 ⊢ gamma
  TelV Telescope
gamma Type
_ <- TCMT IO (TelV Type) -> ExceptT SplitError TCM (TelV Type)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO (TelV Type) -> ExceptT SplitError TCM (TelV Type))
-> TCMT IO (TelV Type) -> ExceptT SplitError TCM (TelV Type)
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView (Type
theHCompT Type -> Args -> Type
`piApply` [Hiding -> Arg Term -> Arg Term
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden (Arg Term -> Arg Term) -> Arg Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Term -> Arg Term
forall a. a -> Arg a
defaultArg (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Term
dlvl , Term -> Arg Term
forall a. a -> Arg a
defaultArg (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ Term
dterm])
  case (Telescope
delta1 Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
gamma,Substitution' DeBruijnPattern
forall a. Substitution' a
IdS) of
    (Telescope
delta1',Substitution' DeBruijnPattern
rho0) -> do
--      debugSubst "rho0" rho0

      -- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ
      let (Substitution' SplitPattern
rho1,Substitution' SplitPattern
rho2) = Nat
-> Substitution' SplitPattern
-> (Substitution' SplitPattern, Substitution' SplitPattern)
forall a.
Nat -> Substitution' a -> (Substitution' a, Substitution' a)
splitS (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
gamma) (Substitution' SplitPattern
 -> (Substitution' SplitPattern, Substitution' SplitPattern))
-> Substitution' SplitPattern
-> (Substitution' SplitPattern, Substitution' SplitPattern)
forall a b. (a -> b) -> a -> b
$ Substitution' DeBruijnPattern -> Substitution' SplitPattern
toSplitPSubst Substitution' DeBruijnPattern
rho0

      let defp :: SplitPattern
defp = PatternInfo -> QName -> [NamedArg SplitPattern] -> SplitPattern
forall x.
PatternInfo -> QName -> [NamedArg (Pattern' x)] -> Pattern' x
DefP PatternInfo
defaultPatternInfo QName
hCompName ([NamedArg SplitPattern] -> SplitPattern)
-> ([NamedArg SplitPattern] -> [NamedArg SplitPattern])
-> [NamedArg SplitPattern]
-> SplitPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (NamedArg SplitPattern -> NamedArg SplitPattern)
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> [a] -> [b]
map (Origin -> NamedArg SplitPattern -> NamedArg SplitPattern
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted) ([NamedArg SplitPattern] -> SplitPattern)
-> [NamedArg SplitPattern] -> SplitPattern
forall a b. (a -> b) -> a -> b
$
                   (Arg SplitPattern -> NamedArg SplitPattern)
-> [Arg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> [a] -> [b]
map ((SplitPattern -> Named NamedName SplitPattern)
-> Arg SplitPattern -> NamedArg SplitPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SplitPattern -> Named NamedName SplitPattern
forall a name. a -> Named name a
unnamed) [Hiding -> Arg SplitPattern -> Arg SplitPattern
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden (Arg SplitPattern -> Arg SplitPattern)
-> Arg SplitPattern -> Arg SplitPattern
forall a b. (a -> b) -> a -> b
$ SplitPattern -> Arg SplitPattern
forall a. a -> Arg a
defaultArg (SplitPattern -> Arg SplitPattern)
-> SplitPattern -> Arg SplitPattern
forall a b. (a -> b) -> a -> b
$ Substitution' (SubstArg SplitPattern)
-> SplitPattern -> SplitPattern
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' SplitPattern
Substitution' (SubstArg SplitPattern)
rho1 (SplitPattern -> SplitPattern) -> SplitPattern -> SplitPattern
forall a b. (a -> b) -> a -> b
$ PatternInfo -> Term -> SplitPattern
forall x. PatternInfo -> Term -> Pattern' x
DotP PatternInfo
defaultPatternInfo (Term -> SplitPattern) -> Term -> SplitPattern
forall a b. (a -> b) -> a -> b
$ Term
dlvl
                                      ,Hiding -> Arg SplitPattern -> Arg SplitPattern
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
Hidden (Arg SplitPattern -> Arg SplitPattern)
-> Arg SplitPattern -> Arg SplitPattern
forall a b. (a -> b) -> a -> b
$ SplitPattern -> Arg SplitPattern
forall a. a -> Arg a
defaultArg (SplitPattern -> Arg SplitPattern)
-> SplitPattern -> Arg SplitPattern
forall a b. (a -> b) -> a -> b
$ Substitution' (SubstArg SplitPattern)
-> SplitPattern -> SplitPattern
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' SplitPattern
Substitution' (SubstArg SplitPattern)
rho1 (SplitPattern -> SplitPattern) -> SplitPattern -> SplitPattern
forall a b. (a -> b) -> a -> b
$ PatternInfo -> Term -> SplitPattern
forall x. PatternInfo -> Term -> Pattern' x
DotP PatternInfo
defaultPatternInfo (Term -> SplitPattern) -> Term -> SplitPattern
forall a b. (a -> b) -> a -> b
$ Term
dterm]
                   [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++ Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' SplitPattern
Substitution' (SubstArg [NamedArg SplitPattern])
rho2 (Telescope -> [NamedArg SplitPattern]
forall a. DeBruijn a => Telescope -> [NamedArg a]
teleNamedArgs Telescope
gamma) -- rho0?
      -- Compute final context and substitution
      let rho3 :: Substitution' SplitPattern
rho3    = SplitPattern
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS SplitPattern
defp Substitution' SplitPattern
rho1            -- Δ₁' ⊢ ρ₃ : Δ₁(x:D)
          delta2' :: Telescope
delta2' = Substitution' SplitPattern -> Telescope -> Telescope
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
rho3 Telescope
delta2  -- Δ₂' = Δ₂ρ₃
          delta' :: Telescope
delta'  = Telescope
delta1' Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
delta2' -- Δ'  = Δ₁'Δ₂'
          rho :: Substitution' SplitPattern
rho     = Nat -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Nat -> Substitution' a -> Substitution' a
liftS (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
delta2) Substitution' SplitPattern
rho3   -- Δ' ⊢ ρ : Δ₁(x:D)Δ₂

      -- debugTel "delta'" delta'
      -- debugSubst "rho" rho
      -- debugPs tel ps

      -- Apply the substitution
      let ps' :: [NamedArg SplitPattern]
ps' = Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' SplitPattern
Substitution' (SubstArg [NamedArg SplitPattern])
rho [NamedArg SplitPattern]
ps
      -- debugPlugged delta' ps'

      let cps' :: Map CheckpointId Substitution
cps' = Substitution' SplitPattern
-> Map CheckpointId Substitution -> Map CheckpointId Substitution
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
rho Map CheckpointId Substitution
cps

      Maybe (SplitTag, SplitClause)
-> CoverM (Maybe (SplitTag, SplitClause))
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (SplitTag, SplitClause)
 -> CoverM (Maybe (SplitTag, SplitClause)))
-> Maybe (SplitTag, SplitClause)
-> CoverM (Maybe (SplitTag, SplitClause))
forall a b. (a -> b) -> a -> b
$ (SplitTag, SplitClause) -> Maybe (SplitTag, SplitClause)
forall a. a -> Maybe a
Just ((SplitTag, SplitClause) -> Maybe (SplitTag, SplitClause))
-> (SplitClause -> (SplitTag, SplitClause))
-> SplitClause
-> Maybe (SplitTag, SplitClause)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName -> SplitTag
SplitCon QName
hCompName,) (SplitClause -> Maybe (SplitTag, SplitClause))
-> SplitClause -> Maybe (SplitTag, SplitClause)
forall a b. (a -> b) -> a -> b
$ Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause Telescope
delta' [NamedArg SplitPattern]
ps' Substitution' SplitPattern
rho Map CheckpointId Substitution
cps' Maybe (Dom Type)
forall a. Maybe a
Nothing -- target fixed later



-- | @computeNeighbourhood delta1 delta2 d pars ixs hix tel ps con@
--
--   @
--      delta1   Telescope before split point
--      n        Name of pattern variable at split point
--      delta2   Telescope after split point
--      d        Name of datatype to split at
--      pars     Data type parameters
--      ixs      Data type indices
--      hix      Index of split variable
--      tel      Telescope for patterns ps
--      ps       Patterns before doing the split
--      cps      Current module parameter checkpoints
--      con      Constructor to fit into hole
--   @
--   @dtype == d pars ixs@
computeNeighbourhood
  :: Telescope                    -- ^ Telescope before split point.
  -> PatVarName                   -- ^ Name of pattern variable at split point.
  -> Telescope                    -- ^ Telescope after split point.
  -> QName                        -- ^ Name of datatype to split at.
  -> Args                         -- ^ Data type parameters.
  -> Args                         -- ^ Data type indices.
  -> Nat                          -- ^ Index of split variable.
  -> Telescope                    -- ^ Telescope for the patterns.
  -> [NamedArg SplitPattern]      -- ^ Patterns before doing the split.
  -> Map CheckpointId Substitution -- ^ Current checkpoints
  -> QName                        -- ^ Constructor to fit into hole.
  -> CoverM (Maybe SplitClause)   -- ^ New split clause if successful.
computeNeighbourhood :: Telescope
-> VerboseKey
-> Telescope
-> QName
-> Args
-> Args
-> Nat
-> Telescope
-> [NamedArg SplitPattern]
-> Map CheckpointId Substitution
-> QName
-> CoverM (Maybe SplitClause)
computeNeighbourhood Telescope
delta1 VerboseKey
n Telescope
delta2 QName
d Args
pars Args
ixs Nat
hix Telescope
tel [NamedArg SplitPattern]
ps Map CheckpointId Substitution
cps QName
c = do

  -- Get the type of the datatype
  Type
dtype <- TCM Type -> ExceptT SplitError TCM Type
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Type -> ExceptT SplitError TCM Type)
-> TCM Type -> ExceptT SplitError TCM Type
forall a b. (a -> b) -> a -> b
$ (Type -> Args -> Type
`piApply` Args
pars) (Type -> Type) -> (Definition -> Type) -> Definition -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType (Definition -> Type) -> TCMT IO Definition -> TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d

  -- Get the real constructor name
  ConHead
con <- TCM ConHead -> ExceptT SplitError TCM ConHead
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM ConHead -> ExceptT SplitError TCM ConHead)
-> TCM ConHead -> ExceptT SplitError TCM ConHead
forall a b. (a -> b) -> a -> b
$ (SigError -> ConHead) -> Either SigError ConHead -> ConHead
forall a b. (a -> b) -> Either a b -> b
fromRight SigError -> ConHead
forall a. HasCallStack => a
__IMPOSSIBLE__ (Either SigError ConHead -> ConHead)
-> TCMT IO (Either SigError ConHead) -> TCM ConHead
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO (Either SigError ConHead)
getConForm QName
c
  ConHead
con <- ConHead -> ExceptT SplitError TCM ConHead
forall (m :: * -> *) a. Monad m => a -> m a
return (ConHead -> ExceptT SplitError TCM ConHead)
-> ConHead -> ExceptT SplitError TCM ConHead
forall a b. (a -> b) -> a -> b
$ ConHead
con { conName :: QName
conName = QName
c }  -- What if we restore the current name?
                                       -- Andreas, 2013-11-29 changes nothing!

  -- Get the type of the constructor
  Type
ctype <- TCM Type -> ExceptT SplitError TCM Type
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Type -> ExceptT SplitError TCM Type)
-> TCM Type -> ExceptT SplitError TCM Type
forall a b. (a -> b) -> a -> b
$ Definition -> Type
defType (Definition -> Type) -> TCMT IO Definition -> TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConHead -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => ConHead -> m Definition
getConInfo ConHead
con

  -- Lookup the type of the constructor at the given parameters
  (Telescope
gamma0, Args
cixs, [(Term, (Term, Term))]
boundary) <- do
    (TelV Telescope
gamma0 (El Sort
_ Term
d), [(Term, (Term, Term))]
boundary) <- TCM (TelV Type, [(Term, (Term, Term))])
-> ExceptT SplitError TCM (TelV Type, [(Term, (Term, Term))])
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (TelV Type, [(Term, (Term, Term))])
 -> ExceptT SplitError TCM (TelV Type, [(Term, (Term, Term))]))
-> TCM (TelV Type, [(Term, (Term, Term))])
-> ExceptT SplitError TCM (TelV Type, [(Term, (Term, Term))])
forall a b. (a -> b) -> a -> b
$ Type -> TCM (TelV Type, [(Term, (Term, Term))])
forall (m :: * -> *).
PureTCM m =>
Type -> m (TelV Type, [(Term, (Term, Term))])
telViewPathBoundaryP (Type
ctype Type -> Args -> Type
`piApply` Args
pars)
    let Def QName
_ Elims
es = Term
d
        Just Args
cixs = Elims -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
    (Telescope, Args, [(Term, (Term, Term))])
-> ExceptT SplitError TCM (Telescope, Args, [(Term, (Term, Term))])
forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope
gamma0, Args
cixs, [(Term, (Term, Term))]
boundary)

  let (ListTel
_, Dom{domInfo :: forall t e. Dom' t e -> ArgInfo
domInfo = ArgInfo
info} : ListTel
_) = Nat -> ListTel -> (ListTel, ListTel)
forall a. Nat -> [a] -> ([a], [a])
splitAt (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
hix Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1) (Telescope -> ListTel
forall t. Tele (Dom t) -> [Dom (VerboseKey, t)]
telToList Telescope
tel)

  -- Andreas, 2012-02-25 preserve name suggestion for recursive arguments
  -- of constructor

  let preserve :: (VerboseKey, Type) -> (VerboseKey, Type)
preserve (VerboseKey
x, t :: Type
t@(El Sort
_ (Def QName
d' Elims
_))) | QName
d QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
d' = (VerboseKey
n, Type
t)
      preserve (VerboseKey
x, Type
t) = (VerboseKey
x, Type
t)
      gamma :: Telescope
gamma  = ((Dom Type -> Dom Type) -> Telescope -> Telescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Dom Type -> Dom Type) -> Telescope -> Telescope)
-> ((Modality -> Modality) -> Dom Type -> Dom Type)
-> (Modality -> Modality)
-> Telescope
-> Telescope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Modality -> Modality) -> Dom Type -> Dom Type
forall a. LensModality a => (Modality -> Modality) -> a -> a
mapModality) (Modality -> Modality -> Modality
composeModality (ArgInfo -> Modality
forall a. LensModality a => a -> Modality
getModality ArgInfo
info)) (Telescope -> Telescope) -> Telescope -> Telescope
forall a b. (a -> b) -> a -> b
$ ListTel -> Telescope
telFromList (ListTel -> Telescope)
-> (Telescope -> ListTel) -> Telescope -> Telescope
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dom' Term (VerboseKey, Type) -> Dom' Term (VerboseKey, Type))
-> ListTel -> ListTel
forall a b. (a -> b) -> [a] -> [b]
map (((VerboseKey, Type) -> (VerboseKey, Type))
-> Dom' Term (VerboseKey, Type) -> Dom' Term (VerboseKey, Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (VerboseKey, Type) -> (VerboseKey, Type)
preserve) (ListTel -> ListTel)
-> (Telescope -> ListTel) -> Telescope -> ListTel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> ListTel
forall t. Tele (Dom t) -> [Dom (VerboseKey, t)]
telToList (Telescope -> Telescope) -> Telescope -> Telescope
forall a b. (a -> b) -> a -> b
$ Telescope
gamma0
      delta1Gamma :: Telescope
delta1Gamma = Telescope
delta1 Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
gamma

  ConHead
-> Type
-> QName
-> Args
-> Args
-> Args
-> Telescope
-> Telescope
-> Telescope
-> Telescope
-> [NamedArg SplitPattern]
-> Nat
-> ExceptT SplitError TCM ()
forall (tcm :: * -> *) a a a a a a a a a a a.
(MonadTCM tcm, AddContext a, AddContext a, AddContext a,
 PrettyTCM a, PrettyTCM a, PrettyTCM a, PrettyTCM a, PrettyTCM a,
 PrettyTCM a, PrettyTCM a, PrettyTCM a, PrettyTCM a, PrettyTCM a,
 Show a, Show a, Show a, Show a, Show a, Show a, Show a, Show a,
 Show a, Show a) =>
a
-> a
-> a
-> [a]
-> [a]
-> [a]
-> a
-> a
-> a
-> a
-> [NamedArg SplitPattern]
-> a
-> tcm ()
debugInit ConHead
con Type
ctype QName
d Args
pars Args
ixs Args
cixs Telescope
delta1 Telescope
delta2 Telescope
gamma Telescope
tel [NamedArg SplitPattern]
ps Nat
hix

  [IsForced]
cforced <- Definition -> [IsForced]
defForced (Definition -> [IsForced])
-> ExceptT SplitError TCM Definition
-> ExceptT SplitError TCM [IsForced]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ExceptT SplitError TCM Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
c
      -- Variables in Δ₁ are not forced, since the unifier takes care to not introduce forced
      -- variables.
  let forced :: [IsForced]
forced = Nat -> IsForced -> [IsForced]
forall a. Nat -> a -> [a]
replicate (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
delta1) IsForced
NotForced [IsForced] -> [IsForced] -> [IsForced]
forall a. [a] -> [a] -> [a]
++ [IsForced]
cforced
      flex :: FlexibleVars
flex   = [IsForced] -> Telescope -> FlexibleVars
allFlexVars [IsForced]
forced Telescope
delta1Gamma -- All variables are flexible

  -- Unify constructor target and given type (in Δ₁Γ)
  let conIxs :: Args
conIxs   = Nat -> Args -> Args
forall a. Nat -> [a] -> [a]
drop (Args -> Nat
forall a. Sized a => a -> Nat
size Args
pars) Args
cixs
      givenIxs :: Args
givenIxs = Nat -> Args -> Args
forall a. Subst a => Nat -> a -> a
raise (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
gamma) Args
ixs

  -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope
  -- TODO: should we propagate the modality in general?
  -- See also LHS checking.
  Type
dtype <- do
         let updCoh :: Cohesion -> Cohesion
updCoh = Cohesion -> Cohesion -> Cohesion
composeCohesion (ArgInfo -> Cohesion
forall a. LensCohesion a => a -> Cohesion
getCohesion ArgInfo
info)
         TelV Telescope
dtel Type
dt <- Type -> ExceptT SplitError TCM (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView Type
dtype
         Type -> ExceptT SplitError TCM Type
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> ExceptT SplitError TCM Type)
-> Type -> ExceptT SplitError TCM Type
forall a b. (a -> b) -> a -> b
$ Telescope -> Type -> Type
forall t. Abstract t => Telescope -> t -> t
abstract ((Cohesion -> Cohesion) -> Dom Type -> Dom Type
forall a. LensCohesion a => (Cohesion -> Cohesion) -> a -> a
mapCohesion Cohesion -> Cohesion
updCoh (Dom Type -> Dom Type) -> Telescope -> Telescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope
dtel) Type
dt

  ExceptT SplitError TCM UnificationResult
-> ExceptT SplitError TCM UnificationResult
withKIfStrict <- Telescope
-> ExceptT
     SplitError
     TCM
     (ExceptT SplitError TCM UnificationResult
      -> ExceptT SplitError TCM UnificationResult)
-> ExceptT
     SplitError
     TCM
     (ExceptT SplitError TCM UnificationResult
      -> ExceptT SplitError TCM UnificationResult)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 (ExceptT
   SplitError
   TCM
   (ExceptT SplitError TCM UnificationResult
    -> ExceptT SplitError TCM UnificationResult)
 -> ExceptT
      SplitError
      TCM
      (ExceptT SplitError TCM UnificationResult
       -> ExceptT SplitError TCM UnificationResult))
-> ExceptT
     SplitError
     TCM
     (ExceptT SplitError TCM UnificationResult
      -> ExceptT SplitError TCM UnificationResult)
-> ExceptT
     SplitError
     TCM
     (ExceptT SplitError TCM UnificationResult
      -> ExceptT SplitError TCM UnificationResult)
forall a b. (a -> b) -> a -> b
$ Sort -> ExceptT SplitError TCM Sort
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Type -> Sort
forall a. LensSort a => a -> Sort
getSort Type
dtype) ExceptT SplitError TCM Sort
-> (Sort
    -> ExceptT
         SplitError
         TCM
         (ExceptT SplitError TCM UnificationResult
          -> ExceptT SplitError TCM UnificationResult))
-> ExceptT
     SplitError
     TCM
     (ExceptT SplitError TCM UnificationResult
      -> ExceptT SplitError TCM UnificationResult)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    SSet{} -> (ExceptT SplitError TCM UnificationResult
 -> ExceptT SplitError TCM UnificationResult)
-> ExceptT
     SplitError
     TCM
     (ExceptT SplitError TCM UnificationResult
      -> ExceptT SplitError TCM UnificationResult)
forall (m :: * -> *) a. Monad m => a -> m a
return ((ExceptT SplitError TCM UnificationResult
  -> ExceptT SplitError TCM UnificationResult)
 -> ExceptT
      SplitError
      TCM
      (ExceptT SplitError TCM UnificationResult
       -> ExceptT SplitError TCM UnificationResult))
-> (ExceptT SplitError TCM UnificationResult
    -> ExceptT SplitError TCM UnificationResult)
-> ExceptT
     SplitError
     TCM
     (ExceptT SplitError TCM UnificationResult
      -> ExceptT SplitError TCM UnificationResult)
forall a b. (a -> b) -> a -> b
$ Lens' Bool TCEnv
-> (Bool -> Bool)
-> ExceptT SplitError TCM UnificationResult
-> ExceptT SplitError TCM UnificationResult
forall (m :: * -> *) a b.
MonadTCEnv m =>
Lens' a TCEnv -> (a -> a) -> m b -> m b
locallyTC Lens' Bool TCEnv
eSplitOnStrict ((Bool -> Bool)
 -> ExceptT SplitError TCM UnificationResult
 -> ExceptT SplitError TCM UnificationResult)
-> (Bool -> Bool)
-> ExceptT SplitError TCM UnificationResult
-> ExceptT SplitError TCM UnificationResult
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
True
    Sort
_      -> (ExceptT SplitError TCM UnificationResult
 -> ExceptT SplitError TCM UnificationResult)
-> ExceptT
     SplitError
     TCM
     (ExceptT SplitError TCM UnificationResult
      -> ExceptT SplitError TCM UnificationResult)
forall (m :: * -> *) a. Monad m => a -> m a
return ExceptT SplitError TCM UnificationResult
-> ExceptT SplitError TCM UnificationResult
forall a. a -> a
id

  UnificationResult
r <- ExceptT SplitError TCM UnificationResult
-> ExceptT SplitError TCM UnificationResult
withKIfStrict (ExceptT SplitError TCM UnificationResult
 -> ExceptT SplitError TCM UnificationResult)
-> ExceptT SplitError TCM UnificationResult
-> ExceptT SplitError TCM UnificationResult
forall a b. (a -> b) -> a -> b
$ Telescope
-> FlexibleVars
-> Type
-> Args
-> Args
-> ExceptT SplitError TCM UnificationResult
forall (m :: * -> *).
(PureTCM m, MonadBench m, BenchPhase m ~ Phase) =>
Telescope
-> FlexibleVars -> Type -> Args -> Args -> m UnificationResult
unifyIndices
         Telescope
delta1Gamma
         FlexibleVars
flex
         (Nat -> Type -> Type
forall a. Subst a => Nat -> a -> a
raise (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
gamma) Type
dtype)
         Args
conIxs
         Args
givenIxs

  let stuck :: Maybe Blocker -> [UnificationFailure] -> CoverM (Maybe SplitClause)
stuck Maybe Blocker
b [UnificationFailure]
errs = do
        ExceptT SplitError TCM ()
debugCantSplit
        SplitError -> CoverM (Maybe SplitClause)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SplitError -> CoverM (Maybe SplitClause))
-> SplitError -> CoverM (Maybe SplitClause)
forall a b. (a -> b) -> a -> b
$ Maybe Blocker
-> QName
-> Telescope
-> Args
-> Args
-> [UnificationFailure]
-> SplitError
UnificationStuck Maybe Blocker
b (ConHead -> QName
conName ConHead
con) (Telescope
delta1 Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
gamma) Args
conIxs Args
givenIxs [UnificationFailure]
errs


  case UnificationResult
r of
    NoUnify {} -> ExceptT SplitError TCM ()
debugNoUnify ExceptT SplitError TCM ()
-> Maybe SplitClause -> CoverM (Maybe SplitClause)
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe SplitClause
forall a. Maybe a
Nothing

    UnifyBlocked Blocker
block -> Maybe Blocker -> [UnificationFailure] -> CoverM (Maybe SplitClause)
stuck (Blocker -> Maybe Blocker
forall a. a -> Maybe a
Just Blocker
block) []

    UnifyStuck [UnificationFailure]
errs -> Maybe Blocker -> [UnificationFailure] -> CoverM (Maybe SplitClause)
stuck Maybe Blocker
forall a. Maybe a
Nothing [UnificationFailure]
errs

    Unifies (Telescope
delta1',Substitution' DeBruijnPattern
rho0,[NamedArg DeBruijnPattern]
_) -> do
      VerboseKey
-> Substitution' DeBruijnPattern -> ExceptT SplitError TCM ()
forall (tcm :: * -> *) a.
(MonadTCM tcm, PrettyTCM a) =>
VerboseKey -> a -> tcm ()
debugSubst VerboseKey
"rho0" Substitution' DeBruijnPattern
rho0

      let rho0' :: Substitution' SplitPattern
rho0' = Substitution' DeBruijnPattern -> Substitution' SplitPattern
toSplitPSubst Substitution' DeBruijnPattern
rho0

      -- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ
      let (Substitution' SplitPattern
rho1,Substitution' SplitPattern
rho2) = Nat
-> Substitution' SplitPattern
-> (Substitution' SplitPattern, Substitution' SplitPattern)
forall a.
Nat -> Substitution' a -> (Substitution' a, Substitution' a)
splitS (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
gamma) (Substitution' SplitPattern
 -> (Substitution' SplitPattern, Substitution' SplitPattern))
-> Substitution' SplitPattern
-> (Substitution' SplitPattern, Substitution' SplitPattern)
forall a b. (a -> b) -> a -> b
$ Substitution' SplitPattern
rho0'

      -- Andreas, 2015-05-01  I guess it is fine to use no @conPType@
      -- as the result of splitting is never used further down the pipeline.
      -- After splitting, Agda reloads the file.
      -- Andreas, 2017-09-03, issue #2729: remember that pattern was generated by case split.
      let cpi :: ConPatternInfo
cpi  = ConPatternInfo
noConPatternInfo{ conPInfo :: PatternInfo
conPInfo = PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatOSplit [] , conPRecord :: Bool
conPRecord = Bool
True }
          conp :: SplitPattern
conp = ConHead
-> ConPatternInfo -> [NamedArg SplitPattern] -> SplitPattern
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
con ConPatternInfo
cpi ([NamedArg SplitPattern] -> SplitPattern)
-> [NamedArg SplitPattern] -> SplitPattern
forall a b. (a -> b) -> a -> b
$ Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' SplitPattern
Substitution' (SubstArg [NamedArg SplitPattern])
rho0' ([NamedArg SplitPattern] -> [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> a -> b
$
                   (NamedArg SplitPattern -> NamedArg SplitPattern)
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> [a] -> [b]
map ((ArgInfo -> ArgInfo)
-> NamedArg SplitPattern -> NamedArg SplitPattern
forall a. LensArgInfo a => (ArgInfo -> ArgInfo) -> a -> a
mapArgInfo ArgInfo -> ArgInfo
hiddenInserted) ([NamedArg SplitPattern] -> [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> a -> b
$ (forall a. DeBruijn a => Telescope -> [NamedArg a])
-> Telescope -> [(Term, (Term, Term))] -> [NamedArg SplitPattern]
forall a.
DeBruijn a =>
(forall a. DeBruijn a => Telescope -> [NamedArg a])
-> Telescope -> [(Term, (Term, Term))] -> [NamedArg (Pattern' a)]
telePatterns' (Telescope -> Telescope -> [NamedArg a1]
forall a. DeBruijn a => Telescope -> Telescope -> [NamedArg a]
tele2NamedArgs Telescope
gamma0) Telescope
gamma [(Term, (Term, Term))]
boundary
          -- Andreas, 2016-09-08, issue #2166: use gamma0 for correct argument names

      -- Compute final context and substitution
      let rho3 :: Substitution' SplitPattern
rho3    = SplitPattern
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS SplitPattern
conp Substitution' SplitPattern
rho1            -- Δ₁' ⊢ ρ₃ : Δ₁(x:D)
          delta2' :: Telescope
delta2' = Substitution' SplitPattern -> Telescope -> Telescope
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
rho3 Telescope
delta2  -- Δ₂' = Δ₂ρ₃
          delta' :: Telescope
delta'  = Telescope
delta1' Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
delta2' -- Δ'  = Δ₁'Δ₂'
          rho :: Substitution' SplitPattern
rho     = Nat -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Nat -> Substitution' a -> Substitution' a
liftS (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
delta2) Substitution' SplitPattern
rho3   -- Δ' ⊢ ρ : Δ₁(x:D)Δ₂

      VerboseKey -> Telescope -> ExceptT SplitError TCM ()
forall (tcm :: * -> *) a.
(MonadTCM tcm, PrettyTCM a) =>
VerboseKey -> a -> tcm ()
debugTel VerboseKey
"delta'" Telescope
delta'
      VerboseKey
-> Substitution' SplitPattern -> ExceptT SplitError TCM ()
forall (tcm :: * -> *) a.
(MonadTCM tcm, PrettyTCM a) =>
VerboseKey -> a -> tcm ()
debugSubst VerboseKey
"rho" Substitution' SplitPattern
rho
      Telescope -> [NamedArg SplitPattern] -> ExceptT SplitError TCM ()
forall (tcm :: * -> *) b.
(MonadTCM tcm, AddContext b) =>
b -> [NamedArg SplitPattern] -> tcm ()
debugPs Telescope
tel [NamedArg SplitPattern]
ps

      -- Apply the substitution
      let ps' :: [NamedArg SplitPattern]
ps' = Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' SplitPattern
Substitution' (SubstArg [NamedArg SplitPattern])
rho [NamedArg SplitPattern]
ps
      Telescope -> [NamedArg SplitPattern] -> ExceptT SplitError TCM ()
forall (tcm :: * -> *) b.
(MonadTCM tcm, AddContext b) =>
b -> [NamedArg SplitPattern] -> tcm ()
debugPlugged Telescope
delta' [NamedArg SplitPattern]
ps'

      let cps' :: Map CheckpointId Substitution
cps'  = Substitution' SplitPattern
-> Map CheckpointId Substitution -> Map CheckpointId Substitution
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
rho Map CheckpointId Substitution
cps

      Maybe SplitClause -> CoverM (Maybe SplitClause)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SplitClause -> CoverM (Maybe SplitClause))
-> Maybe SplitClause -> CoverM (Maybe SplitClause)
forall a b. (a -> b) -> a -> b
$ SplitClause -> Maybe SplitClause
forall a. a -> Maybe a
Just (SplitClause -> Maybe SplitClause)
-> SplitClause -> Maybe SplitClause
forall a b. (a -> b) -> a -> b
$ Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause Telescope
delta' [NamedArg SplitPattern]
ps' Substitution' SplitPattern
rho Map CheckpointId Substitution
cps' Maybe (Dom Type)
forall a. Maybe a
Nothing -- target fixed later

  where
    debugInit :: a
-> a
-> a
-> [a]
-> [a]
-> [a]
-> a
-> a
-> a
-> a
-> [NamedArg SplitPattern]
-> a
-> tcm ()
debugInit a
con a
ctype a
d [a]
pars [a]
ixs [a]
cixs a
delta1 a
delta2 a
gamma a
tel [NamedArg SplitPattern]
ps a
hix = TCMT IO () -> tcm ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ do
      VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.split.con" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCM Doc
"computeNeighbourhood"
        , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCM Doc
"context=" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc)
-> (Telescope -> TCM Doc) -> Telescope -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Telescope -> TCM Doc) -> TCM Telescope -> TCM Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCM Telescope
forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Telescope
getContextTelescope)
          , TCM Doc
"con    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
con
          , TCM Doc
"ctype  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
ctype
          , TCM Doc
"ps     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ a -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext a
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg DeBruijnPattern] -> TCM Doc)
-> [NamedArg DeBruijnPattern] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps
          , TCM Doc
"d      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
d
          , TCM Doc
"pars   =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ (a -> TCM Doc) -> [a] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [a]
pars
          , TCM Doc
"ixs    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do a -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext a
delta1 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ (a -> TCM Doc) -> [a] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [a]
ixs
          , TCM Doc
"cixs   =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do a -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext a
gamma  (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ (a -> TCM Doc) -> [a] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [a]
cixs
          , TCM Doc
"delta1 =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
delta1
          , TCM Doc
"delta2 =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ a -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext a
delta1 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ a -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext a
gamma (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
delta2
          , TCM Doc
"gamma  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ a -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext a
delta1 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
gamma
          , TCM Doc
"tel  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
tel
          , TCM Doc
"hix    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (a -> VerboseKey
forall a. Show a => a -> VerboseKey
show a
hix)
          ]
        ]
      VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.split.con" Nat
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCM Doc
"computeNeighbourhood"
        , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCM Doc
"context=" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc)
-> (Telescope -> TCM Doc) -> Telescope -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc)
-> (Telescope -> VerboseKey) -> Telescope -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Telescope -> VerboseKey
forall a. Show a => a -> VerboseKey
show) (Telescope -> TCM Doc) -> TCM Telescope -> TCM Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCM Telescope
forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Telescope
getContextTelescope)
          , TCM Doc
"con    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (a -> VerboseKey) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> VerboseKey
forall a. Show a => a -> VerboseKey
show) a
con
          , TCM Doc
"ctype  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (a -> VerboseKey) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> VerboseKey
forall a. Show a => a -> VerboseKey
show) a
ctype
          , TCM Doc
"ps     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc)
-> ([NamedArg SplitPattern] -> VerboseKey)
-> [NamedArg SplitPattern]
-> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NamedArg SplitPattern] -> VerboseKey
forall a. Show a => a -> VerboseKey
show) [NamedArg SplitPattern]
ps
          , TCM Doc
"d      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (a -> VerboseKey) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> VerboseKey
forall a. Show a => a -> VerboseKey
show) a
d
          , TCM Doc
"pars   =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> ([a] -> VerboseKey) -> [a] -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> VerboseKey
forall a. Show a => a -> VerboseKey
show) [a]
pars
          , TCM Doc
"ixs    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> ([a] -> VerboseKey) -> [a] -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> VerboseKey
forall a. Show a => a -> VerboseKey
show) [a]
ixs
          , TCM Doc
"cixs   =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> ([a] -> VerboseKey) -> [a] -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [a] -> VerboseKey
forall a. Show a => a -> VerboseKey
show) [a]
cixs
          , TCM Doc
"delta1 =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (a -> VerboseKey) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> VerboseKey
forall a. Show a => a -> VerboseKey
show) a
delta1
          , TCM Doc
"delta2 =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (a -> VerboseKey) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> VerboseKey
forall a. Show a => a -> VerboseKey
show) a
delta2
          , TCM Doc
"gamma  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (a -> VerboseKey) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> VerboseKey
forall a. Show a => a -> VerboseKey
show) a
gamma
          , TCM Doc
"hix    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (a -> VerboseKey
forall a. Show a => a -> VerboseKey
show a
hix)
          ]
        ]

    debugNoUnify :: ExceptT SplitError TCM ()
debugNoUnify =
      TCMT IO () -> ExceptT SplitError TCM ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> ExceptT SplitError TCM ())
-> TCMT IO () -> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.split.con" Nat
20 VerboseKey
"  Constructor impossible!"

    debugCantSplit :: ExceptT SplitError TCM ()
debugCantSplit =
      TCMT IO () -> ExceptT SplitError TCM ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> ExceptT SplitError TCM ())
-> TCMT IO () -> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Nat -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.split.con" Nat
20 VerboseKey
"  Bad split!"

    debugSubst :: VerboseKey -> a -> tcm ()
debugSubst VerboseKey
s a
sub =
      TCMT IO () -> tcm ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.split.con" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey
s VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseKey
" =") TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
sub
        ]

    debugTel :: VerboseKey -> a -> tcm ()
debugTel VerboseKey
s a
tel =
      TCMT IO () -> tcm ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.split.con" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey
s VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseKey
" =") TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
tel
        ]

    debugPs :: b -> [NamedArg SplitPattern] -> tcm ()
debugPs b
tel [NamedArg SplitPattern]
ps =
      TCMT IO () -> tcm ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.split.con" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ b -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext b
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCM Doc
"ps     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps)
          ]

    debugPlugged :: b -> [NamedArg SplitPattern] -> tcm ()
debugPlugged b
delta' [NamedArg SplitPattern]
ps' = do
      TCMT IO () -> tcm ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.split.con" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ b -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext b
delta' (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCM Doc
"ps'    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg DeBruijnPattern] -> TCM Doc)
-> [NamedArg DeBruijnPattern] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps'
          ]

-- | Introduce trailing pattern variables?
data InsertTrailing
  = DoInsertTrailing
  | DontInsertTrailing
  deriving (InsertTrailing -> InsertTrailing -> Bool
(InsertTrailing -> InsertTrailing -> Bool)
-> (InsertTrailing -> InsertTrailing -> Bool) -> Eq InsertTrailing
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: InsertTrailing -> InsertTrailing -> Bool
$c/= :: InsertTrailing -> InsertTrailing -> Bool
== :: InsertTrailing -> InsertTrailing -> Bool
$c== :: InsertTrailing -> InsertTrailing -> Bool
Eq, Nat -> InsertTrailing -> VerboseKey -> VerboseKey
[InsertTrailing] -> VerboseKey -> VerboseKey
InsertTrailing -> VerboseKey
(Nat -> InsertTrailing -> VerboseKey -> VerboseKey)
-> (InsertTrailing -> VerboseKey)
-> ([InsertTrailing] -> VerboseKey -> VerboseKey)
-> Show InsertTrailing
forall a.
(Nat -> a -> VerboseKey -> VerboseKey)
-> (a -> VerboseKey) -> ([a] -> VerboseKey -> VerboseKey) -> Show a
showList :: [InsertTrailing] -> VerboseKey -> VerboseKey
$cshowList :: [InsertTrailing] -> VerboseKey -> VerboseKey
show :: InsertTrailing -> VerboseKey
$cshow :: InsertTrailing -> VerboseKey
showsPrec :: Nat -> InsertTrailing -> VerboseKey -> VerboseKey
$cshowsPrec :: Nat -> InsertTrailing -> VerboseKey -> VerboseKey
Show)

-- | Allow partial covering for split?
data AllowPartialCover
  = YesAllowPartialCover  -- To try to coverage-check incomplete splits.
  | NoAllowPartialCover   -- Default.
  deriving (AllowPartialCover -> AllowPartialCover -> Bool
(AllowPartialCover -> AllowPartialCover -> Bool)
-> (AllowPartialCover -> AllowPartialCover -> Bool)
-> Eq AllowPartialCover
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: AllowPartialCover -> AllowPartialCover -> Bool
$c/= :: AllowPartialCover -> AllowPartialCover -> Bool
== :: AllowPartialCover -> AllowPartialCover -> Bool
$c== :: AllowPartialCover -> AllowPartialCover -> Bool
Eq, Nat -> AllowPartialCover -> VerboseKey -> VerboseKey
[AllowPartialCover] -> VerboseKey -> VerboseKey
AllowPartialCover -> VerboseKey
(Nat -> AllowPartialCover -> VerboseKey -> VerboseKey)
-> (AllowPartialCover -> VerboseKey)
-> ([AllowPartialCover] -> VerboseKey -> VerboseKey)
-> Show AllowPartialCover
forall a.
(Nat -> a -> VerboseKey -> VerboseKey)
-> (a -> VerboseKey) -> ([a] -> VerboseKey -> VerboseKey) -> Show a
showList :: [AllowPartialCover] -> VerboseKey -> VerboseKey
$cshowList :: [AllowPartialCover] -> VerboseKey -> VerboseKey
show :: AllowPartialCover -> VerboseKey
$cshow :: AllowPartialCover -> VerboseKey
showsPrec :: Nat -> AllowPartialCover -> VerboseKey -> VerboseKey
$cshowsPrec :: Nat -> AllowPartialCover -> VerboseKey -> VerboseKey
Show)

-- | Entry point from @Interaction.MakeCase@.
splitClauseWithAbsurd :: SplitClause -> Nat -> TCM (Either SplitError (Either SplitClause Covering))
splitClauseWithAbsurd :: SplitClause
-> Nat -> TCM (Either SplitError (Either SplitClause Covering))
splitClauseWithAbsurd SplitClause
c Nat
x =
  CheckEmpty
-> Induction
-> AllowPartialCover
-> InsertTrailing
-> SplitClause
-> BlockingVar
-> TCM (Either SplitError (Either SplitClause Covering))
split' CheckEmpty
CheckEmpty Induction
Inductive AllowPartialCover
NoAllowPartialCover InsertTrailing
DontInsertTrailing SplitClause
c (Nat -> [ConHead] -> [Literal] -> Bool -> Bool -> BlockingVar
BlockingVar Nat
x [] [] Bool
True Bool
False)
  -- Andreas, 2016-05-03, issue 1950:
  -- Do not introduce trailing pattern vars after split,
  -- because this does not work for with-clauses.

-- | Entry point from @TypeChecking.Empty@ and @Interaction.BasicOps@.
--   @splitLast CoInductive@ is used in the @refine@ tactics.

splitLast :: Induction -> Telescope -> [NamedArg DeBruijnPattern] -> TCM (Either SplitError Covering)
splitLast :: Induction
-> Telescope
-> [NamedArg DeBruijnPattern]
-> TCMT IO (Either SplitError Covering)
splitLast Induction
ind Telescope
tel [NamedArg DeBruijnPattern]
ps = Induction
-> AllowPartialCover
-> SplitClause
-> BlockingVar
-> TCMT IO (Either SplitError Covering)
split Induction
ind AllowPartialCover
NoAllowPartialCover SplitClause
sc (Nat -> [ConHead] -> [Literal] -> Bool -> Bool -> BlockingVar
BlockingVar Nat
0 [] [] Bool
True Bool
False)
  where sc :: SplitClause
sc = Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause Telescope
tel ([NamedArg DeBruijnPattern] -> [NamedArg SplitPattern]
toSplitPatterns [NamedArg DeBruijnPattern]
ps) Substitution' SplitPattern
forall a. Null a => a
empty Map CheckpointId Substitution
forall a. Null a => a
empty Maybe (Dom Type)
forall t. Maybe (Dom (Type'' t Term))
target
        -- TODO 2ltt: allows (Empty_fib -> Empty_strict) which is not conservative
        target :: Maybe (Dom (Type'' t Term))
target = (Dom (Type'' t Term) -> Maybe (Dom (Type'' t Term))
forall a. a -> Maybe a
Just (Dom (Type'' t Term) -> Maybe (Dom (Type'' t Term)))
-> Dom (Type'' t Term) -> Maybe (Dom (Type'' t Term))
forall a b. (a -> b) -> a -> b
$ Type'' t Term -> Dom (Type'' t Term)
forall a. a -> Dom a
defaultDom (Type'' t Term -> Dom (Type'' t Term))
-> Type'' t Term -> Dom (Type'' t Term)
forall a b. (a -> b) -> a -> b
$ Sort' t -> Term -> Type'' t Term
forall t a. Sort' t -> a -> Type'' t a
El (Level' t -> Sort' t
forall t. Level' t -> Sort' t
Prop (Integer -> [PlusLevel' t] -> Level' t
forall t. Integer -> [PlusLevel' t] -> Level' t
Max Integer
0 [])) (Term -> Type'' t Term) -> Term -> Type'' t Term
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Elims -> Term
Dummy VerboseKey
"splitLastTarget" [])

-- | @split ind splitClause x = return res@
--   splits @splitClause@ at pattern var @x@ (de Bruijn index).
--
--   Possible results @res@ are:
--
--   1. @Left err@:
--      Splitting failed.
--
--   2. @Right covering@:
--      A covering set of split clauses, one for each valid constructor.
--      This could be the empty set (denoting an absurd clause).

split :: Induction
         -- ^ Coinductive constructors are allowed if this argument is
         -- 'CoInductive'.
      -> AllowPartialCover
         -- ^ Don't fail if computed 'Covering' does not cover all constructors.
      -> SplitClause
      -> BlockingVar
      -> TCM (Either SplitError Covering)
split :: Induction
-> AllowPartialCover
-> SplitClause
-> BlockingVar
-> TCMT IO (Either SplitError Covering)
split Induction
ind AllowPartialCover
allowPartialCover SplitClause
sc BlockingVar
x =
  (Either SplitClause Covering -> Covering)
-> Either SplitError (Either SplitClause Covering)
-> Either SplitError Covering
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Either SplitClause Covering -> Covering
blendInAbsurdClause (Either SplitError (Either SplitClause Covering)
 -> Either SplitError Covering)
-> TCM (Either SplitError (Either SplitClause Covering))
-> TCMT IO (Either SplitError Covering)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> CheckEmpty
-> Induction
-> AllowPartialCover
-> InsertTrailing
-> SplitClause
-> BlockingVar
-> TCM (Either SplitError (Either SplitClause Covering))
split' CheckEmpty
NoCheckEmpty Induction
ind AllowPartialCover
allowPartialCover InsertTrailing
DoInsertTrailing SplitClause
sc BlockingVar
x
  where
    n :: Arg Nat
n = SplitClause -> Nat -> Arg Nat
lookupPatternVar SplitClause
sc (Nat -> Arg Nat) -> Nat -> Arg Nat
forall a b. (a -> b) -> a -> b
$ BlockingVar -> Nat
blockingVarNo BlockingVar
x
    blendInAbsurdClause :: Either SplitClause Covering -> Covering
    blendInAbsurdClause :: Either SplitClause Covering -> Covering
blendInAbsurdClause = (SplitClause -> Covering)
-> Either SplitClause Covering -> Covering
forall a b. (a -> b) -> Either a b -> b
fromRight (Covering -> SplitClause -> Covering
forall a b. a -> b -> a
const (Covering -> SplitClause -> Covering)
-> Covering -> SplitClause -> Covering
forall a b. (a -> b) -> a -> b
$ Arg Nat -> [(SplitTag, SplitClause)] -> Covering
Covering Arg Nat
n [])

-- | Convert a de Bruijn index relative to the clause telescope to a de Bruijn
--   level. The result should be the argument position (counted from left,
--   starting with 0) to split at (dot patterns included!).
lookupPatternVar :: SplitClause -> Int -> Arg Nat
lookupPatternVar :: SplitClause -> Nat -> Arg Nat
lookupPatternVar SClause{ scTel :: SplitClause -> Telescope
scTel = Telescope
tel, scPats :: SplitClause -> [NamedArg SplitPattern]
scPats = [NamedArg SplitPattern]
pats } Nat
x = Arg DeBruijnPattern
arg Arg DeBruijnPattern -> Nat -> Arg Nat
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>
    if Nat
n Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
< Nat
0 then Nat
forall a. HasCallStack => a
__IMPOSSIBLE__ else Nat
n
  where n :: Nat
n = if Nat
k Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
< Nat
0
            then Nat
forall a. HasCallStack => a
__IMPOSSIBLE__
            else Nat -> Maybe Nat -> Nat
forall a. a -> Maybe a -> a
fromMaybe Nat
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Nat -> Nat) -> Maybe Nat -> Nat
forall a b. (a -> b) -> a -> b
$ Permutation -> [Nat]
permPicks Permutation
perm [Nat] -> Nat -> Maybe Nat
forall a. [a] -> Nat -> Maybe a
!!! Nat
k
        perm :: Permutation
perm = Permutation -> Maybe Permutation -> Permutation
forall a. a -> Maybe a -> a
fromMaybe Permutation
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Permutation -> Permutation)
-> Maybe Permutation -> Permutation
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> Maybe Permutation
dbPatPerm ([NamedArg DeBruijnPattern] -> Maybe Permutation)
-> [NamedArg DeBruijnPattern] -> Maybe Permutation
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
pats
        k :: Nat
k = Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
x Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1
        arg :: Arg DeBruijnPattern
arg = Arg DeBruijnPattern
-> [Arg DeBruijnPattern] -> Nat -> Arg DeBruijnPattern
forall a. a -> [a] -> Nat -> a
indexWithDefault Arg DeBruijnPattern
forall a. HasCallStack => a
__IMPOSSIBLE__ (Nat -> Telescope -> [Arg DeBruijnPattern]
telVars (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel) Telescope
tel) Nat
k


data CheckEmpty = CheckEmpty | NoCheckEmpty

-- | @split' ind pc ft splitClause x = return res@
--   splits @splitClause@ at pattern var @x@ (de Bruijn index).
--
--   Possible results @res@ are:
--
--   1. @Left err@:
--      Splitting failed.
--
--   2. @Right (Left splitClause')@:
--      Absurd clause (type of @x@ has 0 valid constructors).
--
--   3. @Right (Right covering)@:
--      A covering set of split clauses, one for each valid constructor.

split' :: CheckEmpty
          -- ^ Use isEmptyType to check whether the type of the variable to
          -- split on is empty. This switch is necessary to break the cycle
          -- between split' and isEmptyType.
       -> Induction
          -- ^ Coinductive constructors are allowed if this argument is
          -- 'CoInductive'.
       -> AllowPartialCover
          -- ^ Don't fail if computed 'Covering' does not cover all constructors.
       -> InsertTrailing
          -- ^ If 'DoInsertTrailing', introduce new trailing variable patterns.
       -> SplitClause
       -> BlockingVar
       -> TCM (Either SplitError (Either SplitClause Covering))
split' :: CheckEmpty
-> Induction
-> AllowPartialCover
-> InsertTrailing
-> SplitClause
-> BlockingVar
-> TCM (Either SplitError (Either SplitClause Covering))
split' CheckEmpty
checkEmpty Induction
ind AllowPartialCover
allowPartialCover InsertTrailing
inserttrailing
       sc :: SplitClause
sc@(SClause Telescope
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId Substitution
cps Maybe (Dom Type)
target) (BlockingVar Nat
x [ConHead]
pcons' [Literal]
plits Bool
overlap Bool
lazy) =
 TCM (Either SplitError (Either SplitClause Covering))
-> TCM (Either SplitError (Either SplitClause Covering))
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Either SplitError (Either SplitClause Covering))
 -> TCM (Either SplitError (Either SplitClause Covering)))
-> TCM (Either SplitError (Either SplitClause Covering))
-> TCM (Either SplitError (Either SplitClause Covering))
forall a b. (a -> b) -> a -> b
$ ExceptT SplitError TCM (Either SplitClause Covering)
-> TCM (Either SplitError (Either SplitClause Covering))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SplitError TCM (Either SplitClause Covering)
 -> TCM (Either SplitError (Either SplitClause Covering)))
-> ExceptT SplitError TCM (Either SplitClause Covering)
-> TCM (Either SplitError (Either SplitClause Covering))
forall a b. (a -> b) -> a -> b
$ do
  Telescope
-> Nat
-> [NamedArg SplitPattern]
-> Map CheckpointId Substitution
-> ExceptT SplitError TCM ()
forall (tcm :: * -> *) a a a.
(MonadTCM tcm, AddContext a, PrettyTCM a, PrettyTCM a, PrettyTCM a,
 Show a, Show a, Show a) =>
a -> a -> [NamedArg SplitPattern] -> a -> tcm ()
debugInit Telescope
tel Nat
x [NamedArg SplitPattern]
ps Map CheckpointId Substitution
cps

  -- Split the telescope at the variable
  -- t = type of the variable,  Δ₁ ⊢ t
  (VerboseKey
n, Dom Type
t, Telescope
delta1, Telescope
delta2) <- do
    let (ListTel
tel1, Dom' Term (VerboseKey, Type)
dom : ListTel
tel2) = Nat -> ListTel -> (ListTel, ListTel)
forall a. Nat -> [a] -> ([a], [a])
splitAt (Telescope -> Nat
forall a. Sized a => a -> Nat
size Telescope
tel Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
x Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1) (ListTel -> (ListTel, ListTel)) -> ListTel -> (ListTel, ListTel)
forall a b. (a -> b) -> a -> b
$ Telescope -> ListTel
forall t. Tele (Dom t) -> [Dom (VerboseKey, t)]
telToList Telescope
tel
    (VerboseKey, Dom Type, Telescope, Telescope)
-> ExceptT
     SplitError TCM (VerboseKey, Dom Type, Telescope, Telescope)
forall (m :: * -> *) a. Monad m => a -> m a
return ((VerboseKey, Type) -> VerboseKey
forall a b. (a, b) -> a
fst ((VerboseKey, Type) -> VerboseKey)
-> (VerboseKey, Type) -> VerboseKey
forall a b. (a -> b) -> a -> b
$ Dom' Term (VerboseKey, Type) -> (VerboseKey, Type)
forall t e. Dom' t e -> e
unDom Dom' Term (VerboseKey, Type)
dom, (VerboseKey, Type) -> Type
forall a b. (a, b) -> b
snd ((VerboseKey, Type) -> Type)
-> Dom' Term (VerboseKey, Type) -> Dom Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom' Term (VerboseKey, Type)
dom, ListTel -> Telescope
telFromList ListTel
tel1, ListTel -> Telescope
telFromList ListTel
tel2)

  -- Compute the neighbourhoods for the constructors
  let computeNeighborhoods :: ExceptT
  SplitError TCM (DataOrRecord, Bool, [(SplitTag, SplitClause)])
computeNeighborhoods = do
        -- Check that t is a datatype or a record
        -- Andreas, 2010-09-21, isDatatype now directly throws an exception if it fails
        -- cons = constructors of this datatype
        (DataOrRecord
dr, QName
d, Args
pars, Args
ixs, [QName]
cons', Bool
isHIT) <- ExceptT
  SplitError TCM (DataOrRecord, QName, Args, Args, [QName], Bool)
-> ExceptT
     SplitError TCM (DataOrRecord, QName, Args, Args, [QName], Bool)
forall (tcm :: * -> *) a.
(MonadTCM tcm, MonadAddContext tcm, MonadDebug tcm) =>
tcm a -> tcm a
inContextOfT (ExceptT
   SplitError TCM (DataOrRecord, QName, Args, Args, [QName], Bool)
 -> ExceptT
      SplitError TCM (DataOrRecord, QName, Args, Args, [QName], Bool))
-> ExceptT
     SplitError TCM (DataOrRecord, QName, Args, Args, [QName], Bool)
-> ExceptT
     SplitError TCM (DataOrRecord, QName, Args, Args, [QName], Bool)
forall a b. (a -> b) -> a -> b
$ Induction
-> Dom Type
-> ExceptT
     SplitError TCM (DataOrRecord, QName, Args, Args, [QName], Bool)
forall (tcm :: * -> *).
(MonadTCM tcm, MonadError SplitError tcm) =>
Induction
-> Dom Type -> tcm (DataOrRecord, QName, Args, Args, [QName], Bool)
isDatatype Induction
ind Dom Type
t
        [QName]
cons <- case CheckEmpty
checkEmpty of
          CheckEmpty
CheckEmpty   -> ExceptT SplitError TCM Bool
-> ExceptT SplitError TCM [QName]
-> ExceptT SplitError TCM [QName]
-> ExceptT SplitError TCM [QName]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TCMT IO Bool -> ExceptT SplitError TCM Bool
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Bool -> ExceptT SplitError TCM Bool)
-> TCMT IO Bool -> ExceptT SplitError TCM Bool
forall a b. (a -> b) -> a -> b
$ TCMT IO Bool -> TCMT IO Bool
forall (tcm :: * -> *) a.
(MonadTCM tcm, MonadAddContext tcm, MonadDebug tcm) =>
tcm a -> tcm a
inContextOfT (TCMT IO Bool -> TCMT IO Bool) -> TCMT IO Bool -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO Bool
isEmptyType (Type -> TCMT IO Bool) -> Type -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t) ([QName] -> ExceptT SplitError TCM [QName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) ([QName] -> ExceptT SplitError TCM [QName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [QName]
cons')
          CheckEmpty
NoCheckEmpty -> [QName] -> ExceptT SplitError TCM [QName]
forall (f :: * -> *) a. Applicative f => a -> f a
pure [QName]
cons'
        [Maybe (SplitTag, SplitClause)]
mns  <- [QName]
-> (QName -> CoverM (Maybe (SplitTag, SplitClause)))
-> ExceptT SplitError TCM [Maybe (SplitTag, SplitClause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [QName]
cons ((QName -> CoverM (Maybe (SplitTag, SplitClause)))
 -> ExceptT SplitError TCM [Maybe (SplitTag, SplitClause)])
-> (QName -> CoverM (Maybe (SplitTag, SplitClause)))
-> ExceptT SplitError TCM [Maybe (SplitTag, SplitClause)]
forall a b. (a -> b) -> a -> b
$ \ QName
con -> (SplitClause -> (SplitTag, SplitClause))
-> Maybe SplitClause -> Maybe (SplitTag, SplitClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QName -> SplitTag
SplitCon QName
con,) (Maybe SplitClause -> Maybe (SplitTag, SplitClause))
-> CoverM (Maybe SplitClause)
-> CoverM (Maybe (SplitTag, SplitClause))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Telescope
-> VerboseKey
-> Telescope
-> QName
-> Args
-> Args
-> Nat
-> Telescope
-> [NamedArg SplitPattern]
-> Map CheckpointId Substitution
-> QName
-> CoverM (Maybe SplitClause)
computeNeighbourhood Telescope
delta1 VerboseKey
n Telescope
delta2 QName
d Args
pars Args
ixs Nat
x Telescope
tel [NamedArg SplitPattern]
ps Map CheckpointId Substitution
cps QName
con
        Maybe (SplitTag, SplitClause)
hcompsc <- if Bool
isHIT Bool -> Bool -> Bool
&& InsertTrailing
inserttrailing InsertTrailing -> InsertTrailing -> Bool
forall a. Eq a => a -> a -> Bool
== InsertTrailing
DoInsertTrailing
                   then Telescope
-> VerboseKey
-> Telescope
-> QName
-> Args
-> Args
-> Nat
-> Telescope
-> [NamedArg SplitPattern]
-> Map CheckpointId Substitution
-> CoverM (Maybe (SplitTag, SplitClause))
computeHCompSplit Telescope
delta1 VerboseKey
n Telescope
delta2 QName
d Args
pars Args
ixs Nat
x Telescope
tel [NamedArg SplitPattern]
ps Map CheckpointId Substitution
cps
                   else Maybe (SplitTag, SplitClause)
-> CoverM (Maybe (SplitTag, SplitClause))
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (SplitTag, SplitClause)
forall a. Maybe a
Nothing
        (DataOrRecord, Bool, [(SplitTag, SplitClause)])
-> ExceptT
     SplitError TCM (DataOrRecord, Bool, [(SplitTag, SplitClause)])
forall (m :: * -> *) a. Monad m => a -> m a
return ( DataOrRecord
dr
               , Bool -> Bool
not (Args -> Bool
forall a. Null a => a -> Bool
null Args
ixs) -- Is "d" indexed?
               , [Maybe (SplitTag, SplitClause)] -> [(SplitTag, SplitClause)]
forall a. [Maybe a] -> [a]
catMaybes ([Maybe (SplitTag, SplitClause)]
mns [Maybe (SplitTag, SplitClause)]
-> [Maybe (SplitTag, SplitClause)]
-> [Maybe (SplitTag, SplitClause)]
forall a. [a] -> [a] -> [a]
++ [Maybe (SplitTag, SplitClause)
hcompsc])
               )

      computeLitNeighborhoods :: ExceptT
  SplitError TCM (DataOrRecord, Bool, [(SplitTag, SplitClause)])
computeLitNeighborhoods = do
        Bool
typeOk <- TCMT IO Bool -> ExceptT SplitError TCM Bool
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Bool -> ExceptT SplitError TCM Bool)
-> TCMT IO Bool -> ExceptT SplitError TCM Bool
forall a b. (a -> b) -> a -> b
$ do
          Type
t' <- Literal -> TCM Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
Literal -> m Type
litType (Literal -> TCM Type) -> Literal -> TCM Type
forall a b. (a -> b) -> a -> b
$ Literal -> [Literal] -> Literal
forall a. a -> [a] -> a
headWithDefault {-'-} Literal
forall a. HasCallStack => a
__IMPOSSIBLE__ [Literal]
plits
          TCMT IO Bool -> TCMT IO Bool
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Bool -> TCMT IO Bool) -> TCMT IO Bool -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ TCMT IO Bool -> TCMT IO Bool
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
dontAssignMetas (TCMT IO Bool -> TCMT IO Bool) -> TCMT IO Bool -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ TCMT IO () -> TCMT IO Bool
forall (m :: * -> *).
(MonadConstraint m, MonadWarning m, MonadError TCErr m,
 MonadFresh ProblemId m) =>
m () -> m Bool
tryConversion (TCMT IO () -> TCMT IO Bool) -> TCMT IO () -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ Type -> Type -> TCMT IO ()
forall (m :: * -> *). MonadConversion m => Type -> Type -> m ()
equalType (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t) Type
t'
        Bool -> ExceptT SplitError TCM () -> ExceptT SplitError TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
typeOk (ExceptT SplitError TCM () -> ExceptT SplitError TCM ())
-> ExceptT SplitError TCM () -> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$ SplitError -> ExceptT SplitError TCM ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SplitError -> ExceptT SplitError TCM ())
-> (Closure Type -> SplitError)
-> Closure Type
-> ExceptT SplitError TCM ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure Type -> SplitError
NotADatatype (Closure Type -> ExceptT SplitError TCM ())
-> ExceptT SplitError TCM (Closure Type)
-> ExceptT SplitError TCM ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do TCM (Closure Type) -> ExceptT SplitError TCM (Closure Type)
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Closure Type) -> ExceptT SplitError TCM (Closure Type))
-> TCM (Closure Type) -> ExceptT SplitError TCM (Closure Type)
forall a b. (a -> b) -> a -> b
$ Type -> TCM (Closure Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)
        [(SplitTag, SplitClause)]
ns <- [Literal]
-> (Literal -> ExceptT SplitError TCM (SplitTag, SplitClause))
-> ExceptT SplitError TCM [(SplitTag, SplitClause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [Literal]
plits ((Literal -> ExceptT SplitError TCM (SplitTag, SplitClause))
 -> ExceptT SplitError TCM [(SplitTag, SplitClause)])
-> (Literal -> ExceptT SplitError TCM (SplitTag, SplitClause))
-> ExceptT SplitError TCM [(SplitTag, SplitClause)]
forall a b. (a -> b) -> a -> b
$ \Literal
lit -> do
          let delta2' :: Telescope
delta2' = Nat -> SubstArg Telescope -> Telescope -> Telescope
forall a. Subst a => Nat -> SubstArg a -> a -> a
subst Nat
0 (Literal -> Term
Lit Literal
lit) Telescope
delta2
              delta' :: Telescope
delta'  = Telescope
delta1 Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
delta2'
              rho :: Substitution' SplitPattern
rho     = Nat -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
x (Substitution' SplitPattern -> Substitution' SplitPattern)
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a b. (a -> b) -> a -> b
$ SplitPattern
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS (Literal -> SplitPattern
forall a. Literal -> Pattern' a
litP Literal
lit) Substitution' SplitPattern
forall a. Substitution' a
idS
              ps' :: [NamedArg SplitPattern]
ps'     = Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' SplitPattern
Substitution' (SubstArg [NamedArg SplitPattern])
rho [NamedArg SplitPattern]
ps
              cps' :: Map CheckpointId Substitution
cps'    = Substitution' SplitPattern
-> Map CheckpointId Substitution -> Map CheckpointId Substitution
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
rho Map CheckpointId Substitution
cps
          (SplitTag, SplitClause)
-> ExceptT SplitError TCM (SplitTag, SplitClause)
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> SplitTag
SplitLit Literal
lit , Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause Telescope
delta' [NamedArg SplitPattern]
ps' Substitution' SplitPattern
rho Map CheckpointId Substitution
cps' Maybe (Dom Type)
forall a. Maybe a
Nothing)
        (SplitTag, SplitClause)
ca <- do
          let delta' :: Telescope
delta' = Telescope
tel -- telescope is unchanged for catchall branch
              varp :: SplitPattern
varp   = PatternInfo -> SplitPatVar -> SplitPattern
forall x. PatternInfo -> x -> Pattern' x
VarP (PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatOSplit []) (SplitPatVar -> SplitPattern) -> SplitPatVar -> SplitPattern
forall a b. (a -> b) -> a -> b
$ SplitPatVar :: VerboseKey -> Nat -> [Literal] -> SplitPatVar
SplitPatVar
                         { splitPatVarName :: VerboseKey
splitPatVarName   = VerboseKey
forall a. Underscore a => a
underscore
                         , splitPatVarIndex :: Nat
splitPatVarIndex  = Nat
0
                         , splitExcludedLits :: [Literal]
splitExcludedLits = [Literal]
plits
                         }
              rho :: Substitution' SplitPattern
rho    = Nat -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
x (Substitution' SplitPattern -> Substitution' SplitPattern)
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a b. (a -> b) -> a -> b
$ SplitPattern
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS SplitPattern
varp (Substitution' SplitPattern -> Substitution' SplitPattern)
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a b. (a -> b) -> a -> b
$ Nat -> Substitution' SplitPattern
forall a. Nat -> Substitution' a
raiseS Nat
1
              ps' :: [NamedArg SplitPattern]
ps'    = Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' SplitPattern
Substitution' (SubstArg [NamedArg SplitPattern])
rho [NamedArg SplitPattern]
ps
          (SplitTag, SplitClause)
-> ExceptT SplitError TCM (SplitTag, SplitClause)
forall (m :: * -> *) a. Monad m => a -> m a
return (SplitTag
SplitCatchall , Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause Telescope
delta' [NamedArg SplitPattern]
ps' Substitution' SplitPattern
rho Map CheckpointId Substitution
cps Maybe (Dom Type)
forall a. Maybe a
Nothing)

        -- If Agda is changed so that the type of a literal can belong
        -- to an inductive family (with at least one index), then the
        -- following code should be changed (the constructor False
        -- stands for "not indexed").
        (DataOrRecord, Bool, [(SplitTag, SplitClause)])
-> ExceptT
     SplitError TCM (DataOrRecord, Bool, [(SplitTag, SplitClause)])
forall (m :: * -> *) a. Monad m => a -> m a
return (DataOrRecord
IsData, Bool
False, [(SplitTag, SplitClause)]
ns [(SplitTag, SplitClause)]
-> [(SplitTag, SplitClause)] -> [(SplitTag, SplitClause)]
forall a. [a] -> [a] -> [a]
++ [ (SplitTag, SplitClause)
ca ])

  (DataOrRecord
dr, Bool
isIndexed, [(SplitTag, SplitClause)]
ns) <- if [ConHead] -> Bool
forall a. Null a => a -> Bool
null [ConHead]
pcons' Bool -> Bool -> Bool
&& Bool -> Bool
not ([Literal] -> Bool
forall a. Null a => a -> Bool
null [Literal]
plits)
        then ExceptT
  SplitError TCM (DataOrRecord, Bool, [(SplitTag, SplitClause)])
computeLitNeighborhoods
        else ExceptT
  SplitError TCM (DataOrRecord, Bool, [(SplitTag, SplitClause)])
computeNeighborhoods

  [(SplitTag, SplitClause)]
ns <- case Maybe (Dom Type)
target of
    Just Dom Type
a  -> [(SplitTag, SplitClause)]
-> ((SplitTag, SplitClause)
    -> ExceptT SplitError TCM (SplitTag, SplitClause))
-> ExceptT SplitError TCM [(SplitTag, SplitClause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(SplitTag, SplitClause)]
ns (((SplitTag, SplitClause)
  -> ExceptT SplitError TCM (SplitTag, SplitClause))
 -> ExceptT SplitError TCM [(SplitTag, SplitClause)])
-> ((SplitTag, SplitClause)
    -> ExceptT SplitError TCM (SplitTag, SplitClause))
-> ExceptT SplitError TCM [(SplitTag, SplitClause)]
forall a b. (a -> b) -> a -> b
$ \ (SplitTag
con, SplitClause
sc) -> TCMT IO (SplitTag, SplitClause)
-> ExceptT SplitError TCM (SplitTag, SplitClause)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO (SplitTag, SplitClause)
 -> ExceptT SplitError TCM (SplitTag, SplitClause))
-> TCMT IO (SplitTag, SplitClause)
-> ExceptT SplitError TCM (SplitTag, SplitClause)
forall a b. (a -> b) -> a -> b
$ (SplitTag
con,) (SplitClause -> (SplitTag, SplitClause))
-> TCMT IO SplitClause -> TCMT IO (SplitTag, SplitClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                 Quantity
-> SplitTag -> SplitClause -> Dom Type -> TCMT IO SplitClause
fixTargetType (Dom Type -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity Dom Type
t) SplitTag
con SplitClause
sc Dom Type
a
    Maybe (Dom Type)
Nothing -> [(SplitTag, SplitClause)]
-> ExceptT SplitError TCM [(SplitTag, SplitClause)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SplitTag, SplitClause)]
ns

  [(SplitTag, SplitClause)]
ns <- case InsertTrailing
inserttrailing of
    InsertTrailing
DontInsertTrailing -> [(SplitTag, SplitClause)]
-> ExceptT SplitError TCM [(SplitTag, SplitClause)]
forall (m :: * -> *) a. Monad m => a -> m a
return [(SplitTag, SplitClause)]
ns
    InsertTrailing
DoInsertTrailing   -> TCMT IO [(SplitTag, SplitClause)]
-> ExceptT SplitError TCM [(SplitTag, SplitClause)]
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO [(SplitTag, SplitClause)]
 -> ExceptT SplitError TCM [(SplitTag, SplitClause)])
-> TCMT IO [(SplitTag, SplitClause)]
-> ExceptT SplitError TCM [(SplitTag, SplitClause)]
forall a b. (a -> b) -> a -> b
$ [(SplitTag, SplitClause)]
-> ((SplitTag, SplitClause) -> TCMT IO (SplitTag, SplitClause))
-> TCMT IO [(SplitTag, SplitClause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(SplitTag, SplitClause)]
ns (((SplitTag, SplitClause) -> TCMT IO (SplitTag, SplitClause))
 -> TCMT IO [(SplitTag, SplitClause)])
-> ((SplitTag, SplitClause) -> TCMT IO (SplitTag, SplitClause))
-> TCMT IO [(SplitTag, SplitClause)]
forall a b. (a -> b) -> a -> b
$ \(SplitTag
con,SplitClause
sc) ->
      (SplitTag
con,) (SplitClause -> (SplitTag, SplitClause))
-> ((Telescope, SplitClause) -> SplitClause)
-> (Telescope, SplitClause)
-> (SplitTag, SplitClause)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Telescope, SplitClause) -> SplitClause
forall a b. (a, b) -> b
snd ((Telescope, SplitClause) -> (SplitTag, SplitClause))
-> TCM (Telescope, SplitClause) -> TCMT IO (SplitTag, SplitClause)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Bool -> SplitClause -> TCM (Telescope, SplitClause)
insertTrailingArgs Bool
False SplitClause
sc

  Maybe QName
mHCompName <- VerboseKey -> ExceptT SplitError TCM (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
VerboseKey -> m (Maybe QName)
getPrimitiveName' VerboseKey
builtinHComp
  Bool
withoutK   <- WithDefault 'False -> Bool
forall (b :: Bool). KnownBool b => WithDefault b -> Bool
collapseDefault (WithDefault 'False -> Bool)
-> (PragmaOptions -> WithDefault 'False) -> PragmaOptions -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PragmaOptions -> WithDefault 'False
optWithoutK (PragmaOptions -> Bool)
-> ExceptT SplitError TCM PragmaOptions
-> ExceptT SplitError TCM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT SplitError TCM PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions

  Bool
erased <- (TCEnv -> Bool) -> ExceptT SplitError TCM Bool
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> Bool
forall a. LensQuantity a => a -> Bool
hasQuantity0
  VerboseKey -> Nat -> VerboseKey -> ExceptT SplitError TCM ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.cover.split" Nat
60 (VerboseKey -> ExceptT SplitError TCM ())
-> VerboseKey -> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"We are in erased context = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Bool -> VerboseKey
forall a. Show a => a -> VerboseKey
show Bool
erased
  let erasedError :: Bool -> ExceptT SplitError TCM (Either SplitClause Covering)
erasedError Bool
causedByWithoutK =
        SplitError -> ExceptT SplitError TCM (Either SplitClause Covering)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SplitError
 -> ExceptT SplitError TCM (Either SplitClause Covering))
-> (Closure Type -> SplitError)
-> Closure Type
-> ExceptT SplitError TCM (Either SplitClause Covering)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> Closure Type -> SplitError
ErasedDatatype Bool
causedByWithoutK (Closure Type
 -> ExceptT SplitError TCM (Either SplitClause Covering))
-> ExceptT SplitError TCM (Closure Type)
-> ExceptT SplitError TCM (Either SplitClause Covering)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
          do TCM (Closure Type) -> ExceptT SplitError TCM (Closure Type)
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Closure Type) -> ExceptT SplitError TCM (Closure Type))
-> TCM (Closure Type) -> ExceptT SplitError TCM (Closure Type)
forall a b. (a -> b) -> a -> b
$ TCM (Closure Type) -> TCM (Closure Type)
forall (tcm :: * -> *) a.
(MonadTCM tcm, MonadAddContext tcm, MonadDebug tcm) =>
tcm a -> tcm a
inContextOfT (TCM (Closure Type) -> TCM (Closure Type))
-> TCM (Closure Type) -> TCM (Closure Type)
forall a b. (a -> b) -> a -> b
$ Type -> TCM (Closure Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)

  case [(SplitTag, SplitClause)]
ns of
    []  -> do
      let absurdp :: SplitPattern
absurdp = PatternInfo -> SplitPatVar -> SplitPattern
forall x. PatternInfo -> x -> Pattern' x
VarP (PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatOAbsurd []) (SplitPatVar -> SplitPattern) -> SplitPatVar -> SplitPattern
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Nat -> [Literal] -> SplitPatVar
SplitPatVar VerboseKey
forall a. Underscore a => a
underscore Nat
0 []
          rho :: Substitution' SplitPattern
rho = Nat -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Nat -> Substitution' a -> Substitution' a
liftS Nat
x (Substitution' SplitPattern -> Substitution' SplitPattern)
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a b. (a -> b) -> a -> b
$ SplitPattern
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS SplitPattern
absurdp (Substitution' SplitPattern -> Substitution' SplitPattern)
-> Substitution' SplitPattern -> Substitution' SplitPattern
forall a b. (a -> b) -> a -> b
$ Nat -> Substitution' SplitPattern
forall a. Nat -> Substitution' a
raiseS Nat
1
          ps' :: [NamedArg SplitPattern]
ps' = Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' SplitPattern
Substitution' (SubstArg [NamedArg SplitPattern])
rho [NamedArg SplitPattern]
ps
      Either SplitClause Covering
-> ExceptT SplitError TCM (Either SplitClause Covering)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SplitClause Covering
 -> ExceptT SplitError TCM (Either SplitClause Covering))
-> Either SplitClause Covering
-> ExceptT SplitError TCM (Either SplitClause Covering)
forall a b. (a -> b) -> a -> b
$ SplitClause -> Either SplitClause Covering
forall a b. a -> Either a b
Left (SplitClause -> Either SplitClause Covering)
-> SplitClause -> Either SplitClause Covering
forall a b. (a -> b) -> a -> b
$ SClause :: Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause
               { scTel :: Telescope
scTel  = Telescope
tel
               , scPats :: [NamedArg SplitPattern]
scPats = [NamedArg SplitPattern]
ps'
               , scSubst :: Substitution' SplitPattern
scSubst              = Substitution' SplitPattern
forall a. HasCallStack => a
__IMPOSSIBLE__ -- not used
               , scCheckpoints :: Map CheckpointId Substitution
scCheckpoints        = Map CheckpointId Substitution
forall a. HasCallStack => a
__IMPOSSIBLE__ -- not used
               , scTarget :: Maybe (Dom Type)
scTarget             = Maybe (Dom Type)
forall a. Maybe a
Nothing
               }

    -- Andreas, 2018-10-17: If more than one constructor matches, we cannot erase.
    (SplitTag, SplitClause)
_ : (SplitTag, SplitClause)
_ : [(SplitTag, SplitClause)]
_ | Bool -> Bool
not Bool
erased Bool -> Bool -> Bool
&& Bool -> Bool
not (Dom Type -> Bool
forall a. LensQuantity a => a -> Bool
usableQuantity Dom Type
t) ->
      Bool -> ExceptT SplitError TCM (Either SplitClause Covering)
erasedError Bool
False

    -- If exactly one constructor matches and the K rule is turned
    -- off, then we only allow erasure for non-indexed data types
    -- (#4172).
    [(SplitTag, SplitClause)
_] | Bool -> Bool
not Bool
erased Bool -> Bool -> Bool
&& Bool -> Bool
not (Dom Type -> Bool
forall a. LensQuantity a => a -> Bool
usableQuantity Dom Type
t) Bool -> Bool -> Bool
&&
          Bool
withoutK Bool -> Bool -> Bool
&& Bool
isIndexed ->
      Bool -> ExceptT SplitError TCM (Either SplitClause Covering)
erasedError Bool
True

    [(SplitTag, SplitClause)]
_ -> do

      -- Andreas, 2012-10-10 fail if precomputed constructor set does not cover
      -- all the data type constructors
      -- Andreas, 2017-10-08 ... unless partial covering is explicitly allowed.
      let ptags :: [SplitTag]
ptags = (ConHead -> SplitTag) -> [ConHead] -> [SplitTag]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> SplitTag
SplitCon (QName -> SplitTag) -> (ConHead -> QName) -> ConHead -> SplitTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ConHead -> QName
conName) [ConHead]
pcons' [SplitTag] -> [SplitTag] -> [SplitTag]
forall a. [a] -> [a] -> [a]
++ (Literal -> SplitTag) -> [Literal] -> [SplitTag]
forall a b. (a -> b) -> [a] -> [b]
map Literal -> SplitTag
SplitLit [Literal]
plits
      -- clauses for hcomp will be automatically generated.
      let inferred_tags :: Set SplitTag
inferred_tags = Set SplitTag
-> (QName -> Set SplitTag) -> Maybe QName -> Set SplitTag
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Set SplitTag
forall a. Set a
Set.empty (SplitTag -> Set SplitTag
forall a. a -> Set a
Set.singleton (SplitTag -> Set SplitTag)
-> (QName -> SplitTag) -> QName -> Set SplitTag
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> SplitTag
SplitCon) Maybe QName
mHCompName
      let all_tags :: Set SplitTag
all_tags = [SplitTag] -> Set SplitTag
forall a. Ord a => [a] -> Set a
Set.fromList [SplitTag]
ptags Set SplitTag -> Set SplitTag -> Set SplitTag
forall a. Ord a => Set a -> Set a -> Set a
`Set.union` Set SplitTag
inferred_tags

      Bool -> ExceptT SplitError TCM () -> ExceptT SplitError TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AllowPartialCover
allowPartialCover AllowPartialCover -> AllowPartialCover -> Bool
forall a. Eq a => a -> a -> Bool
== AllowPartialCover
NoAllowPartialCover Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
overlap) (ExceptT SplitError TCM () -> ExceptT SplitError TCM ())
-> ExceptT SplitError TCM () -> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$
        [(SplitTag, SplitClause)]
-> ((SplitTag, SplitClause) -> ExceptT SplitError TCM ())
-> ExceptT SplitError TCM ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(SplitTag, SplitClause)]
ns (((SplitTag, SplitClause) -> ExceptT SplitError TCM ())
 -> ExceptT SplitError TCM ())
-> ((SplitTag, SplitClause) -> ExceptT SplitError TCM ())
-> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$ \(SplitTag
tag, SplitClause
sc) -> do
          Bool -> ExceptT SplitError TCM () -> ExceptT SplitError TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (SplitTag
tag SplitTag -> Set SplitTag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set SplitTag
all_tags) (ExceptT SplitError TCM () -> ExceptT SplitError TCM ())
-> ExceptT SplitError TCM () -> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$ do
            Bool
isImpossibleClause <- TCMT IO Bool -> ExceptT SplitError TCM Bool
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Bool -> ExceptT SplitError TCM Bool)
-> TCMT IO Bool -> ExceptT SplitError TCM Bool
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Bool
isEmptyTel (Telescope -> TCMT IO Bool) -> Telescope -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ SplitClause -> Telescope
scTel SplitClause
sc
            Bool -> ExceptT SplitError TCM () -> ExceptT SplitError TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
isImpossibleClause (ExceptT SplitError TCM () -> ExceptT SplitError TCM ())
-> ExceptT SplitError TCM () -> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$ do
              TCMT IO () -> ExceptT SplitError TCM ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> ExceptT SplitError TCM ())
-> TCMT IO () -> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
                [ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text VerboseKey
"Missing case for" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> SplitTag -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM SplitTag
tag
                , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ SplitClause -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM SplitClause
sc
                ]
              SplitError -> ExceptT SplitError TCM ()
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (VerboseKey -> SplitError
GenericSplitError VerboseKey
"precomputed set of constructors does not cover all cases")

      TCMT IO () -> ExceptT SplitError TCM ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> ExceptT SplitError TCM ())
-> TCMT IO () -> ExceptT SplitError TCM ()
forall a b. (a -> b) -> a -> b
$ DataOrRecord -> Type -> Telescope -> Maybe (Dom Type) -> TCMT IO ()
forall (m :: * -> *) a ty.
(MonadTCM m, PureTCM m, MonadError TCErr m, LensSort a,
 PrettyTCM a, LensSort ty, PrettyTCM ty) =>
DataOrRecord -> a -> Telescope -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t) Telescope
delta2 Maybe (Dom Type)
target
      Either SplitClause Covering
-> ExceptT SplitError TCM (Either SplitClause Covering)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SplitClause Covering
 -> ExceptT SplitError TCM (Either SplitClause Covering))
-> Either SplitClause Covering
-> ExceptT SplitError TCM (Either SplitClause Covering)
forall a b. (a -> b) -> a -> b
$ Covering -> Either SplitClause Covering
forall a b. b -> Either a b
Right (Covering -> Either SplitClause Covering)
-> Covering -> Either SplitClause Covering
forall a b. (a -> b) -> a -> b
$ Arg Nat -> [(SplitTag, SplitClause)] -> Covering
Covering (SplitClause -> Nat -> Arg Nat
lookupPatternVar SplitClause
sc Nat
x) [(SplitTag, SplitClause)]
ns

  where
    inContextOfT, inContextOfDelta2 :: (MonadTCM tcm, MonadAddContext tcm, MonadDebug tcm) => tcm a -> tcm a
    inContextOfT :: tcm a -> tcm a
inContextOfT      = Telescope -> tcm a -> tcm a
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (tcm a -> tcm a) -> (tcm a -> tcm a) -> tcm a -> tcm a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Impossible -> Nat -> tcm a -> tcm a
forall (m :: * -> *) a.
MonadAddContext m =>
Impossible -> Nat -> m a -> m a
escapeContext Impossible
HasCallStack => Impossible
impossible (Nat
x Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
1)
    inContextOfDelta2 :: tcm a -> tcm a
inContextOfDelta2 = Telescope -> tcm a -> tcm a
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (tcm a -> tcm a) -> (tcm a -> tcm a) -> tcm a -> tcm a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Impossible -> Nat -> tcm a -> tcm a
forall (m :: * -> *) a.
MonadAddContext m =>
Impossible -> Nat -> m a -> m a
escapeContext Impossible
HasCallStack => Impossible
impossible Nat
x

    -- Debug printing
    debugInit :: a -> a -> [NamedArg SplitPattern] -> a -> tcm ()
debugInit a
tel a
x [NamedArg SplitPattern]
ps a
cps = TCMT IO () -> tcm ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
      VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.top" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCM Doc
"TypeChecking.Coverage.split': split"
        , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCM Doc
"tel     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
tel
          , TCM Doc
"x       =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
x
          , TCM Doc
"ps      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do a -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext a
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg DeBruijnPattern] -> TCM Doc)
-> [NamedArg DeBruijnPattern] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps
          , TCM Doc
"cps     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
cps
          ]
        ]
      VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.top" Nat
60 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCM Doc
"TypeChecking.Coverage.split': split"
        , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCM Doc
"tel     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (a -> VerboseKey) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> VerboseKey
forall a. Show a => a -> VerboseKey
show) a
tel
          , TCM Doc
"x       =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (a -> VerboseKey) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> VerboseKey
forall a. Show a => a -> VerboseKey
show) a
x
          , TCM Doc
"ps      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc)
-> ([NamedArg SplitPattern] -> VerboseKey)
-> [NamedArg SplitPattern]
-> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [NamedArg SplitPattern] -> VerboseKey
forall a. Show a => a -> VerboseKey
show) [NamedArg SplitPattern]
ps
          , TCM Doc
"cps     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> (a -> VerboseKey) -> a -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> VerboseKey
forall a. Show a => a -> VerboseKey
show) a
cps
          ]
        ]

    debugHoleAndType :: a -> a -> VerboseKey -> [NamedArg DeBruijnPattern] -> a -> tcm ()
debugHoleAndType a
delta1 a
delta2 VerboseKey
s [NamedArg DeBruijnPattern]
ps a
t =
      TCMT IO () -> tcm ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.top" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$
        [ TCM Doc
"p      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> VerboseKey
patVarNameToString VerboseKey
s)
        , TCM Doc
"ps     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList [NamedArg DeBruijnPattern]
ps
        , TCM Doc
"delta1 =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
delta1
        , TCM Doc
"delta2 =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCM tcm, MonadAddContext tcm, MonadDebug tcm) =>
tcm a -> tcm a
inContextOfDelta2 (a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
delta2)
        , TCM Doc
"t      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCM Doc -> TCM Doc
forall (tcm :: * -> *) a.
(MonadTCM tcm, MonadAddContext tcm, MonadDebug tcm) =>
tcm a -> tcm a
inContextOfT (a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
t)
        ]


-- | splitResult for MakeCase, tries to introduce IApply or ProjP copatterns
splitResult :: QName -> SplitClause -> TCM (Either SplitError [SplitClause])
splitResult :: QName -> SplitClause -> TCM (Either SplitError [SplitClause])
splitResult QName
f SplitClause
sc = do
  TCMT IO (Maybe SplitClause)
-> TCM (Either SplitError [SplitClause])
-> (SplitClause -> TCM (Either SplitError [SplitClause]))
-> TCM (Either SplitError [SplitClause])
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (QName -> SplitClause -> TCMT IO (Maybe SplitClause)
splitResultPath QName
f SplitClause
sc)
             (((Either SplitError Covering -> Either SplitError [SplitClause])
-> TCMT IO (Either SplitError Covering)
-> TCM (Either SplitError [SplitClause])
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Either SplitError Covering -> Either SplitError [SplitClause])
 -> TCMT IO (Either SplitError Covering)
 -> TCM (Either SplitError [SplitClause]))
-> ((Covering -> [SplitClause])
    -> Either SplitError Covering -> Either SplitError [SplitClause])
-> (Covering -> [SplitClause])
-> TCMT IO (Either SplitError Covering)
-> TCM (Either SplitError [SplitClause])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Covering -> [SplitClause])
-> Either SplitError Covering -> Either SplitError [SplitClause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) Covering -> [SplitClause]
splitClauses (TCMT IO (Either SplitError Covering)
 -> TCM (Either SplitError [SplitClause]))
-> TCMT IO (Either SplitError Covering)
-> TCM (Either SplitError [SplitClause])
forall a b. (a -> b) -> a -> b
$ QName -> SplitClause -> TCMT IO (Either SplitError Covering)
splitResultRecord QName
f SplitClause
sc)
             (Either SplitError [SplitClause]
-> TCM (Either SplitError [SplitClause])
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SplitError [SplitClause]
 -> TCM (Either SplitError [SplitClause]))
-> (SplitClause -> Either SplitError [SplitClause])
-> SplitClause
-> TCM (Either SplitError [SplitClause])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [SplitClause] -> Either SplitError [SplitClause]
forall a b. b -> Either a b
Right ([SplitClause] -> Either SplitError [SplitClause])
-> (SplitClause -> [SplitClause])
-> SplitClause
-> Either SplitError [SplitClause]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (SplitClause -> [SplitClause] -> [SplitClause]
forall a. a -> [a] -> [a]
:[]))


-- | Tries to split the result to introduce an IApply pattern.
splitResultPath :: QName -> SplitClause -> TCM (Maybe SplitClause)
splitResultPath :: QName -> SplitClause -> TCMT IO (Maybe SplitClause)
splitResultPath QName
f sc :: SplitClause
sc@(SClause Telescope
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId Substitution
_ Maybe (Dom Type)
target) = do
  Maybe (Dom Type)
-> TCMT IO (Maybe SplitClause)
-> (Dom Type -> TCMT IO (Maybe SplitClause))
-> TCMT IO (Maybe SplitClause)
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Dom Type)
target (Maybe SplitClause -> TCMT IO (Maybe SplitClause)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SplitClause
forall a. Maybe a
Nothing) ((Dom Type -> TCMT IO (Maybe SplitClause))
 -> TCMT IO (Maybe SplitClause))
-> (Dom Type -> TCMT IO (Maybe SplitClause))
-> TCMT IO (Maybe SplitClause)
forall a b. (a -> b) -> a -> b
$ \ Dom Type
t -> do
        TCMT IO (Maybe (Dom Type, Abs Type))
-> TCMT IO (Maybe SplitClause)
-> ((Dom Type, Abs Type) -> TCMT IO (Maybe SplitClause))
-> TCMT IO (Maybe SplitClause)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Type -> TCMT IO (Maybe (Dom Type, Abs Type))
forall (m :: * -> *).
PureTCM m =>
Type -> m (Maybe (Dom Type, Abs Type))
isPath (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)) (Maybe SplitClause -> TCMT IO (Maybe SplitClause)
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe SplitClause
forall a. Maybe a
Nothing) (((Dom Type, Abs Type) -> TCMT IO (Maybe SplitClause))
 -> TCMT IO (Maybe SplitClause))
-> ((Dom Type, Abs Type) -> TCMT IO (Maybe SplitClause))
-> TCMT IO (Maybe SplitClause)
forall a b. (a -> b) -> a -> b
$ \ (Dom Type, Abs Type)
_ -> do
               (TelV Telescope
i Type
b, [(Term, (Term, Term))]
boundary) <- Nat -> Type -> TCM (TelV Type, [(Term, (Term, Term))])
forall (m :: * -> *).
PureTCM m =>
Nat -> Type -> m (TelV Type, [(Term, (Term, Term))])
telViewUpToPathBoundary' Nat
1 (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)
               let tel' :: Telescope
tel' = Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
abstract Telescope
tel Telescope
i
                   rho :: Substitution' a
rho  = Nat -> Substitution' a
forall a. Nat -> Substitution' a
raiseS Nat
1
                   ps' :: [NamedArg SplitPattern]
ps' = Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg [NamedArg SplitPattern])
forall a. Substitution' a
rho (SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
sc) [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++ Telescope -> [(Term, (Term, Term))] -> [NamedArg SplitPattern]
forall a.
DeBruijn a =>
Telescope -> [(Term, (Term, Term))] -> [NamedArg (Pattern' a)]
telePatterns Telescope
i [(Term, (Term, Term))]
boundary
                   cps' :: Map CheckpointId Substitution
cps' = Substitution' (SubstArg (Map CheckpointId Substitution))
-> Map CheckpointId Substitution -> Map CheckpointId Substitution
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' (SubstArg (Map CheckpointId Substitution))
forall a. Substitution' a
rho (SplitClause -> Map CheckpointId Substitution
scCheckpoints SplitClause
sc)
                   target' :: Maybe (Dom Type)
target' = Dom Type -> Maybe (Dom Type)
forall a. a -> Maybe a
Just (Dom Type -> Maybe (Dom Type)) -> Dom Type -> Maybe (Dom Type)
forall a b. (a -> b) -> a -> b
$ Type
b Type -> Dom Type -> Dom Type
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Dom Type
t
               Maybe SplitClause -> TCMT IO (Maybe SplitClause)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe SplitClause -> TCMT IO (Maybe SplitClause))
-> (SplitClause -> Maybe SplitClause)
-> SplitClause
-> TCMT IO (Maybe SplitClause)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SplitClause -> Maybe SplitClause
forall a. a -> Maybe a
Just (SplitClause -> TCMT IO (Maybe SplitClause))
-> SplitClause -> TCMT IO (Maybe SplitClause)
forall a b. (a -> b) -> a -> b
$ Telescope
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId Substitution
-> Maybe (Dom Type)
-> SplitClause
SClause Telescope
tel' [NamedArg SplitPattern]
ps' Substitution' SplitPattern
forall a. Substitution' a
idS Map CheckpointId Substitution
cps' Maybe (Dom Type)
target'

-- | @splitResultRecord f sc = return res@
--
--   If the target type of @sc@ is a record type, a covering set of
--   split clauses is returned (@sc@ extended by all valid projection patterns),
--   otherwise @res == Left _@.
--   Note that the empty set of split clauses is returned if the record has no fields.
splitResultRecord :: QName -> SplitClause -> TCM (Either SplitError Covering)
splitResultRecord :: QName -> SplitClause -> TCMT IO (Either SplitError Covering)
splitResultRecord QName
f sc :: SplitClause
sc@(SClause Telescope
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId Substitution
_ Maybe (Dom Type)
target) = do
  VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.split" Nat
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCM Doc
"splitting result:"
    , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"f      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
f
    , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"target =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> (Dom Type -> TCM Doc) -> Maybe (Dom Type) -> TCM Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCM Doc
forall a. Null a => a
empty Dom Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Maybe (Dom Type)
target)
    ]
  -- if we want to split projections, but have no target type, we give up
  let failure :: a -> TCMT IO (Either a b)
failure = Either a b -> TCMT IO (Either a b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Either a b -> TCMT IO (Either a b))
-> (a -> Either a b) -> a -> TCMT IO (Either a b)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. a -> Either a b
forall a b. a -> Either a b
Left
  Maybe (Dom Type)
-> TCMT IO (Either SplitError Covering)
-> (Dom Type -> TCMT IO (Either SplitError Covering))
-> TCMT IO (Either SplitError Covering)
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Dom Type)
target (SplitError -> TCMT IO (Either SplitError Covering)
forall a b. a -> TCMT IO (Either a b)
failure SplitError
CosplitNoTarget) ((Dom Type -> TCMT IO (Either SplitError Covering))
 -> TCMT IO (Either SplitError Covering))
-> (Dom Type -> TCMT IO (Either SplitError Covering))
-> TCMT IO (Either SplitError Covering)
forall a b. (a -> b) -> a -> b
$ \ Dom Type
t -> do
    Maybe (QName, Args, Defn)
isR <- Telescope
-> TCMT IO (Maybe (QName, Args, Defn))
-> TCMT IO (Maybe (QName, Args, Defn))
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCMT IO (Maybe (QName, Args, Defn))
 -> TCMT IO (Maybe (QName, Args, Defn)))
-> TCMT IO (Maybe (QName, Args, Defn))
-> TCMT IO (Maybe (QName, Args, Defn))
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO (Maybe (QName, Args, Defn))
forall (m :: * -> *).
PureTCM m =>
Type -> m (Maybe (QName, Args, Defn))
isRecordType (Type -> TCMT IO (Maybe (QName, Args, Defn)))
-> Type -> TCMT IO (Maybe (QName, Args, Defn))
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t
    case Maybe (QName, Args, Defn)
isR of
      Just (QName
_r, Args
vs, Record{ recFields :: Defn -> [Dom QName]
recFields = [Dom QName]
fs }) -> do
        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
          [ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"we are of record type _r = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow QName
_r
          , VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text   VerboseKey
"applied to parameters vs =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (Args -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Args
vs)
          , VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"and have fields       fs = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ [Dom QName] -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow [Dom QName]
fs
          ]
        -- Andreas, 2018-06-09, issue #2170, we always have irrelevant projections
        -- available on the lhs.
        -- -- Andreas, 2018-03-19, issue #2971, check that we have a "strong" record type,
        -- -- i.e., with all the projections.  Otherwise, we may not split.
        -- ifNotM (strongRecord fs) (failure CosplitIrrelevantProjections) $ {-else-} do
        let es :: Elims
es = [NamedArg DeBruijnPattern] -> Elims
patternsToElims ([NamedArg DeBruijnPattern] -> Elims)
-> [NamedArg DeBruijnPattern] -> Elims
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps
        -- Note: module parameters are part of ps
        let self :: Arg Term
self  = Term -> Arg Term
forall a. a -> Arg a
defaultArg (Term -> Arg Term) -> Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ QName -> Elims -> Term
Def QName
f [] Term -> Elims -> Term
forall t. Apply t => t -> Elims -> t
`applyE` Elims
es
            pargs :: Args
pargs = Args
vs Args -> Args -> Args
forall a. [a] -> [a] -> [a]
++ [Arg Term
self]
            fieldValues :: [Term]
fieldValues = [Dom QName] -> (Dom QName -> Term) -> [Term]
forall (m :: * -> *) a b. Functor m => m a -> (a -> b) -> m b
for [Dom QName]
fs ((Dom QName -> Term) -> [Term]) -> (Dom QName -> Term) -> [Term]
forall a b. (a -> b) -> a -> b
$ \ Dom QName
proj -> Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
self Term -> Elims -> Term
forall t. Apply t => t -> Elims -> t
`applyE` [ProjOrigin -> QName -> Elim' Term
forall a. ProjOrigin -> QName -> Elim' a
Proj ProjOrigin
ProjSystem (Dom QName -> QName
forall t e. Dom' t e -> e
unDom Dom QName
proj)]
        VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover" Nat
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
          [ VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text   VerboseKey
"we are              self =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
self)
          , VerboseKey -> TCM Doc
forall (m :: * -> *). Applicative m => VerboseKey -> m Doc
text   VerboseKey
"            field values =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Term] -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Term]
fieldValues
          ]
        let n :: Arg Nat
n = Nat -> Arg Nat
forall a. a -> Arg a
defaultArg (Nat -> Arg Nat) -> Nat -> Arg Nat
forall a b. (a -> b) -> a -> b
$ Permutation -> Nat
permRange (Permutation -> Nat) -> Permutation -> Nat
forall a b. (a -> b) -> a -> b
$ Permutation -> Maybe Permutation -> Permutation
forall a. a -> Maybe a -> a
fromMaybe Permutation
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Permutation -> Permutation)
-> Maybe Permutation -> Permutation
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> Maybe Permutation
dbPatPerm ([NamedArg DeBruijnPattern] -> Maybe Permutation)
-> [NamedArg DeBruijnPattern] -> Maybe Permutation
forall a b. (a -> b) -> a -> b
$ [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps
            -- Andreas & James, 2013-11-19 includes the dot patterns!
            -- See test/succeed/CopatternsAndDotPatterns.agda for a case with dot patterns
            -- and copatterns which fails for @n = size tel@ with a broken case tree.

        -- Andreas, 2016-07-22 read the style of projections from the user's lips
        ProjOrigin
projOrigin <- TCMT IO Bool
-> TCMT IO ProjOrigin -> TCMT IO ProjOrigin -> TCMT IO ProjOrigin
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (PragmaOptions -> Bool
optPostfixProjections (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions) (ProjOrigin -> TCMT IO ProjOrigin
forall (m :: * -> *) a. Monad m => a -> m a
return ProjOrigin
ProjPostfix) (ProjOrigin -> TCMT IO ProjOrigin
forall (m :: * -> *) a. Monad m => a -> m a
return ProjOrigin
ProjPrefix)
        Covering -> Either SplitError Covering
forall a b. b -> Either a b
Right (Covering -> Either SplitError Covering)
-> ([(SplitTag, SplitClause)] -> Covering)
-> [(SplitTag, SplitClause)]
-> Either SplitError Covering
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Nat -> [(SplitTag, SplitClause)] -> Covering
Covering Arg Nat
n ([(SplitTag, SplitClause)] -> Either SplitError Covering)
-> TCMT IO [(SplitTag, SplitClause)]
-> TCMT IO (Either SplitError Covering)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
          [(Dom QName, [Term])]
-> ((Dom QName, [Term]) -> TCMT IO (SplitTag, SplitClause))
-> TCMT IO [(SplitTag, SplitClause)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ([Dom QName] -> [[Term]] -> [(Dom QName, [Term])]
forall a b. [a] -> [b] -> [(a, b)]
zip [Dom QName]
fs ([[Term]] -> [(Dom QName, [Term])])
-> [[Term]] -> [(Dom QName, [Term])]
forall a b. (a -> b) -> a -> b
$ [Term] -> [[Term]]
forall a. [a] -> [[a]]
List.inits [Term]
fieldValues) (((Dom QName, [Term]) -> TCMT IO (SplitTag, SplitClause))
 -> TCMT IO [(SplitTag, SplitClause)])
-> ((Dom QName, [Term]) -> TCMT IO (SplitTag, SplitClause))
-> TCMT IO [(SplitTag, SplitClause)]
forall a b. (a -> b) -> a -> b
$ \ (Dom QName
proj, [Term]
prevFields) -> do
            -- compute the new target
            Type
dType <- Definition -> Type
defType (Definition -> Type) -> TCMT IO Definition -> TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (QName -> TCMT IO Definition) -> QName -> TCMT IO Definition
forall a b. (a -> b) -> a -> b
$ Dom QName -> QName
forall t e. Dom' t e -> e
unDom Dom QName
proj -- WRONG: typeOfConst $ unArg proj
            let -- Substitution for parameters and previous fields. Needs to be applied to potential
                -- tactic in proj.
                fieldSub :: Substitution
fieldSub = [Term] -> [Term]
forall a. [a] -> [a]
reverse ((Arg Term -> Term) -> Args -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Term
forall e. Arg e -> e
unArg Args
vs [Term] -> [Term] -> [Term]
forall a. [a] -> [a] -> [a]
++ [Term]
prevFields) [Term] -> Substitution -> Substitution
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Impossible -> Substitution
forall a. Impossible -> Substitution' a
EmptyS Impossible
HasCallStack => Impossible
impossible
                proj' :: Dom QName
proj'    = Substitution' (SubstArg (Dom QName)) -> Dom QName -> Dom QName
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg (Dom QName))
fieldSub Dom QName
proj
                -- type of projection instantiated at self
                target' :: Maybe (Dom Type)
target' = Dom Type -> Maybe (Dom Type)
forall a. a -> Maybe a
Just (Dom Type -> Maybe (Dom Type)) -> Dom Type -> Maybe (Dom Type)
forall a b. (a -> b) -> a -> b
$ Dom QName
proj' Dom QName -> Type -> Dom Type
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Type
dType Type -> Args -> Type
`piApply` Args
pargs      -- Always visible (#2287)
                projArg :: NamedArg SplitPattern
projArg = (QName -> Named NamedName SplitPattern)
-> Arg QName -> NamedArg SplitPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Maybe NamedName -> SplitPattern -> Named NamedName SplitPattern
forall name a. Maybe name -> a -> Named name a
Named Maybe NamedName
forall a. Maybe a
Nothing (SplitPattern -> Named NamedName SplitPattern)
-> (QName -> SplitPattern) -> QName -> Named NamedName SplitPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ProjOrigin -> QName -> SplitPattern
forall x. ProjOrigin -> QName -> Pattern' x
ProjP ProjOrigin
projOrigin) (Arg QName -> NamedArg SplitPattern)
-> Arg QName -> NamedArg SplitPattern
forall a b. (a -> b) -> a -> b
$ Dom QName -> Arg QName
forall t a. Dom' t a -> Arg a
argFromDom (Dom QName -> Arg QName) -> Dom QName -> Arg QName
forall a b. (a -> b) -> a -> b
$ Hiding -> Dom QName -> Dom QName
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
NotHidden Dom QName
proj
                sc' :: SplitClause
sc' = SplitClause
sc { scPats :: [NamedArg SplitPattern]
scPats   = SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
sc [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++ [NamedArg SplitPattern
projArg]
                         , scSubst :: Substitution' SplitPattern
scSubst  = Substitution' SplitPattern
forall a. Substitution' a
idS
                         , scTarget :: Maybe (Dom Type)
scTarget = Maybe (Dom Type)
target'
                         }
            VerboseKey -> Nat -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> Nat -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.cover.copattern" Nat
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
              [ TCM Doc
"fieldSub for" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Dom QName -> QName
forall t e. Dom' t e -> e
unDom Dom QName
proj)
              , Nat -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Substitution -> TCM Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Substitution
fieldSub ]
            (SplitTag, SplitClause) -> TCMT IO (SplitTag, SplitClause)
forall (m :: * -> *) a. Monad m => a -> m a
return (QName -> SplitTag
SplitCon (Dom QName -> QName
forall t e. Dom' t e -> e
unDom Dom QName
proj), SplitClause
sc')
      Maybe (QName, Args, Defn)
_ -> Telescope
-> TCMT IO (Either SplitError Covering)
-> TCMT IO (Either SplitError Covering)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (TCMT IO (Either SplitError Covering)
 -> TCMT IO (Either SplitError Covering))
-> TCMT IO (Either SplitError Covering)
-> TCMT IO (Either SplitError Covering)
forall a b. (a -> b) -> a -> b
$ do
        Type -> TCM (Closure Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t) TCM (Closure Type)
-> (Closure Type -> TCMT IO (Either SplitError Covering))
-> TCMT IO (Either SplitError Covering)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= SplitError -> TCMT IO (Either SplitError Covering)
forall a b. a -> TCMT IO (Either a b)
failure (SplitError -> TCMT IO (Either SplitError Covering))
-> (Closure Type -> SplitError)
-> Closure Type
-> TCMT IO (Either SplitError Covering)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure Type -> SplitError
CosplitNoRecordType
  -- Andreas, 2018-06-09, issue #2170: splitting with irrelevant fields is always fine!
  -- where
  -- -- A record type is strong if it has all the projections.
  -- -- This is the case if --irrelevant-projections or no field is irrelevant.
  -- -- TODO: what about shape irrelevance?
  -- strongRecord :: [Arg QName] -> TCM Bool
  -- strongRecord fs = (optIrrelevantProjections <$> pragmaOptions) `or2M`
  --   (return $ not $ any isIrrelevant fs)


-- * Boring instances

-- | For debugging only.
instance PrettyTCM SplitClause where
  prettyTCM :: SplitClause -> m Doc
prettyTCM (SClause Telescope
tel [NamedArg SplitPattern]
pats Substitution' SplitPattern
sigma Map CheckpointId Substitution
cps Maybe (Dom Type)
target) = [m Doc] -> m Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
    [ m Doc
"SplitClause"
    , Nat -> m Doc -> m Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (m Doc -> m Doc) -> m Doc -> m Doc
forall a b. (a -> b) -> a -> b
$ [m Doc] -> m Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ m Doc
"tel          =" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
      , m Doc
"pats         =" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [m Doc] -> m Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep ((NamedArg SplitPattern -> m Doc)
-> [NamedArg SplitPattern] -> [m Doc]
forall a b. (a -> b) -> [a] -> [b]
map (SplitPattern -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (SplitPattern -> m Doc)
-> (NamedArg SplitPattern -> SplitPattern)
-> NamedArg SplitPattern
-> m Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg SplitPattern -> SplitPattern
forall a. NamedArg a -> a
namedArg) [NamedArg SplitPattern]
pats)
      , m Doc
"subst        =" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' SplitPattern -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Substitution' SplitPattern
sigma
      , m Doc
"checkpoints  =" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Map CheckpointId Substitution -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Map CheckpointId Substitution
cps
      , m Doc
"target       =" m Doc -> m Doc -> m Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do
          Maybe (Dom Type) -> m Doc -> (Dom Type -> m Doc) -> m Doc
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Dom Type)
target m Doc
forall a. Null a => a
empty ((Dom Type -> m Doc) -> m Doc) -> (Dom Type -> m Doc) -> m Doc
forall a b. (a -> b) -> a -> b
$ \ Dom Type
t -> do
            Telescope -> m Doc -> m Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (m Doc -> m Doc) -> m Doc -> m Doc
forall a b. (a -> b) -> a -> b
$ Dom Type -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Dom Type
t
      -- Triggers crash (see Issue 1374).
      -- , "subst target = " <+> do
      --     caseMaybe target empty $ \ t -> do
      --       addContext tel $ prettyTCM $ applySubst sigma t
      ]
    ]