{-# LANGUAGE NondecreasingIndentation #-}
{-# LANGUAGE TypeApplications #-}

{-| 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.Except ( MonadError(..), ExceptT(..), runExceptT )
import Control.Monad.State  ( State, evalState, state )

import Data.Bifunctor (second)
import Data.Either (partitionEithers)
import Data.Foldable (for_)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map
import qualified Data.Set as Set

import qualified Agda.Benchmarking as Bench

import Agda.Syntax.Common hiding (DataOrRecord)
import Agda.Syntax.Common.Pretty (prettyShow)
import Agda.Syntax.Position
import Agda.Syntax.Internal
import Agda.Syntax.Internal.Pattern
import Agda.Syntax.Translation.InternalToAbstract (NamedClause(..))
import Agda.Syntax.Scope.Base (ScopeInfo(..))

import Agda.TypeChecking.Primitive hiding (Nat)
import Agda.TypeChecking.Monad
import qualified Agda.TypeChecking.Monad.Benchmark as Bench

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.SplitPattern
import Agda.TypeChecking.Coverage.SplitTree
import Agda.TypeChecking.Coverage.SplitClause
import Agda.TypeChecking.Coverage.Cubical

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.Sort
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.Warnings

import Agda.Interaction.Options

import Agda.Utils.Either
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.List
import Agda.Utils.Lens
import qualified Agda.Utils.List1 as List1
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Utils.Permutation
import Agda.Utils.Singleton
import Agda.Utils.Size
import Agda.Utils.Tuple

import Agda.Utils.Impossible

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' SplitTag)
coverageCheck QName
f Type
t [Clause]
cs = do
  [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.cover.top" Int
30 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"entering coverageCheck for " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
f
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.top" Int
75 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"  of type (raw): " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> (Type -> [Char]) -> Type -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow) Type
t
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.top" Int
45 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"  of type: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t
  TelV gamma a <- Int -> Type -> TCMT IO (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Int -> Type -> m (TelV Type)
telViewUpTo (-Int
1) Type
t
  reportSLn "tc.cover.top" 30 $ "coverageCheck: computed telView"

  let -- n             = arity
      -- xs            = variable patterns fitting lgamma
      n            = Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
gamma
      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
$ Tele (Dom Type) -> [NamedArg SplitPattern]
forall a t. DeBruijn a => Tele (Dom t) -> [NamedArg a]
teleNamedArgs Tele (Dom Type)
gamma

  reportSLn "tc.cover.top" 30 $ "coverageCheck: getDefFreeVars"

      -- The initial module parameter substitutions need to be weakened by the
      -- number of arguments that aren't module parameters.
  fv           <- getDefFreeVars f

  reportSLn "tc.cover.top" 30 $ "coverageCheck: getting checkpoints"

  -- TODO: does this make sense? Why are we weakening by n - fv?
  checkpoints <- applySubst (raiseS (n - fv)) <$> viewTC eCheckpoints

      -- construct the initial split clause
  let sc = Tele (Dom Type)
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId (Substitution' Term)
-> Maybe (Dom Type)
-> SplitClause
SClause Tele (Dom Type)
gamma [NamedArg SplitPattern]
xs Substitution' SplitPattern
forall a. Substitution' a
idS Map CheckpointId (Substitution' Term)
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

  reportSDoc "tc.cover.top" 10 $ do
    let prCl Clause
cl = Tele (Dom Type) -> m Doc -> m Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext (Clause -> Tele (Dom Type)
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
    vcat
      [ text $ "Coverage checking " ++! prettyShow f ++! " with patterns:"
      , nest 2 $ vcat $ map' prCl cs
      ]

  -- used = actually used clauses for cover
  -- pss  = non-covered cases
  CoverResult splitTree used pss qss noex <- cover YesInferMissing f cs 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@.
  noex <- return $ IntSet.filter (< length cs) noex

  reportSDoc "tc.cover.top" 10 $ vcat
    [ "cover computed!"
    , text $ "used clauses: " ++! show used
    , text $ "non-exact clauses: " ++! show (IntSet.toList noex)
    ]
  reportSDoc "tc.cover.splittree" 10 $ vcat
    [ "generated split tree for" <+> prettyTCM f
    , text $ prettyShow splitTree
    ]
  reportSDoc "tc.cover.covering" 10 $ vcat
    [ text $ "covering patterns for " ++! prettyShow f
    , nest 2 $ vcat $ map' (\ Clause
cl -> Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext (Clause -> Tele (Dom Type)
clauseTel Clause
cl) (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg DeBruijnPattern] -> TCMT IO Doc)
-> [NamedArg DeBruijnPattern] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
cl) qss
    ]

  -- Storing the covering clauses so that checkIApplyConfluence_ can
  -- find them later.
  -- Andreas, 2019-03-27, only needed when --cubical
  -- Jesper, 2022-10-18, also needed for some backends, so keep when flag says so
  opts <- pragmaOptions
  when (isJust (optCubical opts) || optKeepCoveringClauses opts) $
    modifySignature $ updateDefinition f $ updateTheDef $ updateCovering $ const qss


  -- filter out the missing clauses that are absurd.
  pss <- ifNotM (optInferAbsurdClauses <$> pragmaOptions) (pure pss) {-else-} $
   flip filterM pss $ \(Tele (Dom Type)
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 Int)
-> (ErrorNonEmpty -> TCMT IO Bool)
-> (Int -> 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' SrcFile
-> Tele (Dom Type) -> TCMT IO (Either ErrorNonEmpty Int)
checkEmptyTel Range' SrcFile
forall a. Range' a
noRange Tele (Dom Type)
tel) (\ ErrorNonEmpty
_ -> Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True) ((Int -> TCMT IO Bool) -> TCMT IO Bool)
-> (Int -> TCMT IO Bool) -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ \ Int
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 :: Int
i = Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
l
      -- Build a substitution mapping this pattern variable to the absurd pattern.
      let sub :: Substitution' DeBruijnPattern
sub = Int -> DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. EndoSubst a => Int -> a -> Substitution' a
inplaceS Int
i (DeBruijnPattern -> Substitution' DeBruijnPattern)
-> DeBruijnPattern -> Substitution' DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ Int -> DeBruijnPattern
absurdP Int
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 { clauseLHSRange :: Range' SrcFile
clauseLHSRange  = Range' SrcFile
forall a. Range' a
noRange
                      , clauseFullRange :: Range' SrcFile
clauseFullRange = Range' SrcFile
forall a. Range' a
noRange
                      , clauseTel :: Tele (Dom Type)
clauseTel       = Tele (Dom Type)
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 :: Catchall
clauseCatchall    = Range' SrcFile -> Catchall
YesCatchall Range' SrcFile
forall a. Null a => a
empty       -- absurd clauses are safe as catch-all
                      , clauseRecursive :: ClauseRecursive
clauseRecursive   = ClauseRecursive
NotRecursive
                      , clauseUnreachable :: Maybe Bool
clauseUnreachable = Bool -> Maybe Bool
forall a. a -> Maybe a
Just Bool
False
                      , clauseEllipsis :: ExpandedEllipsis
clauseEllipsis    = ExpandedEllipsis
NoEllipsis
                      , clauseWhereModule :: Maybe ModuleName
clauseWhereModule = Maybe ModuleName
forall a. Maybe a
Nothing
                      }
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.missing" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> TCMT IO Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ do
        [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"adding missing absurd clause"
            , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ QNamed Clause -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QNamed Clause -> m Doc
prettyTCM (QNamed Clause -> TCMT IO Doc) -> QNamed Clause -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ QName -> Clause -> QNamed Clause
forall a. QName -> a -> QNamed a
QNamed QName
f Clause
cl
            ]
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.missing" Int
80 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> TCMT IO Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"l   = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Int -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Int
l
        , TCMT IO Doc
"i   = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Int -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Int
i
        , TCMT IO Doc
"cl  = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QNamed Clause -> TCMT IO 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 ()
forall (m :: * -> *).
(MonadConstraint m, MonadTCState m) =>
QName -> [Clause] -> m ()
addClauses QName
f ([Clause] -> TCMT IO ()) -> [Clause] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Clause -> [Clause]
forall el coll. Singleton el coll => el -> coll
singleton Clause
cl
      Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

  -- report a warning if there are uncovered cases,
  List1.unlessNull pss \ List1 (Tele (Dom Type), [NamedArg DeBruijnPattern])
pss -> do
    (Set QName -> f (Set QName)) -> TCState -> f TCState
Lens' TCState (Set QName)
stLocalPartialDefs Lens' TCState (Set QName) -> (Set QName -> Set QName) -> TCMT IO ()
forall (m :: * -> *) a.
MonadTCState m =>
Lens' TCState a -> (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' TCEnv CoverageCheck -> TCMT IO CoverageCheck
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC (CoverageCheck -> f CoverageCheck) -> TCEnv -> f TCEnv
Lens' TCEnv CoverageCheck
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
-> List1 (Tele (Dom Type), [NamedArg DeBruijnPattern]) -> Warning
CoverageIssue QName
f List1 (Tele (Dom Type), [NamedArg DeBruijnPattern])
pss

  -- Andreas, 2017-08-28, issue #2723:
  -- Mark clauses as reachable or unreachable in the signature.
  let cs1 = [Int] -> [Clause] -> [(Int, Clause)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Int
0..] [Clause]
cs [(Int, Clause)] -> ((Int, Clause) -> Clause) -> [Clause]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ (Int
i, Clause
cl) -> Clause
cl
             { clauseUnreachable = Just $ i `IntSet.notMember` used
             }

  -- Replace the first clauses by @cs1@.  There might be more
  -- added by @inferMissingClause@.
  modifyFunClauses f $ \ [Clause]
cs0 -> [Clause]
cs1 [Clause] -> [Clause] -> [Clause]
forall a. [a] -> [a] -> [a]
++! Int -> [Clause] -> [Clause]
forall a. Int -> [a] -> [a]
drop ([Clause] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Clause]
cs1) [Clause]
cs0

  -- Warn if there are unreachable clauses and mark them as unreachable.
  List1.unlessNull (filter ((Just True ==) . clauseUnreachable) cs1) \ List1 Clause
unreached -> do
    -- Warn about unreachable clauses.
    let ranges :: NonEmpty (Range' SrcFile)
ranges = (Clause -> Range' SrcFile)
-> List1 Clause -> NonEmpty (Range' SrcFile)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Clause -> Range' SrcFile
clauseFullRange List1 Clause
unreached
    NonEmpty (Range' SrcFile) -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NonEmpty (Range' SrcFile)
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 -> NonEmpty (Range' SrcFile) -> Warning
UnreachableClauses QName
f NonEmpty (Range' SrcFile)
ranges

  -- Partition clauses into exact and non-exact ones.
  let (noexclauses, exclauses) = partitionEithers $
        zipWith (\ Int
i Clause
c  -> if Int
i Int -> IntSet -> Bool
`IntSet.member` IntSet
noex then Clause -> Either Clause Clause
forall a b. a -> Either a b
Left Clause
c else Clause -> Either Clause Clause
forall a b. b -> Either a b
Right Clause
c) [0..] cs1

  -- Report a warning if there are clauses that are not preserved as
  -- definitional equalities and --exact-split is enabled
  -- and they are not labelled as CATCHALL.
  List1.unlessNull (filter (null . clauseCatchall) noexclauses) \ List1 Clause
noexclauses -> do
      NonEmpty (Range' SrcFile) -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange ((Clause -> Range' SrcFile)
-> List1 Clause -> NonEmpty (Range' SrcFile)
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Clause -> Range' SrcFile
clauseLHSRange List1 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 -> List1 Clause -> Warning
CoverageNoExactSplit QName
f List1 Clause
noexclauses

  -- Warn about unused CATCHALL pragmas.
  forM_ exclauses \ Clause
c ->
    case Clause -> Catchall
clauseCatchall Clause
c of
      YesCatchall Range' SrcFile
r | Bool -> Bool
not (Range' SrcFile -> Bool
forall a. Null a => a -> Bool
null Range' SrcFile
r)
        -> Range' SrcFile -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range' SrcFile
r (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
$ Range' SrcFile -> Doc -> Warning
UselessPragma Range' SrcFile
r (Doc -> Warning) -> Doc -> Warning
forall a b. (a -> b) -> a -> b
$ Doc
"Superfluous CATCHALL pragma"
      Catchall
_ -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()

  return splitTree

-- | When checking whether a clause is already covered,
--   we do not want 'inferMissingClause' as a side effect.
data InferMissing
  = YesInferMissing  -- ^ Infer missing instance and tactic clauses.
  | NoInferMissing   -- ^ Don't.
  deriving (InferMissing -> InferMissing -> Bool
(InferMissing -> InferMissing -> Bool)
-> (InferMissing -> InferMissing -> Bool) -> Eq InferMissing
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: InferMissing -> InferMissing -> Bool
== :: InferMissing -> InferMissing -> Bool
$c/= :: InferMissing -> InferMissing -> Bool
/= :: InferMissing -> InferMissing -> Bool
Eq, Int -> InferMissing -> [Char] -> [Char]
[InferMissing] -> [Char] -> [Char]
InferMissing -> [Char]
(Int -> InferMissing -> [Char] -> [Char])
-> (InferMissing -> [Char])
-> ([InferMissing] -> [Char] -> [Char])
-> Show InferMissing
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> InferMissing -> [Char] -> [Char]
showsPrec :: Int -> InferMissing -> [Char] -> [Char]
$cshow :: InferMissing -> [Char]
show :: InferMissing -> [Char]
$cshowList :: [InferMissing] -> [Char] -> [Char]
showList :: [InferMissing] -> [Char] -> [Char]
Show)

-- | 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
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.isCovered" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"isCovered"
    , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
      [ TCMT IO Doc
"f  = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
f
      , TCMT IO Doc
"cs = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ((Clause -> TCMT IO Doc) -> [Clause] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map' (Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc)
-> (Clause -> TCMT IO Doc) -> Clause -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedClause -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => NamedClause -> m Doc
prettyTCM (NamedClause -> TCMT IO Doc)
-> (Clause -> NamedClause) -> Clause -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Bool -> Clause -> NamedClause
NamedClause QName
f Bool
True) [Clause]
cs)
      , TCMT IO Doc
"sc = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> SplitClause -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => SplitClause -> m Doc
prettyTCM SplitClause
sc
      ]
    ]
  -- Jesper, 2019-10: introduce trailing arguments (see #3828)
  (_ , sc') <- Bool -> SplitClause -> TCM (Tele (Dom Type), SplitClause)
insertTrailingArgs Bool
True SplitClause
sc
  CoverResult { coverMissingClauses = missing } <- cover NoInferMissing f cs sc'
  return $ null 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 a. TCMT IO a -> (TCErr -> TCMT IO a) -> TCMT IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \ TCErr
_ -> Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | @cover infermissing f cs (SClause _ _ ps _) = return (CoverResult splitTree used missing covering noex)@.
--   checks that the list of clauses @cs@ covers the given split clause.
--   Returns the @splitTree@, the @used@ clauses, @missing@ cases, the @covering@ clauses,
--   and the non-exact clauses @noex@.
--
--   Effect: if 'YesInferMissing', adds missing instance clauses for @f@ to signature.
--
cover :: InferMissing -> QName -> [Clause] -> SplitClause ->
         TCM CoverResult
cover :: InferMissing -> QName -> [Clause] -> SplitClause -> TCM CoverResult
cover InferMissing
infermissing QName
f [Clause]
cs sc :: SplitClause
sc@(SClause Tele (Dom Type)
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId (Substitution' Term)
_ 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
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.cover" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc -> TCMT IO Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"checking coverage of pattern:"
    , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ SplitClause -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => SplitClause -> m Doc
prettyTCM SplitClause
sc
    , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target sort =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
-> (Dom Type -> TCMT IO Doc) -> Maybe (Dom Type) -> TCMT IO Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"<none>") (Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM (Sort' Term -> TCMT IO Doc)
-> (Dom Type -> Sort' Term) -> Dom Type -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Type -> Sort' Term
forall a. LensSort a => a -> Sort' Term
getSort (Type -> Sort' Term)
-> (Dom Type -> Type) -> Dom Type -> Sort' Term
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
    ]
  [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.cover.cover" Int
80 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"raw target =\n" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Maybe (Dom Type) -> [Char]
forall a. Show a => a -> [Char]
show Maybe (Dom Type)
target
  [Char] -> Int -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). MonadDebug m => [Char] -> Int -> m () -> m ()
verboseS  [Char]
"tc.cover.matching" Int
20 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.cover.matching" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"clauses when matching:"
    [Clause] -> (Clause -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [Clause]
cs ((Clause -> TCMT IO ()) -> TCMT IO ())
-> (Clause -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ \ Clause
c -> do
      let gamma :: Tele (Dom Type)
gamma = Clause -> Tele (Dom Type)
clauseTel Clause
c
          ps :: [NamedArg DeBruijnPattern]
ps = Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
c
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.matching" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
gamma (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
          TCMT IO Doc
"ps   :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [DeBruijnPattern] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [DeBruijnPattern] -> m Doc
prettyTCM ((NamedArg DeBruijnPattern -> DeBruijnPattern)
-> [NamedArg DeBruijnPattern] -> [DeBruijnPattern]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap NamedArg DeBruijnPattern -> DeBruijnPattern
forall a. NamedArg a -> a
namedArg [NamedArg DeBruijnPattern]
ps)

  [Clause]
-> [NamedArg SplitPattern]
-> TCMT IO (Match (Int, [(Int, SplitPattern)]))
forall (m :: * -> *).
PureTCM m =>
[Clause]
-> [NamedArg SplitPattern]
-> m (Match (Int, [(Int, SplitPattern)]))
match [Clause]
cs [NamedArg SplitPattern]
ps TCMT IO (Match (Int, [(Int, SplitPattern)]))
-> (Match (Int, [(Int, SplitPattern)]) -> TCM CoverResult)
-> TCM CoverResult
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Yes (Int
i,[(Int, SplitPattern)]
mps) -> do
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.cover.cover" Int
10 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"pattern covered by clause " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Int -> [Char]
forall a. Show a => a -> [Char]
show Int
i
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.cover" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"with mps = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [(Int, SplitPattern)] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [(Int, SplitPattern)]
mps
      let cl0 :: Clause
cl0 = Clause -> [Clause] -> Int -> Clause
forall a. a -> [a] -> Int -> a
indexWithDefault Clause
forall a. HasCallStack => a
__IMPOSSIBLE__ [Clause]
cs Int
i
      -- Szumi, 2024-09-15, issue #7495: If the split clause has more
      -- patterns than the function clause, then the extra patterns need to
      -- be trivial for the clause to be exact
      let extra :: [NamedArg SplitPattern]
extra = Int -> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Int -> [a] -> [a]
drop ([NamedArg DeBruijnPattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([NamedArg DeBruijnPattern] -> Int)
-> [NamedArg DeBruijnPattern] -> Int
forall a b. (a -> b) -> a -> b
$ Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
cl0) [NamedArg SplitPattern]
ps
      exact <-
        TCMT IO Bool -> TCMT IO Bool -> TCMT IO Bool
forall (m :: * -> *). Monad m => m Bool -> m Bool -> m Bool
and2M
          ([(Int, SplitPattern)]
-> ((Int, SplitPattern) -> TCMT IO Bool) -> TCMT IO Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
f a -> (a -> m Bool) -> m Bool
forallM [(Int, SplitPattern)]
mps (((Int, SplitPattern) -> TCMT IO Bool) -> TCMT IO Bool)
-> ((Int, 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)
-> ((Int, SplitPattern) -> SplitPattern)
-> (Int, SplitPattern)
-> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Int, SplitPattern) -> SplitPattern
forall a b. (a, b) -> b
snd)
          ([NamedArg SplitPattern]
-> (NamedArg SplitPattern -> TCMT IO Bool) -> TCMT IO Bool
forall (f :: * -> *) (m :: * -> *) a.
(Foldable f, Monad m) =>
f a -> (a -> m Bool) -> m Bool
forallM [NamedArg SplitPattern]
extra ((NamedArg SplitPattern -> TCMT IO Bool) -> TCMT IO Bool)
-> (NamedArg 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)
-> (NamedArg SplitPattern -> SplitPattern)
-> NamedArg SplitPattern
-> TCMT IO Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg SplitPattern -> SplitPattern
forall a. NamedArg a -> a
namedArg)
      cl <- applyCl sc cl0 mps
      return $ CoverResult
        { coverSplitTree      = SplittingDone (size tel)
        , coverUsedClauses    = singleton i
        , coverMissingClauses = []
        , coverPatterns       = [cl]
        , coverNoExactClauses = if exact then empty else singleton i
        }

    Match (Int, [(Int, SplitPattern)])
No        ->  do
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.cover" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"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 InferMissing
infermissing InferMissing -> InferMissing -> Bool
forall a. Eq a => a -> a -> Bool
== InferMissing
YesInferMissing Bool -> Bool -> Bool
&& 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.
          cl <- QName -> SplitClause -> TCM Clause
inferMissingClause QName
f SplitClause
sc
          return $ CoverResult (SplittingDone (size tel)) empty [] [cl] empty
        else do
          let ps' :: [NamedArg DeBruijnPattern]
ps' = [NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
ps
          CoverResult -> TCM CoverResult
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverResult -> TCM CoverResult) -> CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ SplitTree' SplitTag
-> IntSet
-> [(Tele (Dom Type), [NamedArg DeBruijnPattern])]
-> [Clause]
-> IntSet
-> CoverResult
CoverResult (Int -> SplitTree' SplitTag
forall a. Int -> SplitTree' a
SplittingDone (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel)) IntSet
forall a. Null a => a
empty [(Tele (Dom Type)
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 [BlockingVar]
bs -> BlockedOnResult
-> Bool
-> (SplitError -> TCM CoverResult)
-> TCM CoverResult
-> TCM CoverResult
trySplitRes BlockedOnResult
res ([BlockingVar] -> Bool
forall a. Null a => a -> Bool
null [BlockingVar]
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 b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
when ([BlockingVar] -> Bool
forall a. Null a => a -> Bool
null [BlockingVar]
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.
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.cover.strategy" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"blocking vars = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! [BlockingVar] -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow [BlockingVar]
bs
      -- xs is a non-empty lists of blocking variables
      -- try splitting on one of them
      xs <- [BlockingVar] -> Tele (Dom Type) -> TCM [BlockingVar]
splitStrategy [BlockingVar]
bs Tele (Dom Type)
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.
      continue xs NoAllowPartialCover $ \ SplitError
_err -> do
        [BlockingVar]
-> AllowPartialCover
-> (SplitError -> TCM CoverResult)
-> TCM CoverResult
continue [BlockingVar]
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 :: forall a. 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 :: forall a. TCM a -> TCM a
withRangeOfCandidateClauses TCM a
cont = do
      cands <- ((Clause, Match (DList (Int, SplitPattern))) -> Maybe Clause)
-> [(Clause, Match (DList (Int, SplitPattern)))] -> [Clause]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe ((Clause -> Match (DList (Int, SplitPattern)) -> Maybe Clause)
-> (Clause, Match (DList (Int, SplitPattern))) -> Maybe Clause
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry Clause -> Match (DList (Int, SplitPattern)) -> Maybe Clause
forall a. Clause -> Match a -> Maybe Clause
notNo) ([(Clause, Match (DList (Int, SplitPattern)))] -> [Clause])
-> ([Match (DList (Int, SplitPattern))]
    -> [(Clause, Match (DList (Int, SplitPattern)))])
-> [Match (DList (Int, SplitPattern))]
-> [Clause]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Clause]
-> [Match (DList (Int, SplitPattern))]
-> [(Clause, Match (DList (Int, SplitPattern)))]
forall a b. [a] -> [b] -> [(a, b)]
zip [Clause]
cs ([Match (DList (Int, SplitPattern))] -> [Clause])
-> TCMT IO [Match (DList (Int, SplitPattern))] -> TCMT IO [Clause]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Clause -> TCMT IO (Match (DList (Int, SplitPattern))))
-> [Clause] -> TCMT IO [Match (DList (Int, SplitPattern))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ([NamedArg SplitPattern]
-> Clause -> TCMT IO (Match (DList (Int, SplitPattern)))
forall (m :: * -> *).
PureTCM m =>
[NamedArg SplitPattern]
-> Clause -> m (Match (DList (Int, SplitPattern)))
matchClause [NamedArg SplitPattern]
ps) [Clause]
cs
      setCurrentRange cands cont
      where
        notNo :: Clause -> Match a -> Maybe Clause
        notNo :: forall a. 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

    -- Rename the variables in a telescope in accordance with their
    -- first appearance in the given NAPs. This is done to preserve
    -- variable names in IApplyConfluence error messages. Specifically,
    -- consider e.g.
    --
    --  data T : Set where
    --    x : T
    --    p : Path (Path T x x) refl refl
    --  f (p i j) = ...
    --
    -- When generating the covering clause corresponding to f's clause,
    -- the names we have in scope are i and i₁, since those are the
    -- names of both PathP binder arguments. (recall Path A x y = PathP (λ i → A) x y)
    -- So if we tried to print (Var 0 []) in the context of
    -- IApplyConfluence for that clause, what we see isn't j, it's i₁.
    --
    -- This function takes "name suggestions" from both variable
    -- patterns and IApply co/patterns, and replaces any existing names
    -- in the telescope by the name in that pattern.
    renTeleFromNap :: SplitClause -> Clause -> Telescope
    renTeleFromNap :: SplitClause -> Clause -> Tele (Dom Type)
renTeleFromNap SClause{scTel :: SplitClause -> Tele (Dom Type)
scTel = Tele (Dom Type)
tel, scPats :: SplitClause -> [NamedArg SplitPattern]
scPats = [NamedArg SplitPattern]
sps} Clause
clause =
      ListTel -> Tele (Dom Type)
telFromList (ListTel -> Tele (Dom Type)) -> ListTel -> Tele (Dom Type)
forall a b. (a -> b) -> a -> b
$ State Int ListTel -> Int -> ListTel
forall s a. State s a -> s -> a
evalState ((Dom' Term ([Char], Type)
 -> StateT Int Identity (Dom' Term ([Char], Type)))
-> ListTel -> State Int ListTel
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse Dom' Term ([Char], Type)
-> StateT Int Identity (Dom' Term ([Char], Type))
upd (Tele (Dom Type) -> ListTel
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Tele (Dom Type)
tel)) (Int
size Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
offset)
      where
        ps :: [NamedArg DeBruijnPattern]
ps = Clause -> [NamedArg DeBruijnPattern]
namedClausePats Clause
clause
        offset :: Int
offset = Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [NamedArg DeBruijnPattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([NamedArg SplitPattern] -> [NamedArg DeBruijnPattern]
fromSplitPatterns [NamedArg SplitPattern]
sps) Int -> Int -> Int
forall a. Num a => a -> a -> a
- [NamedArg DeBruijnPattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NamedArg DeBruijnPattern]
ps
        -- Fold a single pattern into a map of name suggestions:
        -- In the running example above, we have
        --    f (p i@1 j@0)
        -- so the map that nameSuggest (p ...) returns is {0 → j, 1 → j}
        nameSuggest :: DeBruijnPattern -> IntMap ArgName
        nameSuggest :: DeBruijnPattern -> IntMap [Char]
nameSuggest DeBruijnPattern
ps = ((DeBruijnPattern -> IntMap [Char])
 -> DeBruijnPattern -> IntMap [Char])
-> DeBruijnPattern
-> (DeBruijnPattern -> IntMap [Char])
-> IntMap [Char]
forall a b c. (a -> b -> c) -> b -> a -> c
flip (DeBruijnPattern -> IntMap [Char])
-> DeBruijnPattern -> IntMap [Char]
forall a b m.
(PatternLike a b, Monoid m) =>
(Pattern' a -> m) -> b -> m
foldPattern DeBruijnPattern
ps ((DeBruijnPattern -> IntMap [Char]) -> IntMap [Char])
-> (DeBruijnPattern -> IntMap [Char]) -> IntMap [Char]
forall a b. (a -> b) -> a -> b
$ \case
          VarP PatternInfo
_ DBPatVar
i | DBPatVar -> [Char]
dbPatVarName DBPatVar
i [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"_" ->
            Int -> [Char] -> IntMap [Char]
forall a. Int -> a -> IntMap a
IntMap.singleton (DBPatVar -> Int
dbPatVarIndex DBPatVar
i) (DBPatVar -> [Char]
dbPatVarName DBPatVar
i)
          IApplyP PatternInfo
_ Term
_ Term
_ DBPatVar
i | DBPatVar -> [Char]
dbPatVarName DBPatVar
i [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/= [Char]
"_" ->
            Int -> [Char] -> IntMap [Char]
forall a. Int -> a -> IntMap a
IntMap.singleton (DBPatVar -> Int
dbPatVarIndex DBPatVar
i) (DBPatVar -> [Char]
dbPatVarName DBPatVar
i)
          DeBruijnPattern
_ -> IntMap [Char]
forall a. Monoid a => a
mempty

        -- Suggestions from all patterns..
        suggestions :: IntMap [Char]
suggestions = (NamedArg DeBruijnPattern -> IntMap [Char])
-> [NamedArg DeBruijnPattern] -> IntMap [Char]
forall m a. Monoid m => (a -> m) -> [a] -> m
forall (t :: * -> *) m a.
(Foldable t, Monoid m) =>
(a -> m) -> t a -> m
foldMap (DeBruijnPattern -> IntMap [Char]
nameSuggest (DeBruijnPattern -> IntMap [Char])
-> (NamedArg DeBruijnPattern -> DeBruijnPattern)
-> NamedArg DeBruijnPattern
-> IntMap [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named NamedName DeBruijnPattern -> DeBruijnPattern
forall name a. Named name a -> a
namedThing (Named NamedName DeBruijnPattern -> DeBruijnPattern)
-> (NamedArg DeBruijnPattern -> Named NamedName DeBruijnPattern)
-> NamedArg DeBruijnPattern
-> DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg DeBruijnPattern -> Named NamedName DeBruijnPattern
forall e. Arg e -> e
unArg) [NamedArg DeBruijnPattern]
ps

        -- The state will start counting from (length Γ - 1), which is
        -- the *highest* variable index, i.e. the index of the variable
        -- with level 0. Instead of doing a lot of de Bruijn arithmetic
        -- + recursion, traverse handles iteration and the State handles
        -- counting down.
        size :: Int
size = ListTel -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Tele (Dom Type) -> ListTel
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Tele (Dom Type)
tel)

        upd :: Dom (ArgName , Type) -> State Int (Dom (ArgName , Type))
        upd :: Dom' Term ([Char], Type)
-> StateT Int Identity (Dom' Term ([Char], Type))
upd Dom' Term ([Char], Type)
dom = (Int -> (Dom' Term ([Char], Type), Int))
-> StateT Int Identity (Dom' Term ([Char], Type))
forall a. (Int -> (a, Int)) -> StateT Int Identity a
forall s (m :: * -> *) a. MonadState s m => (s -> (a, s)) -> m a
state ((Int -> (Dom' Term ([Char], Type), Int))
 -> StateT Int Identity (Dom' Term ([Char], Type)))
-> (Int -> (Dom' Term ([Char], Type), Int))
-> StateT Int Identity (Dom' Term ([Char], Type))
forall a b. (a -> b) -> a -> b
$ \Int
s -> do
          case Int -> IntMap [Char] -> Maybe [Char]
forall a. Int -> IntMap a -> Maybe a
IntMap.lookup Int
s IntMap [Char]
suggestions of
            Just [Char]
nm' ->
              let !dom' :: Dom' Term ([Char], Type)
dom' = ASetter
  (Dom' Term ([Char], Type))
  (Dom' Term ([Char], Type))
  (Maybe NamedName)
  (Maybe NamedName)
-> Maybe NamedName
-> Dom' Term ([Char], Type)
-> Dom' Term ([Char], Type)
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Dom' Term ([Char], Type))
  (Dom' Term ([Char], Type))
  (Maybe NamedName)
  (Maybe NamedName)
forall t e (f :: * -> *).
Functor f =>
(Maybe NamedName -> f (Maybe NamedName))
-> Dom' t e -> f (Dom' t e)
dName (NamedName -> Maybe NamedName
forall a. a -> Maybe a
Just (Origin -> Ranged [Char] -> NamedName
forall a. Origin -> a -> WithOrigin a
WithOrigin Origin
CaseSplit ([Char] -> Ranged [Char]
forall a. a -> Ranged a
unranged [Char]
nm'))) (Dom' Term ([Char], Type) -> Dom' Term ([Char], Type))
-> Dom' Term ([Char], Type) -> Dom' Term ([Char], Type)
forall a b. (a -> b) -> a -> b
$
                         (([Char], Type) -> ([Char], Type))
-> Dom' Term ([Char], Type) -> Dom' Term ([Char], Type)
forall a b. (a -> b) -> Dom' Term a -> Dom' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (([Char], Type) -> ([Char], Type) -> ([Char], Type)
forall a b. a -> b -> a
const (([Char]
nm' , ([Char], Type) -> Type
forall a b. (a, b) -> b
snd (Dom' Term ([Char], Type) -> ([Char], Type)
forall t e. Dom' t e -> e
unDom Dom' Term ([Char], Type)
dom)))) Dom' Term ([Char], Type)
dom
                  !s' :: Int
s' = Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
              in (Dom' Term ([Char], Type)
dom', Int
s')
            Maybe [Char]
Nothing -> (Dom' Term ([Char], Type)
dom ,) (Int -> (Dom' Term ([Char], Type), Int))
-> Int -> (Dom' Term ([Char], Type), Int)
forall a b. (a -> b) -> a -> b
$! Int
s Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1

    applyCl :: SplitClause -> Clause -> [(Nat, SplitPattern)] -> TCM Clause
    applyCl :: SplitClause -> Clause -> [(Int, SplitPattern)] -> TCM Clause
applyCl sc :: SplitClause
sc@SClause{scTel :: SplitClause -> Tele (Dom Type)
scTel = Tele (Dom Type)
pretel, scPats :: SplitClause -> [NamedArg SplitPattern]
scPats = [NamedArg SplitPattern]
sps} Clause
cl [(Int, SplitPattern)]
mps
        | Tele (Dom Type)
tel <- SplitClause -> Clause -> Tele (Dom Type)
renTeleFromNap SplitClause
sc Clause
cl = Tele (Dom Type) -> TCM Clause -> TCM Clause
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
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
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.applyCl" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"applyCl"
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.applyCl" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"pretel =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom Type) -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Tele (Dom Type)
pretel
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.applyCl" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"tel    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom Type) -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Tele (Dom Type)
tel
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.applyCl" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"ps     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
ps
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.applyCl" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"mps    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [(Int, SplitPattern)] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [(Int, SplitPattern)]
mps
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.applyCl" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"s      =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' DeBruijnPattern -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Substitution' DeBruijnPattern
s
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.applyCl" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"ps[s]  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCMT IO 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 = Int -> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Int -> [a] -> [a]
drop ([NamedArg DeBruijnPattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
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 :: Int
n_extra = [NamedArg DeBruijnPattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NamedArg DeBruijnPattern]
extra

        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.applyCl" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"extra  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCMT IO 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.

        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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe 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)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse) (Int -> Type -> TCMT IO (TelV Type)
forall (m :: * -> *). PureTCM m => Int -> Type -> m (TelV Type)
telViewUpToPath Int
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 = ((Arg (TelV Type) -> Arg Type)
-> Maybe (Arg (TelV Type)) -> Maybe (Arg Type)
forall a b. (a -> b) -> Maybe a -> Maybe b
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 a b. (a -> b) -> Arg a -> Arg b
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` Int
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. Int -> Substitution' a -> Substitution' a
liftS Int
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
        let body = (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
        let pats = (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

        reportSDoc "tc.cover.applyCl" 40 $ "new ty =" <+> pretty ty
        reportSDoc "tc.cover.applyCl" 40 $ "new pats =" <+> pretty pats
        reportSDoc "tc.cover.applyCl" 40 $ "new body =" <+> pretty body

        return $
             Clause { clauseLHSRange  = clauseLHSRange cl
                    , clauseFullRange = clauseFullRange cl
                    , clauseTel       = tel
                    , namedClausePats = pats
                    , clauseBody      = body
                    , clauseType      = ty
                    , clauseCatchall    = clauseCatchall cl
                    , clauseRecursive   = clauseRecursive cl
                    , clauseUnreachable = clauseUnreachable cl
                    , clauseEllipsis    = clauseEllipsis cl
                    , clauseWhereModule = clauseWhereModule cl
                    }
      where
      mps' :: Map Int DeBruijnPattern
mps' =
        [(Int, DeBruijnPattern)] -> Map Int DeBruijnPattern
forall k a. Ord k => [(k, a)] -> Map k a
Map.fromList ([(Int, DeBruijnPattern)] -> Map Int DeBruijnPattern)
-> [(Int, DeBruijnPattern)] -> Map Int DeBruijnPattern
forall a b. (a -> b) -> a -> b
$
        ((Int, SplitPattern) -> (Int, DeBruijnPattern))
-> [(Int, SplitPattern)] -> [(Int, DeBruijnPattern)]
forall a b. (a -> b) -> [a] -> [b]
map' ((SplitPattern -> DeBruijnPattern)
-> (Int, SplitPattern) -> (Int, DeBruijnPattern)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second (NamedArg DeBruijnPattern -> DeBruijnPattern
forall a. NamedArg a -> a
namedArg (NamedArg DeBruijnPattern -> DeBruijnPattern)
-> (SplitPattern -> NamedArg DeBruijnPattern)
-> SplitPattern
-> DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg SplitPattern -> NamedArg DeBruijnPattern
fromSplitPattern (NamedArg SplitPattern -> NamedArg DeBruijnPattern)
-> (SplitPattern -> NamedArg SplitPattern)
-> SplitPattern
-> NamedArg DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. SplitPattern -> NamedArg SplitPattern
forall a. a -> NamedArg a
defaultNamedArg)) [(Int, SplitPattern)]
mps
      s :: Substitution' DeBruijnPattern
s = [DeBruijnPattern] -> Substitution' DeBruijnPattern
forall a. DeBruijn a => [a] -> Substitution' a
parallelS ([Int] -> (Int -> DeBruijnPattern) -> [DeBruijnPattern]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
for (case Map Int DeBruijnPattern -> Maybe (Int, DeBruijnPattern)
forall k a. Map k a -> Maybe (k, a)
Map.lookupMax Map Int DeBruijnPattern
mps' of
                            Maybe (Int, DeBruijnPattern)
Nothing     -> []
                            Just (Int
i, DeBruijnPattern
_) -> [Int
0..Int
i]) ((Int -> DeBruijnPattern) -> [DeBruijnPattern])
-> (Int -> DeBruijnPattern) -> [DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ \ Int
i ->
                     DeBruijnPattern -> Maybe DeBruijnPattern -> DeBruijnPattern
forall a. a -> Maybe a -> a
fromMaybe (Int -> DeBruijnPattern
forall a. DeBruijn a => Int -> a
deBruijnVar Int
i) (Int -> Map Int DeBruijnPattern -> Maybe DeBruijnPattern
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup Int
i Map Int DeBruijnPattern
mps'))

    updateRelevance :: TCM a -> TCM a
    updateRelevance :: forall a. 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!
        Dom Type -> TCM a -> TCM a
forall e a. Dom e -> TCM a -> TCM a
applyDomToContext Dom Type
b TCM a
cont

    continue
      :: [BlockingVar]
      -> AllowPartialCover
      -> (SplitError -> TCM CoverResult)
      -> TCM CoverResult
    continue :: [BlockingVar]
-> AllowPartialCover
-> (SplitError -> TCM CoverResult)
-> TCM CoverResult
continue [BlockingVar]
xs AllowPartialCover
allowPartialCover SplitError -> TCM CoverResult
handle = do
      r <- (BlockingVar
 -> TCMT IO (Either SplitError (Covering, BlockingVar)))
-> [BlockingVar]
-> 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 a b. (a -> b) -> Either SplitError a -> Either SplitError b
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) [BlockingVar]
xs
      case 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 Int
n [], BlockingVar
_) ->
         do
          -- TODO Andrea: I guess an empty pattern is not part of the cover?
          let qs :: [a]
qs = []
          CoverResult -> TCM CoverResult
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CoverResult -> TCM CoverResult) -> CoverResult -> TCM CoverResult
forall a b. (a -> b) -> a -> b
$ SplitTree' SplitTag
-> IntSet
-> [(Tele (Dom Type), [NamedArg DeBruijnPattern])]
-> [Clause]
-> IntSet
-> CoverResult
CoverResult (Int -> SplitTree' SplitTag
forall a. Int -> SplitTree' a
SplittingDone (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel)) IntSet
forall a. Null a => a
empty [] [Clause]
forall a. [a]
qs IntSet
forall a. Null a => a
empty
        Right (Covering Arg Int
n [(SplitTag, (SplitClause, IInfo))]
scs', BlockingVar
x) -> do
          let scs :: [(SplitTag, SplitClause)]
scs = ((SplitTag, (SplitClause, IInfo)) -> (SplitTag, SplitClause))
-> [(SplitTag, (SplitClause, IInfo))] -> [(SplitTag, SplitClause)]
forall a b. (a -> b) -> [a] -> [b]
map' (\(SplitTag
t,(SplitClause
sc,IInfo
i)) -> (SplitTag
t,SplitClause
sc)) [(SplitTag, (SplitClause, IInfo))]
scs'

          (results_trX, cs) <- QName
-> Arg Int
-> BlockingVar
-> SplitClause
-> [(SplitTag, (SplitClause, IInfo))]
-> [Clause]
-> TCM ([(SplitTag, CoverResult)], [Clause])
createMissingIndexedClauses QName
f Arg Int
n BlockingVar
x SplitClause
sc [(SplitTag, (SplitClause, IInfo))]
scs' [Clause]
cs
          (scs, cs, results_hc) <- do
            let fallback = ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)])
-> TCMT
     IO ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)])
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(SplitTag, SplitClause)]
scs, [Clause]
cs, [])
            caseMaybeM (getPrimitiveName' builtinHComp) fallback $ \ 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 ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)])
-> ((SplitTag, SplitClause)
    -> TCMT
         IO
         ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)]))
-> TCMT
     IO ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)])
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 ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)])
fallback (((SplitTag, SplitClause)
  -> TCMT
       IO
       ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)]))
 -> TCMT
      IO
      ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)]))
-> ((SplitTag, SplitClause)
    -> TCMT
         IO
         ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)]))
-> TCMT
     IO ([(SplitTag, SplitClause)], [Clause], [(SplitTag, CoverResult)])
forall a b. (a -> b) -> a -> b
$ \ (SplitTag
sp, SplitClause
newSc) -> do
            (res,cs') <- QName
-> Arg Int
-> BlockingVar
-> SplitClause
-> SplitClause
-> [Clause]
-> TCM ([(SplitTag, CoverResult)], [Clause])
createMissingHCompClause QName
f Arg Int
n BlockingVar
x SplitClause
sc SplitClause
newSc [Clause]
cs
            let scs2 = ((SplitTag, SplitClause) -> Bool)
-> [(SplitTag, SplitClause)] -> [(SplitTag, SplitClause)]
forall a. (a -> Bool) -> [a] -> [a]
filter (Bool -> Bool
not (Bool -> Bool)
-> ((SplitTag, SplitClause) -> Bool)
-> (SplitTag, SplitClause)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
            return (scs2,cs',res)

          results <- mapM (cover infermissing f cs . snd) scs
          let
            results_extra = [(SplitTag, CoverResult)]
results_hc [(SplitTag, CoverResult)]
-> [(SplitTag, CoverResult)] -> [(SplitTag, CoverResult)]
forall a. [a] -> [a] -> [a]
++! [(SplitTag, CoverResult)]
results_trX
            trees_extra   = ((SplitTag, CoverResult) -> (SplitTag, SplitTree' SplitTag))
-> [(SplitTag, CoverResult)] -> [(SplitTag, SplitTree' SplitTag)]
forall a b. (a -> b) -> [a] -> [b]
map' ((CoverResult -> SplitTree' SplitTag)
-> (SplitTag, CoverResult) -> (SplitTag, SplitTree' SplitTag)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second CoverResult -> SplitTree' SplitTag
coverSplitTree) [(SplitTag, CoverResult)]
results_extra
            results'      = [CoverResult]
results [CoverResult] -> [CoverResult] -> [CoverResult]
forall a. [a] -> [a] -> [a]
++! ((SplitTag, CoverResult) -> CoverResult)
-> [(SplitTag, CoverResult)] -> [CoverResult]
forall a b. (a -> b) -> [a] -> [b]
map' (SplitTag, CoverResult) -> CoverResult
forall a b. (a, b) -> b
snd [(SplitTag, CoverResult)]
results_extra
            -- Andreas, 2025-10-12: add trees_extra later because they would get lost
            -- by the zipWith that constructs trees' below.
            trees = (CoverResult -> SplitTree' SplitTag)
-> [CoverResult] -> [SplitTree' SplitTag]
forall a b. (a -> b) -> [a] -> [b]
map' CoverResult -> SplitTree' SplitTag
coverSplitTree      [CoverResult]
results   -- missing ' is not a typo
            useds = (CoverResult -> IntSet) -> [CoverResult] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map' CoverResult -> IntSet
coverUsedClauses    [CoverResult]
results'
            psss  = (CoverResult -> [(Tele (Dom Type), [NamedArg DeBruijnPattern])])
-> [CoverResult]
-> [[(Tele (Dom Type), [NamedArg DeBruijnPattern])]]
forall a b. (a -> b) -> [a] -> [b]
map' CoverResult -> [(Tele (Dom Type), [NamedArg DeBruijnPattern])]
coverMissingClauses [CoverResult]
results'
            qsss  = (CoverResult -> [Clause]) -> [CoverResult] -> [[Clause]]
forall a b. (a -> b) -> [a] -> [b]
map' CoverResult -> [Clause]
coverPatterns       [CoverResult]
results'
            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).
          addContext tel $ reportSDoc "tc.cover.split.eta" 60 $ vcat
            [ "etaRecordSplits"
            , nest 2 $ vcat
              [ "n   = " <+> text (show n)
              , "scs = " <+> prettyTCM scs
              , "ps  = " <+> inTopContext (addContext tel $ prettyTCMPatternList $ fromSplitPatterns ps)
              ]
            ]
          let trees' = (SplitTree' SplitTag
 -> (SplitTag, SplitClause) -> (SplitTag, SplitTree' SplitTag))
-> [SplitTree' SplitTag]
-> [(SplitTag, SplitClause)]
-> [(SplitTag, SplitTree' SplitTag)]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith ((SplitClause -> SplitTree' SplitTag)
-> (SplitTag, SplitClause) -> (SplitTag, SplitTree' SplitTag)
forall b c a. (b -> c) -> (a, b) -> (a, c)
forall (p :: * -> * -> *) b c a.
Bifunctor p =>
(b -> c) -> p a b -> p a c
second ((SplitClause -> SplitTree' SplitTag)
 -> (SplitTag, SplitClause) -> (SplitTag, SplitTree' SplitTag))
-> (SplitTree' SplitTag -> SplitClause -> SplitTree' SplitTag)
-> SplitTree' SplitTag
-> (SplitTag, SplitClause)
-> (SplitTag, SplitTree' SplitTag)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int
-> [NamedArg SplitPattern]
-> SplitTree' SplitTag
-> SplitClause
-> SplitTree' SplitTag
etaRecordSplits (Arg Int -> Int
forall e. Arg e -> e
unArg Arg Int
n) [NamedArg SplitPattern]
ps) [SplitTree' SplitTag]
trees [(SplitTag, SplitClause)]
scs
              tree   = Arg Int
-> LazySplit
-> [(SplitTag, SplitTree' SplitTag)]
-> SplitTree' SplitTag
forall a. Arg Int -> LazySplit -> SplitTrees' a -> SplitTree' a
SplitAt Arg Int
n LazySplit
StrictSplit ([(SplitTag, SplitTree' SplitTag)]
trees' [(SplitTag, SplitTree' SplitTag)]
-> [(SplitTag, SplitTree' SplitTag)]
-> [(SplitTag, SplitTree' SplitTag)]
forall a. [a] -> [a] -> [a]
++! [(SplitTag, SplitTree' SplitTag)]
trees_extra) -- TODO: Lazy?
          -- Andreas, 2025-10-12: Debug printing to clarify the trees_extra situation.
          reportSDoc "tc.cover.cubical" 30 $ vcat $
            "trees:"           : map' pretty trees ++
            "trees':"          : map' pretty trees' ++
            "trees_extra:"     : map' pretty trees_extra ++
            "coverSplitTree:"  : pretty tree :
            "coverPatterns:"   : map' prettyTCM (concat qsss)
          return $ CoverResult tree (IntSet.unions useds) (concat psss) (concat qsss) (IntSet.unions 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!
      (tel, sc') <- Bool -> SplitClause -> TCM (Tele (Dom Type), SplitClause)
insertTrailingArgs Bool
True SplitClause
sc
      if null tel then
        if finalSplit then __IMPOSSIBLE__ -- already ruled out by lhs checker
        else cont
      else cover infermissing f cs 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
$ (InferMissing -> QName -> [Clause] -> SplitClause -> TCM CoverResult
cover InferMissing
infermissing QName
f [Clause]
cs (SplitClause -> TCM CoverResult)
-> ((Tele (Dom Type), SplitClause) -> SplitClause)
-> (Tele (Dom Type), SplitClause)
-> TCM CoverResult
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Tele (Dom Type), SplitClause) -> SplitClause
forall a b. (a, b) -> b
snd) ((Tele (Dom Type), SplitClause) -> TCM CoverResult)
-> (SplitClause -> TCM (Tele (Dom Type), SplitClause))
-> SplitClause
-> TCM CoverResult
forall (m :: * -> *) b c a.
Monad m =>
(b -> m c) -> (a -> m b) -> a -> m c
<=< Bool -> SplitClause -> TCM (Tele (Dom Type), 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

    -- Andreas, 2025-10-25, issue #8139
    --
    -- - This was the old logic:
    --
    -- -- 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 True) finalSplit splitError cont
    --   | finalSplit = splitError CosplitCatchall
    --   | otherwise  = cont
    --
    -- - The new logic allows copattern catchalls for the sake of further splitting
    --   but they are reported as unreachable.
    --
    -- blocked on result but there are catchalls:
    -- try regular splits if there are any
    trySplitRes (BlockedOnProj Bool
True) Bool
False SplitError -> TCM CoverResult
splitError TCM CoverResult
cont = TCM CoverResult
cont
    -- all clauses have an unsplit copattern: try to split
    trySplitRes (BlockedOnProj Bool
_) Bool
finalSplit SplitError -> TCM CoverResult
splitError TCM CoverResult
cont = do
      [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.cover" Int
20 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"blocked by projection pattern"
      -- forM is a monadic map over a Maybe here
      mcov <- QName -> SplitClause -> TCMT IO (Either SplitError Covering)
splitResultRecord QName
f SplitClause
sc
      case mcov of
        Left SplitError
err
          | Bool
finalSplit -> SplitError -> TCM CoverResult
splitError SplitError
err
          | Bool
otherwise  -> TCM CoverResult
cont
        Right (Covering Arg Int
n [(SplitTag, (SplitClause, IInfo))]
scs) -> do
          -- If result splitting was successful, continue coverage checking.
          (projs, 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)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [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)
forall (m :: * -> *) a b.
Functor m =>
(a -> m b) -> (SplitTag, a) -> m (SplitTag, 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
$ InferMissing -> QName -> [Clause] -> SplitClause -> TCM CoverResult
cover InferMissing
infermissing 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
<=< ((Tele (Dom Type), SplitClause) -> SplitClause
forall a b. (a, b) -> b
snd ((Tele (Dom Type), SplitClause) -> SplitClause)
-> (SplitClause -> TCM (Tele (Dom Type), SplitClause))
-> SplitClause
-> TCMT IO SplitClause
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Bool -> SplitClause -> TCM (Tele (Dom Type), SplitClause)
insertTrailingArgs Bool
False)) (((SplitTag, (SplitClause, IInfo)) -> (SplitTag, SplitClause))
-> [(SplitTag, (SplitClause, IInfo))] -> [(SplitTag, SplitClause)]
forall a b. (a -> b) -> [a] -> [b]
map' (\(SplitTag
t,(SplitClause
sc,IInfo
i)) -> (SplitTag
t,SplitClause
sc)) [(SplitTag, (SplitClause, IInfo))]
scs)
            -- OR:
            -- forM scs $ \ (proj, sc') -> (proj,) <$> do
            --   cover f cs =<< do
            --     snd <$> fixTarget sc'
          let trees = (CoverResult -> SplitTree' SplitTag)
-> [CoverResult] -> [SplitTree' SplitTag]
forall a b. (a -> b) -> [a] -> [b]
map' CoverResult -> SplitTree' SplitTag
coverSplitTree [CoverResult]
results
              useds = (CoverResult -> IntSet) -> [CoverResult] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map' CoverResult -> IntSet
coverUsedClauses [CoverResult]
results
              psss  = (CoverResult -> [(Tele (Dom Type), [NamedArg DeBruijnPattern])])
-> [CoverResult]
-> [[(Tele (Dom Type), [NamedArg DeBruijnPattern])]]
forall a b. (a -> b) -> [a] -> [b]
map' CoverResult -> [(Tele (Dom Type), [NamedArg DeBruijnPattern])]
coverMissingClauses [CoverResult]
results
              qsss  = (CoverResult -> [Clause]) -> [CoverResult] -> [[Clause]]
forall a b. (a -> b) -> [a] -> [b]
map' CoverResult -> [Clause]
coverPatterns [CoverResult]
results
              noex  = (CoverResult -> IntSet) -> [CoverResult] -> [IntSet]
forall a b. (a -> b) -> [a] -> [b]
map' CoverResult -> IntSet
coverNoExactClauses [CoverResult]
results
              tree  = Arg Int
-> LazySplit
-> [(SplitTag, SplitTree' SplitTag)]
-> SplitTree' SplitTag
forall a. Arg Int -> LazySplit -> SplitTrees' a -> SplitTree' a
SplitAt Arg Int
n LazySplit
StrictSplit ([(SplitTag, SplitTree' SplitTag)] -> SplitTree' SplitTag)
-> [(SplitTag, SplitTree' SplitTag)] -> SplitTree' SplitTag
forall a b. (a -> b) -> a -> b
$ [SplitTag]
-> [SplitTree' SplitTag] -> [(SplitTag, SplitTree' SplitTag)]
forall a b. [a] -> [b] -> [(a, b)]
zip [SplitTag]
projs [SplitTree' SplitTag]
trees   -- TODO: Lazy?
          return $ CoverResult tree (IntSet.unions useds) (concat psss) (concat qsss) (IntSet.unions noex)

    gatherEtaSplits :: Int -> SplitClause
                    -> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
    gatherEtaSplits :: Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Int
n SplitClause
sc []
       | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0    = [NamedArg SplitPattern]
forall a. HasCallStack => a
__IMPOSSIBLE__ -- we should have encountered the main
                                    -- split by now already
       | Bool
otherwise = []
    gatherEtaSplits Int
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
       | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
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]
: Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (-Int
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]
++! Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (-Int
1) SplitClause
sc [NamedArg SplitPattern]
ps
           LitP{}       -> Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (-Int
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]
++! Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (-Int
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]
: Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) SplitClause
sc [NamedArg SplitPattern]
ps
        where p' :: SplitPattern
p' = Substitution' SplitPattern -> Int -> SplitPattern
forall a. EndoSubst a => Substitution' a -> Int -> a
lookupS (SplitClause -> Substitution' SplitPattern
scSubst SplitClause
sc) (Int -> SplitPattern) -> Int -> SplitPattern
forall a b. (a -> b) -> a -> b
$ SplitPatVar -> Int
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]
: Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) SplitClause
sc [NamedArg SplitPattern]
ps
      DotP  PatternInfo
_ Term
_    -> NamedArg SplitPattern
p NamedArg SplitPattern
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. a -> [a] -> [a]
: Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits (Int
nInt -> Int -> Int
forall a. Num a => a -> a -> a
-Int
1) SplitClause
sc [NamedArg SplitPattern]
ps -- count dot patterns
      ConP  ConHead
_ ConPatternInfo
_ [NamedArg SplitPattern]
qs -> Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Int
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 -> Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Int
n SplitClause
sc ([NamedArg SplitPattern]
qs [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++! [NamedArg SplitPattern]
ps)
      LitP{}       -> Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Int
n SplitClause
sc [NamedArg SplitPattern]
ps
      ProjP{}      -> Int
-> SplitClause
-> [NamedArg SplitPattern]
-> [NamedArg SplitPattern]
gatherEtaSplits Int
n SplitClause
sc [NamedArg SplitPattern]
ps

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

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


-- | 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 Tele (Dom Type)
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId (Substitution' Term)
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
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.infer" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Trying to infer right-hand side of type" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Dom Type -> m Doc
prettyTCM Dom Type
t
  rhs <-
    Tele (Dom Type) -> TCMT IO Term -> TCMT IO Term
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel
    (TCMT IO Term -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Lens' TCEnv (Map CheckpointId (Substitution' Term))
-> (Map CheckpointId (Substitution' Term)
    -> Map CheckpointId (Substitution' Term))
-> TCMT IO Term
-> TCMT IO Term
forall (m :: * -> *) a b.
MonadTCEnv m =>
Lens' TCEnv a -> (a -> a) -> m b -> m b
locallyTC (Map CheckpointId (Substitution' Term)
 -> f (Map CheckpointId (Substitution' Term)))
-> TCEnv -> f TCEnv
Lens' TCEnv (Map CheckpointId (Substitution' Term))
eCheckpoints (Map CheckpointId (Substitution' Term)
-> Map CheckpointId (Substitution' Term)
-> Map CheckpointId (Substitution' Term)
forall a b. a -> b -> a
const Map CheckpointId (Substitution' Term)
cps)
    (TCMT IO Term -> TCMT IO Term) -> TCMT IO Term -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Substitution' Term -> TCMT IO Term -> TCMT IO Term
forall a. Substitution' Term -> TCM a -> TCM a
checkpoint Substitution' Term
forall a. Substitution' a
IdS    -- introduce a fresh checkpoint
    (TCMT IO Term -> TCMT IO Term) -> TCMT IO Term -> TCMT IO 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
          [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.infer" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
            [ TCMT IO Doc
"@tactic rhs"
            , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Dom Type
t ]
          (_, v) <- RunMetaOccursCheck -> Comparison -> Type -> TCM (MetaId, Term)
newValueMeta RunMetaOccursCheck
DontRunMetaOccursCheck Comparison
CmpLeq (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)
          v <$ unquoteTactic tac v (unDom t)
        Instance{} -> (MetaId, Term) -> Term
forall a b. (a, b) -> b
snd ((MetaId, Term) -> Term) -> TCM (MetaId, Term) -> TCMT IO Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> Type -> TCM (MetaId, Term)
newInstanceMeta [Char]
"" (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)
        Hiding
Hidden     -> TCMT IO Term
forall a. HasCallStack => a
__IMPOSSIBLE__
        Hiding
NotHidden  -> TCMT IO Term
forall a. HasCallStack => a
__IMPOSSIBLE__
  let cl = Clause { clauseLHSRange :: Range' SrcFile
clauseLHSRange  = Range' SrcFile
forall a. Range' a
noRange
                  , clauseFullRange :: Range' SrcFile
clauseFullRange = Range' SrcFile
forall a. Range' a
noRange
                  , clauseTel :: Tele (Dom Type)
clauseTel       = Tele (Dom Type)
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 :: Catchall
clauseCatchall    = Catchall
forall a. Null a => a
empty
                  , clauseRecursive :: ClauseRecursive
clauseRecursive   = ClauseRecursive
MaybeRecursive  -- 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
                  , clauseWhereModule :: Maybe ModuleName
clauseWhereModule = Maybe ModuleName
forall a. Maybe a
Nothing
                  }
  addClauses f $ singleton cl  -- Important: add at the end.
  return cl
inferMissingClause QName
_ (SClause Tele (Dom Type)
_ [NamedArg SplitPattern]
_ Substitution' SplitPattern
_ Map CheckpointId (Substitution' Term)
_ Maybe (Dom Type)
Nothing) = TCM Clause
forall a. HasCallStack => a
__IMPOSSIBLE__

splitStrategy :: BlockingVars -> Telescope -> TCM BlockingVars
splitStrategy :: [BlockingVar] -> Tele (Dom Type) -> TCM [BlockingVar]
splitStrategy [BlockingVar]
bs Tele (Dom Type)
tel = [BlockingVar] -> TCM [BlockingVar]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([BlockingVar] -> TCM [BlockingVar])
-> [BlockingVar] -> TCM [BlockingVar]
forall a b. (a -> b) -> a -> b
$ (BlockingVar -> BlockingVar) -> [BlockingVar] -> [BlockingVar]
forall a. (a -> a) -> [a] -> [a]
updateLast BlockingVar -> BlockingVar
setBlockingVarOverlap [BlockingVar]
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 :: [BlockingVar]
xs             = [BlockingVar]
strict [BlockingVar] -> [BlockingVar] -> [BlockingVar]
forall a. [a] -> [a] -> [a]
++! [BlockingVar]
lazy
    ([BlockingVar]
lazy, [BlockingVar]
strict) = (BlockingVar -> Bool)
-> [BlockingVar] -> ([BlockingVar], [BlockingVar])
forall a. (a -> Bool) -> [a] -> ([a], [a])
List.partition BlockingVar -> Bool
blockingVarLazy [BlockingVar]
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, Sort, Args, Args, [QName], Bool)
isDatatype :: forall (tcm :: * -> *).
(MonadTCM tcm, MonadError SplitError tcm) =>
Induction
-> Dom Type
-> tcm
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [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, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
throw Closure Type -> SplitError
f = SplitError
-> tcm
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
forall a. SplitError -> tcm a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SplitError
 -> tcm
      (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
       Bool))
-> (Closure Type -> SplitError)
-> Closure Type
-> tcm
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure Type -> SplitError
f (Closure Type
 -> tcm
      (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
       Bool))
-> tcm (Closure Type)
-> tcm
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do TCM (Closure Type) -> tcm (Closure Type)
forall a. TCM a -> tcm a
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
  t' <- TCM Type -> tcm Type
forall a. TCM a -> tcm a
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
  mInterval <- liftTCM $ getBuiltinName' builtinInterval
  mIsOne <- liftTCM $ getBuiltinName' builtinIsOne
  case unEl 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, Sort' Term, [Arg Term], [Arg Term], [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
                xs <- TCM [(IntMap Bool, [Term])] -> tcm [(IntMap Bool, [Term])]
forall a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM [(IntMap Bool, [Term])] -> tcm [(IntMap Bool, [Term])])
-> TCM [(IntMap Bool, [Term])] -> tcm [(IntMap Bool, [Term])]
forall a b. (a -> b) -> a -> b
$ Term -> TCM [(IntMap Bool, [Term])]
forall (m :: * -> *).
HasBuiltins m =>
Term -> m [(IntMap Bool, [Term])]
decomposeInterval (Term -> TCM [(IntMap Bool, [Term])])
-> TCMT IO Term -> TCM [(IntMap Bool, [Term])]
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> TCMT IO 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 null xs
                   then return $ (IsData, d, mkSSet 0, [phi], [], [], False)
                   else throw NotADatatype
    Def QName
d Elims
es -> do
      let ~(Just [Arg Term]
args) = Elims -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
      def <- TCM Definition -> tcm Definition
forall a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Definition -> tcm Definition)
-> TCM Definition -> tcm Definition
forall a b. (a -> b) -> a -> b
$ QName -> TCM Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
d
      case theDef def of
        Datatype{dataSort :: Defn -> Sort' Term
dataSort = Sort' Term
s, dataPars :: Defn -> Int
dataPars = Int
np, dataCons :: Defn -> [QName]
dataCons = [QName]
cs}
          | Bool
otherwise -> do
              let ([Arg Term]
ps, [Arg Term]
is) = Int -> [Arg Term] -> ([Arg Term], [Arg Term])
forall a. Int -> [a] -> ([a], [a])
splitAt Int
np [Arg Term]
args
              (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
 Bool)
-> tcm
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataOrRecord
forall p. DataOrRecord' p
IsData, QName
d, Sort' Term
s, [Arg Term]
ps, [Arg Term]
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 -> [QName]) -> Defn -> [QName]
forall a b. (a -> b) -> a -> b
$ Definition -> Defn
theDef Definition
def))
        Record{recPars :: Defn -> Int
recPars = Int
np, recConHead :: Defn -> ConHead
recConHead = ConHead
con, recInduction :: Defn -> Maybe Induction
recInduction = Maybe Induction
i, EtaEquality
recEtaEquality' :: EtaEquality
recEtaEquality' :: Defn -> 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, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
throw Closure Type -> SplitError
CoinductiveDatatype
          | Bool
otherwise -> do
              s <- TCM (Sort' Term) -> tcm (Sort' Term)
forall a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Sort' Term) -> tcm (Sort' Term))
-> TCM (Sort' Term) -> tcm (Sort' Term)
forall a b. (a -> b) -> a -> b
$ Type -> TCM (Sort' Term)
forall (m :: * -> *).
(PureTCM m, MonadBlock m, MonadError TCErr m) =>
Type -> m (Sort' Term)
shouldBeSort (Type -> TCM (Sort' Term)) -> TCM Type -> TCM (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Definition -> Type
defType Definition
def Type -> [Arg Term] -> TCM Type
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
forall (m :: * -> *).
(MonadReduce m, HasBuiltins m) =>
Type -> [Arg Term] -> m Type
`piApplyM` [Arg Term]
args
              return (IsRecord InductionAndEta { recordInduction=i, recordEtaEquality=recEtaEquality' }, d, s, args, [], [conName con], False)
        Defn
_ -> (Closure Type -> SplitError)
-> tcm
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
throw Closure Type -> SplitError
NotADatatype
    Term
_ -> (Closure Type -> SplitError)
-> tcm
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [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 -> Tele (Dom Type)
scTel = Tele (Dom Type)
sctel, scSubst :: SplitClause -> Substitution' SplitPattern
scSubst = Substitution' SplitPattern
sigma } Dom Type
target = do
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.target" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCMT IO Doc
"split clause telescope: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom Type) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
sctel
      ]
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.target" Int
60 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCMT IO Doc
"substitution          : " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' SplitPattern -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Substitution' SplitPattern -> m Doc
prettyTCM Substitution' SplitPattern
sigma
      ]
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.target" Int
60 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
      [ TCMT IO Doc
"target type before substitution:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Dom Type
target
      , TCMT IO Doc
"             after substitution:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom Type -> TCMT IO 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.
    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 a. a -> TCMT IO a
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
          q <- Definition -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity (Definition -> Quantity) -> TCM Definition -> TCMT IO Quantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCM Definition
forall (m :: * -> *).
(HasCallStack, ReadTCState m, HasConstInfo m) =>
QName -> m Definition
getOriginalConstInfo QName
c
          case q of
            Quantity0{} -> (Dom Type -> Dom Type) -> TCMT IO (Dom Type -> Dom Type)
forall a. a -> TCMT IO a
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 a. a -> TCMT IO a
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 a. a -> TCMT IO a
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 a. a -> TCMT IO a
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 a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Dom Type -> Dom Type
forall a. a -> a
id

    return $ sc { scTarget = Just $ updQuant $ applySplitPSubst sigma 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 (Tele (Dom Type), SplitClause)
insertTrailingArgs Bool
force sc :: SplitClause
sc@SClause{ scTel :: SplitClause -> Tele (Dom Type)
scTel = Tele (Dom Type)
sctel, scPats :: SplitClause -> [NamedArg SplitPattern]
scPats = [NamedArg SplitPattern]
ps, scSubst :: SplitClause -> Substitution' SplitPattern
scSubst = Substitution' SplitPattern
sigma, scCheckpoints :: SplitClause -> Map CheckpointId (Substitution' Term)
scCheckpoints = Map CheckpointId (Substitution' Term)
cps, scTarget :: SplitClause -> Maybe (Dom Type)
scTarget = Maybe (Dom Type)
target } = do
  let fallback :: TCM (Tele (Dom Type), SplitClause)
fallback = (Tele (Dom Type), SplitClause)
-> TCM (Tele (Dom Type), SplitClause)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tele (Dom Type)
forall a. Null a => a
empty, SplitClause
sc)
  Maybe (Dom Type)
-> TCM (Tele (Dom Type), SplitClause)
-> (Dom Type -> TCM (Tele (Dom Type), SplitClause))
-> TCM (Tele (Dom Type), SplitClause)
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Dom Type)
target TCM (Tele (Dom Type), SplitClause)
fallback ((Dom Type -> TCM (Tele (Dom Type), SplitClause))
 -> TCM (Tele (Dom Type), SplitClause))
-> (Dom Type -> TCM (Tele (Dom Type), SplitClause))
-> TCM (Tele (Dom Type), 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 (Tele (Dom Type), SplitClause)
fallback else do
    (TelV tel b) <- Tele (Dom Type) -> TCMT IO (TelV Type) -> TCMT IO (TelV Type)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
sctel (TCMT IO (TelV Type) -> TCMT IO (TelV Type))
-> TCMT IO (TelV Type) -> TCMT IO (TelV Type)
forall a b. (a -> b) -> a -> b
$ Int -> Type -> TCMT IO (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Int -> Type -> m (TelV Type)
telViewUpTo (-Int
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
    reportSDoc "tc.cover.target" 15 $ sep
      [ "target type telescope: " <+> do
          addContext sctel $ prettyTCM tel
      , "target type core     : " <+> do
          addContext sctel $ addContext tel $ prettyTCM b
      ]
    let n         = Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel
        -- Andreas, 2016-10-04 issue #2236
        -- Need to set origin to "Inserted" to avoid printing of hidden patterns.
        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
$ Tele (Dom Type) -> [NamedArg SplitPattern]
forall a t. DeBruijn a => Tele (Dom t) -> [NamedArg a]
teleNamedArgs Tele (Dom Type)
tel
        -- Compute new split clause
        sctel'    = ListTel -> Tele (Dom Type)
telFromList (ListTel -> Tele (Dom Type)) -> ListTel -> Tele (Dom Type)
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> ListTel
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList (Int -> Tele (Dom Type) -> Tele (Dom Type)
forall a. Subst a => Int -> a -> a
raise Int
n Tele (Dom Type)
sctel) ListTel -> ListTel -> ListTel
forall a. [a] -> [a] -> [a]
++! Tele (Dom Type) -> ListTel
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Tele (Dom Type)
tel
        -- Dot patterns in @ps@ need to be raised!  (Issue 1298)
        ps'       = Substitution' (SubstArg [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst (Int -> Substitution' SplitPattern
forall a. Int -> Substitution' a
raiseS Int
n) [NamedArg SplitPattern]
ps [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++! [NamedArg SplitPattern]
xs
        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 (Tele (Dom Type) -> Bool
forall a. Null a => a -> Bool
null Tele (Dom Type)
tel) then Dom Type
a Dom Type -> (Dom Type -> Dom Type) -> Dom Type
forall a b. a -> (a -> b) -> b
& (Maybe Term -> Identity (Maybe Term))
-> Dom Type -> Identity (Dom Type)
forall t e (f :: * -> *).
Functor f =>
(Maybe t -> f (Maybe t)) -> Dom' t e -> f (Dom' t e)
dTactic ((Maybe Term -> Identity (Maybe Term))
 -> Dom Type -> Identity (Dom Type))
-> Maybe Term -> Dom Type -> Dom Type
forall s t a b. ASetter s t a b -> b -> s -> t
.~ 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'       = SClause
          { scTel :: Tele (Dom Type)
scTel    = Tele (Dom Type)
sctel'
          , scPats :: [NamedArg SplitPattern]
scPats   = [NamedArg SplitPattern]
ps'
          , scSubst :: Substitution' SplitPattern
scSubst  = Int -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Int -> Substitution' a -> Substitution' a
wkS Int
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' Term)
scCheckpoints        = Substitution' (SubstArg (Map CheckpointId (Substitution' Term)))
-> Map CheckpointId (Substitution' Term)
-> Map CheckpointId (Substitution' Term)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst (Int -> Substitution' Term
forall a. Int -> Substitution' a
raiseS Int
n) Map CheckpointId (Substitution' Term)
cps
          , scTarget :: Maybe (Dom Type)
scTarget = Maybe (Dom Type)
newTarget
          }
    -- Separate debug printing to find cause of crash (Issue 1374)
    reportSDoc "tc.cover.target" 30 $ sep
      [ "new split clause telescope   : " <+> prettyTCM sctel'
      ]
    reportSDoc "tc.cover.target" 30 $ sep
      [ "new split clause patterns    : " <+> do
          addContext sctel' $ prettyTCMPatternList $ fromSplitPatterns ps'
      ]
    reportSDoc "tc.cover.target" 60 $ sep
      [ "new split clause substitution: " <+> prettyTCM (scSubst sc')
      ]
    reportSDoc "tc.cover.target" 30 $ sep
      [ "new split clause target      : " <+> do
          addContext sctel' $ prettyTCM $ fromJust newTarget
      ]
    reportSDoc "tc.cover.target" 20 $ sep
      [ "new split clause"
      , prettyTCM sc'
      ]
    return $ if n == 0 then (empty, sc { scTarget = newTarget }) else (tel, 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


-- | Checks if a type in this sort supports hcomp.
--   currently all such types will have a Level.
--   precondition: Sort in whnf and not blocked.
hasHComp :: Sort -> Maybe Level
hasHComp :: Sort' Term -> Maybe Level
hasHComp (Type Level
l) = Level -> Maybe Level
forall a. a -> Maybe a
Just Level
l
hasHComp Sort' Term
_        = Maybe Level
forall a. Maybe a
Nothing


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 :: Tele (Dom Type)
-> [Char]
-> Tele (Dom Type)
-> QName
-> [Arg Term]
-> [Arg Term]
-> Int
-> Tele (Dom Type)
-> [NamedArg SplitPattern]
-> Map CheckpointId (Substitution' Term)
-> CoverM (Maybe (SplitTag, SplitClause))
computeHCompSplit Tele (Dom Type)
delta1 [Char]
n Tele (Dom Type)
delta2 QName
d [Arg Term]
pars [Arg Term]
ixs Int
hix Tele (Dom Type)
tel [NamedArg SplitPattern]
ps Map CheckpointId (Substitution' Term)
cps = do
  withK   <- Bool -> Bool
not (Bool -> Bool)
-> ExceptT SplitError (TCMT IO) Bool
-> ExceptT SplitError (TCMT IO) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT SplitError (TCMT IO) Bool
forall (m :: * -> *). HasOptions m => m Bool
cubicalCompatibleOption
  if withK then return Nothing else do
    -- Get the type of the datatype
  -- Δ1 ⊢ dtype
  dsort <- liftTCM $ (parallelS (reverse $ map' unArg pars) `applySubst`) . dataSort . theDef <$> getConstInfo d
  hCompName <- fromMaybe __IMPOSSIBLE__ <$> getPrimitiveName' builtinHComp
  theHCompT <- defType <$> getConstInfo hCompName

  -- TODO can dsort be blocked or not in whnf?
  caseMaybe (hasHComp dsort) (return Nothing) $ \ Level
dlvl' -> do
  let
    dlvl :: Term
dlvl = Level -> Term
Level Level
dlvl'
    dterm :: Term
dterm = QName -> Elims -> Term
Def QName
d [] Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` ([Arg Term]
pars [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++! [Arg Term]
ixs)
  -- Δ1 ⊢ gamma
  TelV gamma _ <- TCMT IO (TelV Type) -> ExceptT SplitError (TCMT IO) (TelV Type)
forall (m :: * -> *) a. Monad m => m a -> ExceptT SplitError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO (TelV Type) -> ExceptT SplitError (TCMT IO) (TelV Type))
-> TCMT IO (TelV Type) -> ExceptT SplitError (TCMT IO) (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 -> [Arg Term] -> 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 (delta1 `abstract` gamma,IdS) of
    (Tele (Dom Type)
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) = Int
-> Substitution' SplitPattern
-> (Substitution' SplitPattern, Substitution' SplitPattern)
forall a.
Int -> Substitution' a -> (Substitution' a, Substitution' a)
splitS (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
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
$ -- should there be a different Origin here?
                   (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 a b. (a -> b) -> Arg a -> Arg b
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 (Tele (Dom Type) -> [NamedArg SplitPattern]
forall a t. DeBruijn a => Tele (Dom t) -> [NamedArg a]
teleNamedArgs Tele (Dom Type)
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' :: Tele (Dom Type)
delta2' = Substitution' SplitPattern -> Tele (Dom Type) -> Tele (Dom Type)
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
rho3 Tele (Dom Type)
delta2  -- Δ₂' = Δ₂ρ₃
          delta' :: Tele (Dom Type)
delta'  = Tele (Dom Type)
delta1' Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
`abstract` Tele (Dom Type)
delta2' -- Δ'  = Δ₁'Δ₂'
          rho :: Substitution' SplitPattern
rho     = Int -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Int -> Substitution' a -> Substitution' a
liftS (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
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' Term)
cps' = Substitution' SplitPattern
-> Map CheckpointId (Substitution' Term)
-> Map CheckpointId (Substitution' Term)
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
rho Map CheckpointId (Substitution' Term)
cps

      Maybe (SplitTag, SplitClause)
-> CoverM (Maybe (SplitTag, SplitClause))
forall a. a -> ExceptT SplitError (TCMT IO) a
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
$ Tele (Dom Type)
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId (Substitution' Term)
-> Maybe (Dom Type)
-> SplitClause
SClause Tele (Dom Type)
delta' [NamedArg SplitPattern]
ps' Substitution' SplitPattern
rho Map CheckpointId (Substitution' Term)
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, IInfo))   -- ^ New split clause if successful.
computeNeighbourhood :: Tele (Dom Type)
-> [Char]
-> Tele (Dom Type)
-> QName
-> [Arg Term]
-> [Arg Term]
-> Int
-> Tele (Dom Type)
-> [NamedArg SplitPattern]
-> Map CheckpointId (Substitution' Term)
-> QName
-> CoverM (Maybe (SplitClause, IInfo))
computeNeighbourhood Tele (Dom Type)
delta1 [Char]
n Tele (Dom Type)
delta2 QName
d [Arg Term]
pars [Arg Term]
ixs Int
hix Tele (Dom Type)
tel [NamedArg SplitPattern]
ps Map CheckpointId (Substitution' Term)
cps QName
c = do

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

  -- Get the real constructor name
  con <- liftTCM $ fromRight __IMPOSSIBLE__ <$> getConForm c
  con <- return $ con { conName = c }  -- What if we restore the current name?
                                       -- Andreas, 2013-11-29 changes nothing!

  -- Get the type of the constructor
  ctype <- liftTCM $ defType <$> getConInfo con

  -- Lookup the type of the constructor at the given parameters
  (gamma0, cixs, boundary) <- do
    (TelV gamma0 (El _ d), boundary) <- liftTCM $ addContext delta1 $
      telViewPathBoundary (ctype `piApply` pars)
    let Def _ es = d
        Just cixs = allApplyElims es
    return (gamma0, cixs, boundary)

  let (_, dom : _) = splitAt (size tel - hix - 1) (telToList tel)
      info = Dom' Term ([Char], Type)
dom Dom' Term ([Char], Type)
-> Getting ArgInfo (Dom' Term ([Char], Type)) ArgInfo -> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom' Term ([Char], Type)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo

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

  let preserve ([Char]
x, t :: Type
t@(El Sort' Term
_ (Def QName
d' Elims
_))) | QName
d QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
d' = ([Char]
n, Type
t)
      preserve ([Char]
x, Type
t) = ([Char]
x, Type
t)
      gamma  = ((Dom Type -> Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall a b. (a -> b) -> Tele a -> Tele b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Dom Type -> Dom Type) -> Tele (Dom Type) -> Tele (Dom Type))
-> ((Modality -> Modality) -> Dom Type -> Dom Type)
-> (Modality -> Modality)
-> Tele (Dom Type)
-> Tele (Dom Type)
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)) (Tele (Dom Type) -> Tele (Dom Type))
-> Tele (Dom Type) -> Tele (Dom Type)
forall a b. (a -> b) -> a -> b
$ ListTel -> Tele (Dom Type)
telFromList (ListTel -> Tele (Dom Type))
-> (Tele (Dom Type) -> ListTel)
-> Tele (Dom Type)
-> Tele (Dom Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Dom' Term ([Char], Type) -> Dom' Term ([Char], Type))
-> ListTel -> ListTel
forall a b. (a -> b) -> [a] -> [b]
map' ((([Char], Type) -> ([Char], Type))
-> Dom' Term ([Char], Type) -> Dom' Term ([Char], Type)
forall a b. (a -> b) -> Dom' Term a -> Dom' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], Type) -> ([Char], Type)
preserve) (ListTel -> ListTel)
-> (Tele (Dom Type) -> ListTel) -> Tele (Dom Type) -> ListTel
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tele (Dom Type) -> ListTel
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList (Tele (Dom Type) -> Tele (Dom Type))
-> Tele (Dom Type) -> Tele (Dom Type)
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type)
gamma0
      delta1Gamma = Tele (Dom Type)
delta1 Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
`abstract` Tele (Dom Type)
gamma

  debugInit con ctype d pars ixs cixs delta1 delta2 gamma tel ps hix

  cforced <- defForced <$> getConstInfo c
      -- Variables in Δ₁ are not forced, since the unifier takes care to not introduce forced
      -- variables.
  let forced = Int -> IsForced -> [IsForced]
forall a. Int -> a -> [a]
replicate (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
delta1) IsForced
NotForced [IsForced] -> [IsForced] -> [IsForced]
forall a. [a] -> [a] -> [a]
++! [IsForced]
cforced
      flex   = [IsForced] -> Tele (Dom Type) -> FlexibleVars
allFlexVars [IsForced]
forced Tele (Dom Type)
delta1Gamma -- All variables are flexible

  -- Unify constructor target and given type (in Δ₁Γ)
  let conIxs   = Int -> [Arg Term] -> [Arg Term]
forall a. Int -> [a] -> [a]
drop ([Arg Term] -> Int
forall a. Sized a => a -> Int
size [Arg Term]
pars) [Arg Term]
cixs
      givenIxs = Int -> [Arg Term] -> [Arg Term]
forall a. Subst a => Int -> a -> a
raise (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
gamma) [Arg Term]
ixs

  -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope
  -- TODO: should we propagate the modality in general?
  -- See also LHS checking.
  dtype <- addContext delta1 $ do
         let updCoh = Cohesion -> Cohesion -> Cohesion
composeCohesion (ArgInfo -> Cohesion
forall a. LensCohesion a => a -> Cohesion
getCohesion ArgInfo
info)
         TelV dtel dt <- telView dtype
         return $ abstract (mapCohesion updCoh <$> dtel) dt
  dsort <- addContext delta1 $ reduce (getSort dtype)

  let withKIfStrict :: forall a. CoverM a -> CoverM a
      withKIfStrict = Bool -> (CoverM a -> CoverM a) -> CoverM a -> CoverM a
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen (Sort' Term -> Bool
forall t. Sort' t -> Bool
isStrictDataSort Sort' Term
dsort) ((CoverM a -> CoverM a) -> CoverM a -> CoverM a)
-> (CoverM a -> CoverM a) -> CoverM a -> CoverM a
forall a b. (a -> b) -> a -> b
$ Lens' TCEnv Bool -> (Bool -> Bool) -> CoverM a -> CoverM a
forall (m :: * -> *) a b.
MonadTCEnv m =>
Lens' TCEnv a -> (a -> a) -> m b -> m b
locallyTC (Bool -> f Bool) -> TCEnv -> f TCEnv
Lens' TCEnv Bool
eSplitOnStrict (Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
True)

  -- Should we attempt to compute a left inverse for this clause? When
  -- --cubical=compatible --flat-split is given, we don't generate a
  -- left inverse (at all). This means that, when the coverage checker
  -- gets to the clause this was in, it won't generate a (malformed!)
  -- transpX clause for @♭ matching.
  -- TODO(Amy): properly support transpX when @♭ stuff is in the
  -- context.
  let flatSplit = Bool -> NoLeftInv -> Maybe NoLeftInv
forall a. Bool -> a -> Maybe a
boolToMaybe (ArgInfo -> Cohesion
forall a. LensCohesion a => a -> Cohesion
getCohesion ArgInfo
info Cohesion -> Cohesion -> Bool
forall a. Eq a => a -> a -> Bool
== Cohesion
Flat) NoLeftInv
SplitOnFlat

  r <- withKIfStrict $ lift $
           unifyIndices' flatSplit
             delta1Gamma
             flex
             (raise (size gamma) dtype)
             conIxs
             givenIxs

  TelV eqTel _ <- telView $ (raise (size gamma) dtype)

  let stuck Maybe Blocker
b [UnificationFailure]
errs = do
        ExceptT SplitError (TCMT IO) ()
debugCantSplit
        SplitError -> CoverM (Maybe (SplitClause, IInfo))
forall a. SplitError -> ExceptT SplitError (TCMT IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SplitError -> CoverM (Maybe (SplitClause, IInfo)))
-> SplitError -> CoverM (Maybe (SplitClause, IInfo))
forall a b. (a -> b) -> a -> b
$ Maybe Blocker
-> QName
-> Tele (Dom Type)
-> [Arg Term]
-> [Arg Term]
-> [UnificationFailure]
-> SplitError
UnificationStuck Maybe Blocker
b (ConHead -> QName
conName ConHead
con) (Tele (Dom Type)
delta1 Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
`abstract` Tele (Dom Type)
gamma) [Arg Term]
conIxs [Arg Term]
givenIxs [UnificationFailure]
errs


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

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

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

    Unifies (Tele (Dom Type)
delta1',Substitution' DeBruijnPattern
rho0,[NamedArg DeBruijnPattern]
eqs,TCM (Either NoLeftInv (Substitution' Term, Substitution' Term))
getTauInv) -> do
      tauInv <- CoverM (Either NoLeftInv (Substitution' Term, Substitution' Term))
-> CoverM
     (Either NoLeftInv (Substitution' Term, Substitution' Term))
forall a. CoverM a -> CoverM a
withKIfStrict (CoverM (Either NoLeftInv (Substitution' Term, Substitution' Term))
 -> CoverM
      (Either NoLeftInv (Substitution' Term, Substitution' Term)))
-> CoverM
     (Either NoLeftInv (Substitution' Term, Substitution' Term))
-> CoverM
     (Either NoLeftInv (Substitution' Term, Substitution' Term))
forall a b. (a -> b) -> a -> b
$ TCM (Either NoLeftInv (Substitution' Term, Substitution' Term))
-> CoverM
     (Either NoLeftInv (Substitution' Term, Substitution' Term))
forall (m :: * -> *) a. Monad m => m a -> ExceptT SplitError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift TCM (Either NoLeftInv (Substitution' Term, Substitution' Term))
getTauInv

      let unifyInfo | Type Level
_ <- Sort' Term
dsort     -- only types of sort Type l have trX constructors:
                                          -- re #3733: update if we add transp for other sorts.
                    , Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ [Arg Term] -> Bool
forall a. Null a => a -> Bool
null ([Arg Term] -> Bool) -> [Arg Term] -> Bool
forall a b. (a -> b) -> a -> b
$ [Arg Term]
conIxs -- no point propagating this info if trivial?
                    , Right (Substitution' Term
tau,Substitution' Term
leftInv) <- Either NoLeftInv (Substitution' Term, Substitution' Term)
tauInv
            = UnifyEquiv -> IInfo
TheInfo (UnifyEquiv -> IInfo) -> UnifyEquiv -> IInfo
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type)
-> Tele (Dom Type)
-> Tele (Dom Type)
-> [Term]
-> [Term]
-> Substitution' DeBruijnPattern
-> Substitution' Term
-> Substitution' Term
-> UnifyEquiv
UE Tele (Dom Type)
delta1Gamma Tele (Dom Type)
delta1' Tele (Dom Type)
eqTel ((Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg [Arg Term]
conIxs) ((Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg [Arg Term]
givenIxs) Substitution' DeBruijnPattern
rho0 Substitution' Term
tau Substitution' Term
leftInv
                    | Bool
otherwise
            = IInfo
NoInfo

      case tauInv of
        Right{} -> () -> ExceptT SplitError (TCMT IO) ()
forall a. a -> ExceptT SplitError (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Left NoLeftInv
SplitOnStrict -> () -> ExceptT SplitError (TCMT IO) ()
forall a. a -> ExceptT SplitError (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Left NoLeftInv
x -> do
          ExceptT SplitError (TCMT IO) Bool
-> ExceptT SplitError (TCMT IO) ()
-> ExceptT SplitError (TCMT IO) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM ExceptT SplitError (TCMT IO) Bool
forall (m :: * -> *). HasOptions m => m Bool
cubicalCompatibleOption (ExceptT SplitError (TCMT IO) ()
 -> ExceptT SplitError (TCMT IO) ())
-> ExceptT SplitError (TCMT IO) ()
-> ExceptT SplitError (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ do
            -- re #3733: TODO better error msg.
            TCMT IO () -> ExceptT SplitError (TCMT IO) ()
forall (m :: * -> *) a. Monad m => m a -> ExceptT SplitError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO () -> ExceptT SplitError (TCMT IO) ())
-> TCMT IO () -> ExceptT SplitError (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ()) -> (Doc -> Warning) -> Doc -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> Warning
UnsupportedIndexedMatch (Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< NoLeftInv -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => NoLeftInv -> m Doc
prettyTCM NoLeftInv
x

      debugSubst "rho0" rho0

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

      -- We have Δ₁' ⊢ ρ₀ : Δ₁Γ, so split it into the part for Δ₁ and the part for Γ
      let (rho1,rho2) = splitS (size gamma) $ 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
noConPatternInfo{ conPInfo = PatternInfo PatOSplit [] , conPRecord = True }
          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)
-> NamedArg SplitPattern
-> NamedArg SplitPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName SplitPattern -> Named NamedName SplitPattern)
-> NamedArg SplitPattern -> NamedArg SplitPattern
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((SplitPattern -> SplitPattern)
-> Named NamedName SplitPattern -> Named NamedName SplitPattern
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap SplitPattern -> SplitPattern
setSplitArgOrigin)) ([NamedArg SplitPattern] -> [NamedArg SplitPattern])
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a b. (a -> b) -> a -> b
$
                   (forall a1. DeBruijn a1 => Tele (Dom Type) -> [NamedArg a1])
-> Tele (Dom Type) -> Boundary' Int Term -> [NamedArg SplitPattern]
forall a.
DeBruijn a =>
(forall a1. DeBruijn a1 => Tele (Dom Type) -> [NamedArg a1])
-> Tele (Dom Type) -> Boundary' Int Term -> [NamedArg (Pattern' a)]
telePatterns' (Tele (Dom Type) -> Tele (Dom Type) -> [NamedArg a1]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Tele (Dom Type) -> [NamedArg a]
tele2NamedArgs Tele (Dom Type)
gamma0) Tele (Dom Type)
gamma Boundary' Int Term
boundary
          -- Andreas, 2016-09-08, issue #2166: use gamma0 for correct argument names

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

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

      -- Apply the substitution
      let 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'  = Substitution' SplitPattern
-> Map CheckpointId (Substitution' Term)
-> Map CheckpointId (Substitution' Term)
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
rho Map CheckpointId (Substitution' Term)
cps

      return $ Just . (,unifyInfo) $ SClause delta' ps' rho cps' Nothing -- target fixed later

  where
    setSplitArgOrigin :: SplitPattern -> SplitPattern
    setSplitArgOrigin :: SplitPattern -> SplitPattern
setSplitArgOrigin (VarP PatternInfo
i SplitPatVar
x) = PatternInfo -> SplitPatVar -> SplitPattern
forall x. PatternInfo -> x -> Pattern' x
VarP (PatternInfo
i { patOrigin = PatOSplitArg (splitPatVarName x) }) SplitPatVar
x
    setSplitArgOrigin (IApplyP PatternInfo
i Term
u Term
v SplitPatVar
x) = PatternInfo -> Term -> Term -> SplitPatVar -> SplitPattern
forall x. PatternInfo -> Term -> Term -> x -> Pattern' x
IApplyP (PatternInfo
i { patOrigin = PatOSplitArg (splitPatVarName x)}) Term
u Term
v SplitPatVar
x
    setSplitArgOrigin SplitPattern
p = SplitPattern
p

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

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

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

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

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

    debugPs :: b -> [NamedArg SplitPattern] -> tcm ()
debugPs b
tel [NamedArg SplitPattern]
ps =
      TCMT IO () -> tcm ()
forall a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.split.con" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc -> TCMT IO Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ b -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a. MonadAddContext m => b -> m a -> m a
addContext b
tel (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"ps     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCMT IO 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 a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.split.con" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc -> TCMT IO Doc
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ b -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a. MonadAddContext m => b -> m a -> m a
addContext b
delta' (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"ps'    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> do [NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList ([NamedArg DeBruijnPattern] -> TCMT IO Doc)
-> [NamedArg DeBruijnPattern] -> TCMT IO 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
$c== :: InsertTrailing -> InsertTrailing -> Bool
== :: InsertTrailing -> InsertTrailing -> Bool
$c/= :: InsertTrailing -> InsertTrailing -> Bool
/= :: InsertTrailing -> InsertTrailing -> Bool
Eq, Int -> InsertTrailing -> [Char] -> [Char]
[InsertTrailing] -> [Char] -> [Char]
InsertTrailing -> [Char]
(Int -> InsertTrailing -> [Char] -> [Char])
-> (InsertTrailing -> [Char])
-> ([InsertTrailing] -> [Char] -> [Char])
-> Show InsertTrailing
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> InsertTrailing -> [Char] -> [Char]
showsPrec :: Int -> InsertTrailing -> [Char] -> [Char]
$cshow :: InsertTrailing -> [Char]
show :: InsertTrailing -> [Char]
$cshowList :: [InsertTrailing] -> [Char] -> [Char]
showList :: [InsertTrailing] -> [Char] -> [Char]
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
$c== :: AllowPartialCover -> AllowPartialCover -> Bool
== :: AllowPartialCover -> AllowPartialCover -> Bool
$c/= :: AllowPartialCover -> AllowPartialCover -> Bool
/= :: AllowPartialCover -> AllowPartialCover -> Bool
Eq, Int -> AllowPartialCover -> [Char] -> [Char]
[AllowPartialCover] -> [Char] -> [Char]
AllowPartialCover -> [Char]
(Int -> AllowPartialCover -> [Char] -> [Char])
-> (AllowPartialCover -> [Char])
-> ([AllowPartialCover] -> [Char] -> [Char])
-> Show AllowPartialCover
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> AllowPartialCover -> [Char] -> [Char]
showsPrec :: Int -> AllowPartialCover -> [Char] -> [Char]
$cshow :: AllowPartialCover -> [Char]
show :: AllowPartialCover -> [Char]
$cshowList :: [AllowPartialCover] -> [Char] -> [Char]
showList :: [AllowPartialCover] -> [Char] -> [Char]
Show)

-- | Entry point from @Interaction.MakeCase@.
splitClauseWithAbsurd :: SplitClause -> Nat -> TCM (Either SplitError (Either SplitClause Covering))
splitClauseWithAbsurd :: SplitClause
-> Int -> TCM (Either SplitError (Either SplitClause Covering))
splitClauseWithAbsurd SplitClause
c Int
x =
  CheckEmpty
-> Induction
-> AllowPartialCover
-> InsertTrailing
-> SplitClause
-> BlockingVar
-> TCM (Either SplitError (Either SplitClause Covering))
split' CheckEmpty
CheckEmpty Induction
Inductive AllowPartialCover
NoAllowPartialCover InsertTrailing
DontInsertTrailing SplitClause
c (Int -> [ConHead] -> [Literal] -> Bool -> Bool -> BlockingVar
BlockingVar Int
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
-> Tele (Dom Type)
-> [NamedArg DeBruijnPattern]
-> TCMT IO (Either SplitError Covering)
splitLast Induction
ind Tele (Dom Type)
tel [NamedArg DeBruijnPattern]
ps = Induction
-> AllowPartialCover
-> SplitClause
-> BlockingVar
-> TCMT IO (Either SplitError Covering)
split Induction
ind AllowPartialCover
NoAllowPartialCover SplitClause
sc (Int -> [ConHead] -> [Literal] -> Bool -> Bool -> BlockingVar
BlockingVar Int
0 [] [] Bool
True Bool
False)
  where sc :: SplitClause
sc = Tele (Dom Type)
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId (Substitution' Term)
-> Maybe (Dom Type)
-> SplitClause
SClause Tele (Dom Type)
tel ([NamedArg DeBruijnPattern] -> [NamedArg SplitPattern]
toSplitPatterns [NamedArg DeBruijnPattern]
ps) Substitution' SplitPattern
forall a. Null a => a
empty Map CheckpointId (Substitution' Term)
forall a. Null a => a
empty Maybe (Dom Type)
target
        -- TODO 2ltt: allows (Empty_fib -> Empty_strict) which is not conservative
        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 -> Dom Type
forall a. a -> Dom a
defaultDom (Type -> Dom Type) -> Type -> Dom Type
forall a b. (a -> b) -> a -> b
$ Sort' Term -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El (Integer -> Sort' Term
mkProp Integer
0) (Term -> Type) -> Term -> Type
forall a b. (a -> b) -> a -> b
$ HasCallStack => [Char] -> Term
[Char] -> Term
__DUMMY_TERM_WITH__ [Char]
"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 a b. (a -> b) -> Either SplitError a -> Either SplitError b
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 Int
n = SplitClause -> Int -> Arg Int
lookupPatternVar SplitClause
sc (Int -> Arg Int) -> Int -> Arg Int
forall a b. (a -> b) -> a -> b
$ BlockingVar -> Int
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 Int -> [(SplitTag, (SplitClause, IInfo))] -> Covering
Covering Arg Int
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 -> Int -> Arg Int
lookupPatternVar SClause{ scTel :: SplitClause -> Tele (Dom Type)
scTel = Tele (Dom Type)
tel, scPats :: SplitClause -> [NamedArg SplitPattern]
scPats = [NamedArg SplitPattern]
pats } Int
x = Arg DeBruijnPattern
arg Arg DeBruijnPattern -> Int -> Arg Int
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>
    if Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0 then Int
forall a. HasCallStack => a
__IMPOSSIBLE__ else Int
n
  where n :: Int
n = if Int
k Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
< Int
0
            then Int
forall a. HasCallStack => a
__IMPOSSIBLE__
            else Int -> Maybe Int -> Int
forall a. a -> Maybe a -> a
fromMaybe Int
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Int -> Int) -> Maybe Int -> Int
forall a b. (a -> b) -> a -> b
$ Permutation -> [Int]
permPicks Permutation
perm [Int] -> Int -> Maybe Int
forall a. [a] -> Int -> Maybe a
!!! Int
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 :: Int
k = Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        arg :: Arg DeBruijnPattern
arg = Arg DeBruijnPattern
-> [Arg DeBruijnPattern] -> Int -> Arg DeBruijnPattern
forall a. a -> [a] -> Int -> a
indexWithDefault Arg DeBruijnPattern
forall a. HasCallStack => a
__IMPOSSIBLE__ (Int -> Tele (Dom Type) -> [Arg DeBruijnPattern]
telVars (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel) Tele (Dom Type)
tel) Int
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 Tele (Dom Type)
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId (Substitution' Term)
cps Maybe (Dom Type)
target) (BlockingVar Int
x [ConHead]
pcons' [Literal]
plits Bool
overlap Bool
lazy) =
 TCM (Either SplitError (Either SplitClause Covering))
-> TCM (Either SplitError (Either SplitClause Covering))
forall a. TCM a -> TCM a
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 (TCMT IO) (Either SplitClause Covering)
-> TCM (Either SplitError (Either SplitClause Covering))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT SplitError (TCMT IO) (Either SplitClause Covering)
 -> TCM (Either SplitError (Either SplitClause Covering)))
-> ExceptT SplitError (TCMT IO) (Either SplitClause Covering)
-> TCM (Either SplitError (Either SplitClause Covering))
forall a b. (a -> b) -> a -> b
$ do
  Tele (Dom Type)
-> Int
-> [NamedArg SplitPattern]
-> Map CheckpointId (Substitution' Term)
-> ExceptT SplitError (TCMT IO) ()
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 Tele (Dom Type)
tel Int
x [NamedArg SplitPattern]
ps Map CheckpointId (Substitution' Term)
cps

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

  -- Compute the neighbourhoods for the constructors
  let 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
        (dr, d, s, pars, ixs, cons', isHIT) <- ExceptT
  SplitError
  (TCMT IO)
  (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
   Bool)
-> ExceptT
     SplitError
     (TCMT IO)
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
forall (tcm :: * -> *) a. MonadAddContext tcm => tcm a -> tcm a
inContextOfT (ExceptT
   SplitError
   (TCMT IO)
   (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
    Bool)
 -> ExceptT
      SplitError
      (TCMT IO)
      (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
       Bool))
-> ExceptT
     SplitError
     (TCMT IO)
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
-> ExceptT
     SplitError
     (TCMT IO)
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
forall a b. (a -> b) -> a -> b
$ Induction
-> Dom Type
-> ExceptT
     SplitError
     (TCMT IO)
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
forall (tcm :: * -> *).
(MonadTCM tcm, MonadError SplitError tcm) =>
Induction
-> Dom Type
-> tcm
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term], [QName],
      Bool)
isDatatype Induction
ind Dom Type
t
        isFib <- fromRight (const False) <$> lift (isFibrant' t)
        cons <- case checkEmpty of
          CheckEmpty
CheckEmpty   -> ExceptT SplitError (TCMT IO) Bool
-> ExceptT SplitError (TCMT IO) [QName]
-> ExceptT SplitError (TCMT IO) [QName]
-> ExceptT SplitError (TCMT IO) [QName]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TCMT IO Bool -> ExceptT SplitError (TCMT IO) Bool
forall a. TCM a -> ExceptT SplitError (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Bool -> ExceptT SplitError (TCMT IO) Bool)
-> TCMT IO Bool -> ExceptT SplitError (TCMT IO) Bool
forall a b. (a -> b) -> a -> b
$ TCMT IO Bool -> TCMT IO Bool
forall (tcm :: * -> *) a. MonadAddContext 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
forall (tcm :: * -> *). MonadTCM tcm => Type -> tcm 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 (TCMT IO) [QName]
forall a. a -> ExceptT SplitError (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure []) ([QName] -> ExceptT SplitError (TCMT IO) [QName]
forall a. a -> ExceptT SplitError (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [QName]
cons')
          CheckEmpty
NoCheckEmpty -> [QName] -> ExceptT SplitError (TCMT IO) [QName]
forall a. a -> ExceptT SplitError (TCMT IO) a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [QName]
cons'
        mns  <- forM cons $ \ QName
con -> ((SplitClause, IInfo) -> (SplitTag, (SplitClause, IInfo)))
-> Maybe (SplitClause, IInfo)
-> Maybe (SplitTag, (SplitClause, IInfo))
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (QName -> SplitTag
SplitCon QName
con,) (Maybe (SplitClause, IInfo)
 -> Maybe (SplitTag, (SplitClause, IInfo)))
-> CoverM (Maybe (SplitClause, IInfo))
-> ExceptT
     SplitError (TCMT IO) (Maybe (SplitTag, (SplitClause, IInfo)))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Tele (Dom Type)
-> [Char]
-> Tele (Dom Type)
-> QName
-> [Arg Term]
-> [Arg Term]
-> Int
-> Tele (Dom Type)
-> [NamedArg SplitPattern]
-> Map CheckpointId (Substitution' Term)
-> QName
-> CoverM (Maybe (SplitClause, IInfo))
computeNeighbourhood Tele (Dom Type)
delta1 [Char]
n Tele (Dom Type)
delta2 QName
d [Arg Term]
pars [Arg Term]
ixs Int
x Tele (Dom Type)
tel [NamedArg SplitPattern]
ps Map CheckpointId (Substitution' Term)
cps QName
con
        hcompsc <- if isFib && (isHIT || not (null ixs)) && not (null mns) && inserttrailing == DoInsertTrailing
                   then computeHCompSplit delta1 n delta2 d pars ixs x tel ps cps
                   else return Nothing
        let ns = [Maybe (SplitTag, (SplitClause, IInfo))]
-> [(SplitTag, (SplitClause, IInfo))]
forall a. [Maybe a] -> [a]
catMaybes [Maybe (SplitTag, (SplitClause, IInfo))]
mns
        return ( dr
               , s
               , not (null ixs) -- Is "d" indexed?
               , length $ ns
               , ns ++! catMaybes ([fmap (fmap (,NoInfo)) hcompsc | not $ null $ ns])
               )

      computeLitNeighborhoods = do
        typeOk <- TCMT IO Bool -> ExceptT SplitError (TCMT IO) Bool
forall a. TCM a -> ExceptT SplitError (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Bool -> ExceptT SplitError (TCMT IO) Bool)
-> TCMT IO Bool -> ExceptT SplitError (TCMT IO) Bool
forall a b. (a -> b) -> a -> b
$ do
          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
          liftTCM $ dontAssignMetas $ tryConversion $ equalType (unDom t) t'
        unless typeOk $ throwError . NotADatatype =<< do liftTCM $ buildClosure (unDom t)
        ns <- forM plits $ \Literal
lit -> do
          let delta2' :: Tele (Dom Type)
delta2' = Int
-> SubstArg (Tele (Dom Type)) -> Tele (Dom Type) -> Tele (Dom Type)
forall a. Subst a => Int -> SubstArg a -> a -> a
subst Int
0 (Literal -> Term
Lit Literal
lit) Tele (Dom Type)
delta2
              delta' :: Tele (Dom Type)
delta'  = Tele (Dom Type)
delta1 Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
`abstract` Tele (Dom Type)
delta2'
              rho :: Substitution' SplitPattern
rho     = Int -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Int -> Substitution' a -> Substitution' a
liftS Int
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' Term)
cps'    = Substitution' SplitPattern
-> Map CheckpointId (Substitution' Term)
-> Map CheckpointId (Substitution' Term)
forall a. TermSubst a => Substitution' SplitPattern -> a -> a
applySplitPSubst Substitution' SplitPattern
rho Map CheckpointId (Substitution' Term)
cps
          (SplitTag, SplitClause)
-> ExceptT SplitError (TCMT IO) (SplitTag, SplitClause)
forall a. a -> ExceptT SplitError (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Literal -> SplitTag
SplitLit Literal
lit , Tele (Dom Type)
-> [NamedArg SplitPattern]
-> Substitution' SplitPattern
-> Map CheckpointId (Substitution' Term)
-> Maybe (Dom Type)
-> SplitClause
SClause Tele (Dom Type)
delta' [NamedArg SplitPattern]
ps' Substitution' SplitPattern
rho Map CheckpointId (Substitution' Term)
cps' Maybe (Dom Type)
forall a. Maybe a
Nothing)
        ca <- do
          let delta' = Tele (Dom Type)
tel -- telescope is unchanged for catchall branch
              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
                         { splitPatVarName :: [Char]
splitPatVarName   = [Char]
forall a. Underscore a => a
underscore
                         , splitPatVarIndex :: Int
splitPatVarIndex  = Int
0
                         , splitExcludedLits :: [Literal]
splitExcludedLits = [Literal]
plits
                         }
              rho    = Int -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Int -> Substitution' a -> Substitution' a
liftS Int
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
$ Int -> Substitution' SplitPattern
forall a. Int -> Substitution' a
raiseS Int
1
              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
          return (SplitCatchall , SClause delta' ps' rho cps 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").
        let ns' = ((SplitTag, SplitClause) -> (SplitTag, (SplitClause, IInfo)))
-> [(SplitTag, SplitClause)] -> [(SplitTag, (SplitClause, IInfo))]
forall a b. (a -> b) -> [a] -> [b]
map' (((SplitClause -> (SplitClause, IInfo))
-> (SplitTag, SplitClause) -> (SplitTag, (SplitClause, IInfo))
forall a b. (a -> b) -> (SplitTag, a) -> (SplitTag, b)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,IInfo
NoInfo))) ([(SplitTag, SplitClause)] -> [(SplitTag, (SplitClause, IInfo))])
-> [(SplitTag, SplitClause)] -> [(SplitTag, (SplitClause, IInfo))]
forall a b. (a -> b) -> a -> b
$ [(SplitTag, SplitClause)]
ns [(SplitTag, SplitClause)]
-> [(SplitTag, SplitClause)] -> [(SplitTag, SplitClause)]
forall a. [a] -> [a] -> [a]
++! [ (SplitTag, SplitClause)
ca ]
        return (IsData, mkType 0, False, length ns', ns')

  -- numMatching is the number of proper constructors matching, excluding hcomp.
  -- for literals this considers the catchall clause as 1 extra constructor.
  (dr, s, isIndexed, numMatching, ns) <- if null pcons' && not (null plits)
        then computeLitNeighborhoods
        else computeNeighborhoods

  ns <- case target of
    Just Dom Type
a  -> [(SplitTag, (SplitClause, IInfo))]
-> ((SplitTag, (SplitClause, IInfo))
    -> ExceptT SplitError (TCMT IO) (SplitTag, (SplitClause, IInfo)))
-> ExceptT SplitError (TCMT IO) [(SplitTag, (SplitClause, IInfo))]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(SplitTag, (SplitClause, IInfo))]
ns (((SplitTag, (SplitClause, IInfo))
  -> ExceptT SplitError (TCMT IO) (SplitTag, (SplitClause, IInfo)))
 -> ExceptT SplitError (TCMT IO) [(SplitTag, (SplitClause, IInfo))])
-> ((SplitTag, (SplitClause, IInfo))
    -> ExceptT SplitError (TCMT IO) (SplitTag, (SplitClause, IInfo)))
-> ExceptT SplitError (TCMT IO) [(SplitTag, (SplitClause, IInfo))]
forall a b. (a -> b) -> a -> b
$ \ (SplitTag
con,(SplitClause
sc,IInfo
info)) -> TCMT IO (SplitTag, (SplitClause, IInfo))
-> ExceptT SplitError (TCMT IO) (SplitTag, (SplitClause, IInfo))
forall (m :: * -> *) a. Monad m => m a -> ExceptT SplitError m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO (SplitTag, (SplitClause, IInfo))
 -> ExceptT SplitError (TCMT IO) (SplitTag, (SplitClause, IInfo)))
-> TCMT IO (SplitTag, (SplitClause, IInfo))
-> ExceptT SplitError (TCMT IO) (SplitTag, (SplitClause, IInfo))
forall a b. (a -> b) -> a -> b
$ (SplitTag
con,) ((SplitClause, IInfo) -> (SplitTag, (SplitClause, IInfo)))
-> (SplitClause -> (SplitClause, IInfo))
-> SplitClause
-> (SplitTag, (SplitClause, IInfo))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (,IInfo
info) (SplitClause -> (SplitTag, (SplitClause, IInfo)))
-> TCMT IO SplitClause -> TCMT IO (SplitTag, (SplitClause, IInfo))
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, IInfo))]
-> ExceptT SplitError (TCMT IO) [(SplitTag, (SplitClause, IInfo))]
forall a. a -> ExceptT SplitError (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(SplitTag, (SplitClause, IInfo))]
ns

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

  mHCompName <- getPrimitiveName' builtinHComp
  opts       <- pragmaOptions
  let withoutK        = PragmaOptions -> Bool
optWithoutK PragmaOptions
opts
      erasedMatches   = PragmaOptions -> Bool
optErasedMatches PragmaOptions
opts
      isRecordWithEta = case DataOrRecord
dr of
        DataOrRecord
IsData       -> Bool
False
        IsRecord InductionAndEta
r ->
          case EtaEquality -> HasEta
theEtaEquality (InductionAndEta -> EtaEquality
recordEtaEquality InductionAndEta
r) of
            YesEta{} -> Bool
True
            NoEta{}  -> Bool
False

  erased <- hasQuantity0 <$> viewTC eQuantity
  reportSLn "tc.cover.split" 60 $ "We are in erased context = " ++! show erased
  let erasedError ErasedDatatypeReason
reason =
        SplitError
-> ExceptT SplitError (TCMT IO) (Either SplitClause Covering)
forall a. SplitError -> ExceptT SplitError (TCMT IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (SplitError
 -> ExceptT SplitError (TCMT IO) (Either SplitClause Covering))
-> (Closure Type -> SplitError)
-> Closure Type
-> ExceptT SplitError (TCMT IO) (Either SplitClause Covering)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ErasedDatatypeReason -> Closure Type -> SplitError
ErasedDatatype ErasedDatatypeReason
reason (Closure Type
 -> ExceptT SplitError (TCMT IO) (Either SplitClause Covering))
-> ExceptT SplitError (TCMT IO) (Closure Type)
-> ExceptT SplitError (TCMT IO) (Either SplitClause Covering)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
          do TCM (Closure Type) -> ExceptT SplitError (TCMT IO) (Closure Type)
forall a. TCM a -> ExceptT SplitError (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Closure Type) -> ExceptT SplitError (TCMT IO) (Closure Type))
-> TCM (Closure Type)
-> ExceptT SplitError (TCMT IO) (Closure Type)
forall a b. (a -> b) -> a -> b
$ TCM (Closure Type) -> TCM (Closure Type)
forall (tcm :: * -> *) a. MonadAddContext 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 numMatching of
    Int
0  -> 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
$ [Char] -> Int -> [Literal] -> SplitPatVar
SplitPatVar [Char]
forall a. Underscore a => a
underscore Int
0 []
          rho :: Substitution' SplitPattern
rho = Int -> Substitution' SplitPattern -> Substitution' SplitPattern
forall a. Int -> Substitution' a -> Substitution' a
liftS Int
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
$ Int -> Substitution' SplitPattern
forall a. Int -> Substitution' a
raiseS Int
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 (TCMT IO) (Either SplitClause Covering)
forall a. a -> ExceptT SplitError (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SplitClause Covering
 -> ExceptT SplitError (TCMT IO) (Either SplitClause Covering))
-> Either SplitClause Covering
-> ExceptT SplitError (TCMT IO) (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
               { scTel :: Tele (Dom Type)
scTel  = Tele (Dom Type)
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' Term)
scCheckpoints        = Map CheckpointId (Substitution' Term)
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.
    Int
n | Int
n Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
1 Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
erased Bool -> Bool -> Bool
&& Bool -> Bool
not (Dom Type -> Bool
forall a. LensQuantity a => a -> Bool
usableQuantity Dom Type
t) ->
      ErasedDatatypeReason
-> ExceptT SplitError (TCMT IO) (Either SplitClause Covering)
erasedError ErasedDatatypeReason
SeveralConstructors

    -- If exactly one constructor matches and the K rule is turned
    -- off, then we only allow erasure for non-indexed data/record
    -- types (#4172). If the type is not a record type with
    -- η-equality, then the flag --erased-matches must be active.
    Int
1 | 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 -> Bool -> Bool
|| Bool -> Bool
not Bool
isRecordWithEta Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
erasedMatches) ->
      ErasedDatatypeReason
-> ExceptT SplitError (TCMT IO) (Either SplitClause Covering)
erasedError (if Bool
isIndexed then ErasedDatatypeReason
NoK else ErasedDatatypeReason
NoErasedMatches)

    Int
_ -> 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 (TCMT IO) ()
-> ExceptT SplitError (TCMT IO) ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
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 (TCMT IO) ()
 -> ExceptT SplitError (TCMT IO) ())
-> ExceptT SplitError (TCMT IO) ()
-> ExceptT SplitError (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$
        [(SplitTag, (SplitClause, IInfo))]
-> ((SplitTag, (SplitClause, IInfo))
    -> ExceptT SplitError (TCMT IO) ())
-> ExceptT SplitError (TCMT IO) ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(SplitTag, (SplitClause, IInfo))]
ns (((SplitTag, (SplitClause, IInfo))
  -> ExceptT SplitError (TCMT IO) ())
 -> ExceptT SplitError (TCMT IO) ())
-> ((SplitTag, (SplitClause, IInfo))
    -> ExceptT SplitError (TCMT IO) ())
-> ExceptT SplitError (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ \(SplitTag
tag, (SplitClause
sc, IInfo
_)) -> do
          Bool
-> ExceptT SplitError (TCMT IO) ()
-> ExceptT SplitError (TCMT IO) ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (SplitTag
tag SplitTag -> Set SplitTag -> Bool
forall a. Ord a => a -> Set a -> Bool
`Set.member` Set SplitTag
all_tags) (ExceptT SplitError (TCMT IO) ()
 -> ExceptT SplitError (TCMT IO) ())
-> ExceptT SplitError (TCMT IO) ()
-> ExceptT SplitError (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ do
            isImpossibleClause <- Tele (Dom Type) -> ExceptT SplitError (TCMT IO) Bool
forall (tcm :: * -> *). MonadTCM tcm => Tele (Dom Type) -> tcm Bool
isEmptyTel (Tele (Dom Type) -> ExceptT SplitError (TCMT IO) Bool)
-> Tele (Dom Type) -> ExceptT SplitError (TCMT IO) Bool
forall a b. (a -> b) -> a -> b
$ SplitClause -> Tele (Dom Type)
scTel SplitClause
sc
            unless isImpossibleClause $ do
              liftTCM $ reportSDoc "tc.cover" 10 $ vcat
                [ text "Missing case for" <+> prettyTCM tag
                , nest 2 $ prettyTCM sc
                ]
              throwError (GenericSplitError "precomputed set of constructors does not cover all cases")

      let t' :: Type
t' = ASetter Type Type (Sort' Term) (Sort' Term)
-> Sort' Term -> Type -> Type
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Type Type (Sort' Term) (Sort' Term)
forall a. LensSort a => Lens' a (Sort' Term)
Lens' Type (Sort' Term)
lensSort Sort' Term
s (Type -> Type) -> Type -> Type
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t
      TCMT IO () -> ExceptT SplitError (TCMT IO) ()
forall a. TCM a -> ExceptT SplitError (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> ExceptT SplitError (TCMT IO) ())
-> TCMT IO () -> ExceptT SplitError (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) a. MonadAddContext tcm => tcm a -> tcm a
inContextOfT (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ DataOrRecord
-> Type -> Tele (Dom Type) -> 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 -> Tele (Dom Type) -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr Type
t' Tele (Dom Type)
delta2 Maybe (Dom Type)
target
      Either SplitClause Covering
-> ExceptT SplitError (TCMT IO) (Either SplitClause Covering)
forall a. a -> ExceptT SplitError (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either SplitClause Covering
 -> ExceptT SplitError (TCMT IO) (Either SplitClause Covering))
-> Either SplitClause Covering
-> ExceptT SplitError (TCMT IO) (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 Int -> [(SplitTag, (SplitClause, IInfo))] -> Covering
Covering (SplitClause -> Int -> Arg Int
lookupPatternVar SplitClause
sc Int
x) [(SplitTag, (SplitClause, IInfo))]
ns

  where
    inContextOfT, inContextOfDelta2 :: (MonadAddContext tcm) => tcm a -> tcm a
    inContextOfT :: forall (tcm :: * -> *) a. MonadAddContext tcm => tcm a -> tcm a
inContextOfT      = Tele (Dom Type) -> tcm a -> tcm a
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (tcm a -> tcm a) -> (tcm a -> tcm a) -> tcm a -> tcm a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Impossible -> Int -> tcm a -> tcm a
forall (m :: * -> *) a.
MonadAddContext m =>
Impossible -> Int -> m a -> m a
escapeContext Impossible
HasCallStack => Impossible
impossible (Int
x Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
    inContextOfDelta2 :: forall (tcm :: * -> *) a. MonadAddContext tcm => tcm a -> tcm a
inContextOfDelta2 = Tele (Dom Type) -> tcm a -> tcm a
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (tcm a -> tcm a) -> (tcm a -> tcm a) -> tcm a -> tcm a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Impossible -> Int -> tcm a -> tcm a
forall (m :: * -> *) a.
MonadAddContext m =>
Impossible -> Int -> m a -> m a
escapeContext Impossible
HasCallStack => Impossible
impossible Int
x

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

    debugHoleAndType :: a -> a -> [Char] -> [NamedArg DeBruijnPattern] -> a -> tcm ()
debugHoleAndType a
delta1 a
delta2 [Char]
s [NamedArg DeBruijnPattern]
ps a
t =
      TCMT IO () -> tcm ()
forall a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.top" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        [ TCMT IO Doc
"p      =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> [Char]
patVarNameToString [Char]
s)
        , TCMT IO Doc
"ps     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList [NamedArg DeBruijnPattern]
ps
        , TCMT IO Doc
"delta1 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
delta1
        , TCMT IO Doc
"delta2 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc -> TCMT IO Doc
forall (tcm :: * -> *) a. MonadAddContext tcm => tcm a -> tcm a
inContextOfDelta2 (a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
delta2)
        , TCMT IO Doc
"t      =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc -> TCMT IO Doc
forall (tcm :: * -> *) a. MonadAddContext tcm => tcm a -> tcm a
inContextOfT (a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). 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 a b. (a -> b) -> TCMT IO a -> TCMT IO b
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 a b. (a -> b) -> Either SplitError a -> Either SplitError b
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 a. a -> TCMT IO a
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 Tele (Dom Type)
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId (Substitution' Term)
_ 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 a. a -> TCMT IO a
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 a. a -> TCMT IO a
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 i b, boundary) <- Int -> Type -> TCM (TelV Type, Boundary' Int Term)
forall (m :: * -> *).
PureTCM m =>
Int -> Type -> m (TelV Type, Boundary' Int Term)
telViewUpToPathBoundary' Int
1 (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t)
               let tel' = Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
tel Tele (Dom Type)
i
                   rho  = Int -> Substitution' a
forall a. Int -> Substitution' a
raiseS Int
1
                   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])
forall a. Substitution' a
rho (SplitClause -> [NamedArg SplitPattern]
scPats SplitClause
sc) [NamedArg SplitPattern]
-> [NamedArg SplitPattern] -> [NamedArg SplitPattern]
forall a. [a] -> [a] -> [a]
++! Tele (Dom Type) -> Boundary' Int Term -> [NamedArg SplitPattern]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary' Int Term -> [NamedArg (Pattern' a)]
telePatterns Tele (Dom Type)
i Boundary' Int Term
boundary
                   cps' = Substitution' (SubstArg (Map CheckpointId (Substitution' Term)))
-> Map CheckpointId (Substitution' Term)
-> Map CheckpointId (Substitution' Term)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' Term
Substitution' (SubstArg (Map CheckpointId (Substitution' Term)))
forall a. Substitution' a
rho (SplitClause -> Map CheckpointId (Substitution' Term)
scCheckpoints SplitClause
sc)
                   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 a b. a -> Dom' Term b -> Dom' Term a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Dom Type
t
               return . Just $ SClause tel' ps' idS cps' 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 Tele (Dom Type)
tel [NamedArg SplitPattern]
ps Substitution' SplitPattern
_ Map CheckpointId (Substitution' Term)
_ Maybe (Dom Type)
target) = do
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover.split" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"splitting result:"
    , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"f      =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
f
    , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (TCMT IO Doc
-> (Dom Type -> TCMT IO Doc) -> Maybe (Dom Type) -> TCMT IO Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO Doc
forall a. Null a => a
empty Dom Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Dom Type -> 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 a. a -> TCMT IO a
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
    (Tele (Dom Type)
-> TCMT IO (Maybe (QName, [Arg Term], RecordData))
-> TCMT IO (Maybe (QName, [Arg Term], RecordData))
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (TCMT IO (Maybe (QName, [Arg Term], RecordData))
 -> TCMT IO (Maybe (QName, [Arg Term], RecordData)))
-> TCMT IO (Maybe (QName, [Arg Term], RecordData))
-> TCMT IO (Maybe (QName, [Arg Term], RecordData))
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO (Maybe (QName, [Arg Term], RecordData))
forall (m :: * -> *).
(HasCallStack, PureTCM m) =>
Type -> m (Maybe (QName, [Arg Term], RecordData))
isRecordType (Type -> TCMT IO (Maybe (QName, [Arg Term], RecordData)))
-> Type -> TCMT IO (Maybe (QName, [Arg Term], RecordData))
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
t) TCMT IO (Maybe (QName, [Arg Term], RecordData))
-> (Maybe (QName, [Arg Term], RecordData)
    -> TCMT IO (Either SplitError Covering))
-> TCMT IO (Either SplitError Covering)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Maybe (QName, [Arg Term], RecordData)
Nothing -> Tele (Dom Type)
-> TCMT IO (Either SplitError Covering)
-> TCMT IO (Either SplitError Covering)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
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
        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 (Closure Type -> TCMT IO (Either SplitError Covering))
-> TCM (Closure Type) -> TCMT IO (Either SplitError Covering)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m 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)
      Just (QName
_r, [Arg Term]
vs, RecordData{ _recFields :: RecordData -> [Dom QName]
_recFields = [Dom QName]
fs }) -> do
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
          [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"we are of record type _r = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
_r
          , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"applied to parameters vs =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel ([Arg Term] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Arg Term] -> m Doc
prettyTCM [Arg Term]
vs)
          , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"and have fields       fs = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! [Dom QName] -> [Char]
forall a. Pretty a => a -> [Char]
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 :: [Arg Term]
pargs = [Arg Term]
vs [Arg Term] -> [Arg Term] -> [Arg Term]
forall a. [a] -> [a] -> [a]
++! [Arg Term
self]
            fieldValues :: [Term]
fieldValues = [Dom QName] -> (Dom QName -> Term) -> [Term]
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f 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)]
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.cover" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
          [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"we are              self =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
self)
          , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"            field values =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Term] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Term] -> m Doc
prettyTCM [Term]
fieldValues
          ]
        let n :: Arg Int
n = Int -> Arg Int
forall a. a -> Arg a
defaultArg (Int -> Arg Int) -> Int -> Arg Int
forall a b. (a -> b) -> a -> b
$ Permutation -> Int
permRange (Permutation -> Int) -> Permutation -> Int
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 <- 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 a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjOrigin
ProjPostfix) (ProjOrigin -> TCMT IO ProjOrigin
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ProjOrigin
ProjPrefix)
        Right . Covering n <$> do
          forM (zip fs $ List.inits fieldValues) $ \ (Dom QName
proj, [Term]
prevFields) -> do
            -- compute the new target
            dType <- Definition -> Type
defType (Definition -> Type) -> TCM Definition -> TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do QName -> TCM Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo (QName -> TCM Definition) -> QName -> TCM 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 = [Term] -> [Term]
forall a. [a] -> [a]
reverse ((Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg [Arg Term]
vs [Term] -> [Term] -> [Term]
forall a. [a] -> [a] -> [a]
++! [Term]
prevFields) [Term] -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Impossible -> Substitution' Term
forall a. Impossible -> Substitution' a
EmptyS Impossible
HasCallStack => Impossible
impossible
                proj'    = Substitution' (SubstArg (Dom QName)) -> Dom QName -> Dom QName
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' Term
Substitution' (SubstArg (Dom QName))
fieldSub Dom QName
proj
                -- type of projection instantiated at self
                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 -> [Arg Term] -> Type
`piApply` [Arg Term]
pargs      -- Always visible (#2287)
                projArg = (QName -> Named NamedName SplitPattern)
-> Arg QName -> NamedArg SplitPattern
forall a b. (a -> b) -> Arg a -> Arg b
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 { scPats   = scPats sc ++! [projArg]
                         , scSubst  = idS
                         , scTarget = target'
                         }
            reportSDoc "tc.cover.copattern" 40 $ vcat
              [ "fieldSub for" <+> prettyTCM (unDom proj)
              , nest 2 $ pretty fieldSub ]
            return (SplitCon (unDom proj), (sc', NoInfo))
  -- 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 :: forall (m :: * -> *). MonadPretty m => SplitClause -> m Doc
prettyTCM (SClause Tele (Dom Type)
tel [NamedArg SplitPattern]
pats Substitution' SplitPattern
sigma Map CheckpointId (Substitution' Term)
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"
    , Int -> m Doc -> m Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
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
<+> Tele (Dom Type) -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
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
forall (m :: * -> *). MonadPretty m => SplitPattern -> 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
forall (m :: * -> *).
MonadPretty m =>
Substitution' SplitPattern -> 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' Term) -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Map CheckpointId (Substitution' Term) -> m Doc
prettyTCM Map CheckpointId (Substitution' Term)
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
            Tele (Dom Type) -> m Doc -> m Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
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
forall (m :: * -> *). MonadPretty m => Dom Type -> 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
      ]
    ]