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

module Agda.TypeChecking.Rules.LHS
  ( checkLeftHandSide
  , LHSResult(..)
  , bindAsPatterns
  , IsFlexiblePattern(..)
  , DataOrRecord
  , checkSortOfSplitVar
  , LetOrClause(LetLHS, ClauseLHS)
  , buildLHSSubstitutions
  ) where

import Prelude hiding ( null )

import Data.Function (on)
import Data.Maybe

import Control.Monad.Except       ( MonadError(..), ExceptT(..), runExceptT )
import Control.Monad.Trans.Maybe

import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List (findIndex)
import qualified Data.List as List
import Data.Map (Map)
import qualified Data.Map as Map

import Agda.Interaction.Highlighting.Generate
  ( storeDisambiguatedConstructor, storeDisambiguatedProjection, disambiguateRecordFields)
import Agda.Interaction.Options
import Agda.Interaction.Options.Lenses

import Agda.Syntax.Internal as I
import Agda.Syntax.Internal.Pattern
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Views (asView, deepUnscope)
import Agda.Syntax.Concrete (FieldAssignment'(..),LensInScope(..))
import Agda.Syntax.Common as Common hiding (DataOrRecord)
import qualified Agda.Syntax.Info as A
import Agda.Syntax.Literal
import Agda.Syntax.Position

import Agda.TypeChecking.Monad

import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import Agda.TypeChecking.Conversion
import Agda.TypeChecking.Constraints
import Agda.TypeChecking.CheckInternal (checkInternal)
import Agda.TypeChecking.Datatypes hiding (isDataOrRecordType)
import Agda.TypeChecking.Errors (dropTopLevelModule)
import Agda.TypeChecking.Irrelevance
-- Prevent "Ambiguous occurrence ‘DontKnow’" when loading with ghci.
-- (DontKnow is one of the constructors of ErrorNonEmpty *and* UnifactionResult').
-- We can't explicitly hide just the constructor here because it isn't in the
-- hs-boot file.
import {-# SOURCE #-} Agda.TypeChecking.Empty (ensureEmptyType)
import Agda.TypeChecking.Patterns.Abstract
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Records hiding (getRecordConstructor)
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Sort
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Telescope.Path
import Agda.TypeChecking.Primitive hiding (Nat)
import Agda.TypeChecking.Warnings (warning)

import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkExpr, isType_)
import Agda.TypeChecking.Rules.LHS.Problem
import Agda.TypeChecking.Rules.LHS.ProblemRest
import Agda.TypeChecking.Rules.LHS.Unify
import Agda.TypeChecking.Rules.LHS.Implicit

import Agda.Utils.CallStack ( HasCallStack, withCallerCallStack )
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.List1 (List1, pattern (:|))
import Agda.Utils.List2 (pattern List2)
import qualified Agda.Utils.List1 as List1
import qualified Agda.Utils.List2 as List2
import Agda.Utils.Either
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import qualified Agda.Syntax.Common.Pretty as P
import Agda.Syntax.Common.Pretty (prettyShow)
import Agda.Utils.Singleton
import Agda.Utils.Size
import Agda.Utils.Tuple
import Agda.Utils.StrictReader
import Agda.Utils.StrictWriter

import Agda.Utils.Impossible
import Agda.TypeChecking.Free (freeIn)

-- | Are we checking the LHS of a let-pattern binding or a function clause?
data LetOrClause
  = LetLHS
      -- ^ Checking a pattern bound by a let.
  | ClauseLHS QName
      -- ^ Checking the LHS of a clause of the function with the given 'QName'.

-- | Extra read-only state for the LHS checker.
--
data LHSContext = LHSContext
  { LHSContext -> Range' SrcFile
lhsRange       :: Range  -- ^ The range of the whole lhs of a clause.
  , LHSContext -> Int
lhsContextSize :: Nat    -- ^ Original size of the context in which the lhs checker runs.
  }

-- | A pattern is flexible if it is dotted or implicit, or a record pattern
--   with only flexible subpatterns.
class IsFlexiblePattern a where
  maybeFlexiblePattern :: (HasConstInfo m) => a -> MaybeT m FlexibleVarKind

  isFlexiblePattern :: (HasConstInfo m) => a -> m Bool
  isFlexiblePattern a
p =
    Bool -> (FlexibleVarKind -> Bool) -> Maybe FlexibleVarKind -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FlexibleVarKind -> Bool
notOtherFlex (Maybe FlexibleVarKind -> Bool)
-> m (Maybe FlexibleVarKind) -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT m FlexibleVarKind -> m (Maybe FlexibleVarKind)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
HasConstInfo m =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern a
p)
    where
    notOtherFlex :: FlexibleVarKind -> Bool
notOtherFlex = \case
      RecordFlex [FlexibleVarKind]
fls -> (FlexibleVarKind -> Bool) -> [FlexibleVarKind] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all FlexibleVarKind -> Bool
notOtherFlex [FlexibleVarKind]
fls
      FlexibleVarKind
ImplicitFlex   -> Bool
True
      FlexibleVarKind
DotFlex        -> Bool
True
      FlexibleVarKind
OtherFlex      -> Bool
False

instance IsFlexiblePattern A.Pattern where
  maybeFlexiblePattern :: forall (m :: * -> *).
HasConstInfo m =>
Pattern' Expr -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern' Expr
p = do
    [Char] -> Int -> TCMT IO Doc -> MaybeT m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.flex" Int
30 (TCMT IO Doc -> MaybeT m ()) -> TCMT IO Doc -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"maybeFlexiblePattern" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Pattern' Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern' Expr
p
    [Char] -> Int -> TCMT IO Doc -> MaybeT m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.flex" Int
60 (TCMT IO Doc -> MaybeT m ()) -> TCMT IO Doc -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"maybeFlexiblePattern (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)
-> (Pattern' Expr -> [Char]) -> Pattern' Expr -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern' Expr -> [Char]
forall a. Show a => a -> [Char]
show (Pattern' Expr -> [Char])
-> (Pattern' Expr -> Pattern' Expr) -> Pattern' Expr -> [Char]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern' Expr -> Pattern' Expr
forall a. ExprLike a => a -> a
deepUnscope) Pattern' Expr
p
    case Pattern' Expr
p of
      A.DotP{}  -> FlexibleVarKind -> MaybeT m FlexibleVarKind
forall a. a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
DotFlex
      A.VarP{}  -> FlexibleVarKind -> MaybeT m FlexibleVarKind
forall a. a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
ImplicitFlex
      A.WildP{} -> FlexibleVarKind -> MaybeT m FlexibleVarKind
forall a. a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
ImplicitFlex
      A.AsP PatInfo
_ BindName
_ Pattern' Expr
p -> Pattern' Expr -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
HasConstInfo m =>
Pattern' Expr -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern' Expr
p
      A.ConP ConPatInfo
_ AmbiguousQName
cs [Arg (Named_ (Pattern' Expr))]
qs | Just QName
c <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
cs ->
        MaybeT m Bool
-> MaybeT m FlexibleVarKind
-> MaybeT m FlexibleVarKind
-> MaybeT m FlexibleVarKind
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Maybe (QName, RecordData) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (QName, RecordData) -> Bool)
-> MaybeT m (Maybe (QName, RecordData)) -> MaybeT m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> MaybeT m (Maybe (QName, RecordData))
forall (m :: * -> *).
(HasCallStack, HasConstInfo m) =>
QName -> m (Maybe (QName, RecordData))
isRecordConstructor QName
c) (FlexibleVarKind -> MaybeT m FlexibleVarKind
forall a. a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
OtherFlex) {-else-}
            ([Arg (Named_ (Pattern' Expr))] -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
HasConstInfo m =>
[Arg (Named_ (Pattern' Expr))] -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [Arg (Named_ (Pattern' Expr))]
qs)
      A.LitP{}  -> FlexibleVarKind -> MaybeT m FlexibleVarKind
forall a. a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
OtherFlex
      Pattern' Expr
_ -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance IsFlexiblePattern (I.Pattern' a) where
  maybeFlexiblePattern :: forall (m :: * -> *).
HasConstInfo m =>
Pattern' a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern' a
p =
    case Pattern' a
p of
      I.DotP{}  -> FlexibleVarKind -> MaybeT m FlexibleVarKind
forall a. a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
DotFlex
      I.ConP ConHead
_ ConPatternInfo
i [NamedArg (Pattern' a)]
ps
        | ConPatternInfo -> Bool
conPRecord ConPatternInfo
i , PatOrigin
PatOSystem <- PatternInfo -> PatOrigin
patOrigin (ConPatternInfo -> PatternInfo
conPInfo ConPatternInfo
i) -> FlexibleVarKind -> MaybeT m FlexibleVarKind
forall a. a -> MaybeT m a
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
ImplicitFlex  -- expanded from ImplicitP
        | ConPatternInfo -> Bool
conPRecord ConPatternInfo
i -> [NamedArg (Pattern' a)] -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
HasConstInfo m =>
[NamedArg (Pattern' a)] -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [NamedArg (Pattern' a)]
ps
        | Bool
otherwise -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.VarP{}  -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.LitP{}  -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.ProjP{} -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.IApplyP{} -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.DefP{} -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- TODO Andrea check semantics

-- | Lists of flexible patterns are 'RecordFlex'.
instance IsFlexiblePattern a => IsFlexiblePattern [a] where
  maybeFlexiblePattern :: forall (m :: * -> *).
HasConstInfo m =>
[a] -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [a]
ps = [FlexibleVarKind] -> FlexibleVarKind
RecordFlex ([FlexibleVarKind] -> FlexibleVarKind)
-> MaybeT m [FlexibleVarKind] -> MaybeT m FlexibleVarKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> MaybeT m FlexibleVarKind)
-> [a] -> MaybeT m [FlexibleVarKind]
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 a -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
HasConstInfo m =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [a]
ps

instance IsFlexiblePattern a => IsFlexiblePattern (Arg a) where
  maybeFlexiblePattern :: forall (m :: * -> *).
HasConstInfo m =>
Arg a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern = a -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
HasConstInfo m =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern (a -> MaybeT m FlexibleVarKind)
-> (Arg a -> a) -> Arg a -> MaybeT m FlexibleVarKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg a -> a
forall e. Arg e -> e
unArg

instance IsFlexiblePattern a => IsFlexiblePattern (Common.Named name a) where
  maybeFlexiblePattern :: forall (m :: * -> *).
HasConstInfo m =>
Named name a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern = a -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
HasConstInfo m =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern (a -> MaybeT m FlexibleVarKind)
-> (Named name a -> a) -> Named name a -> MaybeT m FlexibleVarKind
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named name a -> a
forall name a. Named name a -> a
namedThing

-- | Update the given LHS state:
--   1. simplify problem equations
--   2. rename telescope variables
--   3. introduce trailing patterns
updateLHSState :: LHSState a -> TCM (LHSState a)
updateLHSState :: forall a. LHSState a -> TCM (LHSState a)
updateLHSState LHSState a
st = do
  let tel :: Tele (Dom (Type'' Term Term))
tel     = LHSState a
st LHSState a
-> Getting
     (Tele (Dom (Type'' Term Term)))
     (LHSState a)
     (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall s a. s -> Getting a s a -> a
^. Getting
  (Tele (Dom (Type'' Term Term)))
  (LHSState a)
  (Tele (Dom (Type'' Term Term)))
forall a (f :: * -> *).
Functor f =>
(Tele (Dom (Type'' Term Term))
 -> f (Tele (Dom (Type'' Term Term))))
-> LHSState a -> f (LHSState a)
lhsTel
      problem :: Problem a
problem = LHSState a
st LHSState a
-> Getting (Problem a) (LHSState a) (Problem a) -> Problem a
forall s a. s -> Getting a s a -> a
^. Getting (Problem a) (LHSState a) (Problem a)
forall a (f :: * -> *).
Functor f =>
(Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
lhsProblem
  eqs' <- Tele (Dom (Type'' Term Term))
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
tel (TCMT IO [ProblemEq] -> TCMT IO [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ [ProblemEq] -> TCMT IO [ProblemEq]
updateProblemEqs ([ProblemEq] -> TCMT IO [ProblemEq])
-> [ProblemEq] -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a
-> Getting [ProblemEq] (Problem a) [ProblemEq] -> [ProblemEq]
forall s a. s -> Getting a s a -> a
^. Getting [ProblemEq] (Problem a) [ProblemEq]
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs
  tel' <- useNamesFromProblemEqs eqs' tel
  updateProblemRest $ set lhsTel tel' $ set (lhsProblem . problemEqs) eqs' st

-- | Update the user patterns in the given problem, simplifying equations
--   between constructors where possible.
updateProblemEqs
 :: [ProblemEq] -> TCM [ProblemEq]
updateProblemEqs :: [ProblemEq] -> TCMT IO [ProblemEq]
updateProblemEqs [ProblemEq]
eqs = do
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" 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
"updateProblem: equations to update"
    , 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
$ if [ProblemEq] -> Bool
forall a. Null a => a -> Bool
null [ProblemEq]
eqs then TCMT IO Doc
"(none)" else [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
$ (ProblemEq -> TCMT IO Doc) -> [ProblemEq] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map'  ProblemEq -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ProblemEq -> m Doc
prettyTCM [ProblemEq]
eqs
    ]

  eqs' <- [ProblemEq] -> TCMT IO [ProblemEq]
updates [ProblemEq]
eqs

  reportSDoc "tc.lhs.top" 20 $ vcat
    [ "updateProblem: new equations"
    , nest 2 $ if null eqs' then "(none)" else vcat $ map'  prettyTCM eqs'
    ]

  return eqs'

  where

    updates :: [ProblemEq] -> TCM [ProblemEq]
    updates :: [ProblemEq] -> TCMT IO [ProblemEq]
updates = [[ProblemEq]] -> [ProblemEq]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ProblemEq]] -> [ProblemEq])
-> ([ProblemEq] -> TCMT IO [[ProblemEq]])
-> [ProblemEq]
-> TCMT IO [ProblemEq]
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> (ProblemEq -> TCMT IO [ProblemEq])
-> [ProblemEq] -> TCMT IO [[ProblemEq]]
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 ProblemEq -> TCMT IO [ProblemEq]
update

    update :: ProblemEq -> TCM [ProblemEq]
    update :: ProblemEq -> TCMT IO [ProblemEq]
update eq :: ProblemEq
eq@(ProblemEq A.WildP{} Term
_ Dom (Type'' Term Term)
_) = [ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]
    update eq :: ProblemEq
eq@(ProblemEq p :: Pattern' Expr
p@A.ProjP{} Term
_ Dom (Type'' Term Term)
_) = TypeError -> TCMT IO [ProblemEq]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO [ProblemEq])
-> TypeError -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Pattern' Expr -> TypeError
IllformedProjectionPatternAbstract Pattern' Expr
p
    update eq :: ProblemEq
eq@(ProblemEq p :: Pattern' Expr
p@(A.AsP PatInfo
info BindName
x Pattern' Expr
p') Term
v Dom (Type'' Term Term)
a) =
      (Pattern' Expr -> Term -> Dom (Type'' Term Term) -> ProblemEq
ProblemEq (BindName -> Pattern' Expr
forall e. BindName -> Pattern' e
A.VarP BindName
x) Term
v Dom (Type'' Term Term)
a ProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProblemEq -> TCMT IO [ProblemEq]
update (Pattern' Expr -> Term -> Dom (Type'' Term Term) -> ProblemEq
ProblemEq Pattern' Expr
p' Term
v Dom (Type'' Term Term)
a)

    update eq :: ProblemEq
eq@(ProblemEq Pattern' Expr
p Term
v Dom (Type'' Term Term)
a) = Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
v TCMT IO Term -> (Term -> TCMT IO Term) -> TCMT IO Term
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
>>= Term -> TCMT IO Term
forall (m :: * -> *). HasBuiltins m => Term -> m Term
constructorForm TCMT IO Term
-> (Term -> TCMT IO [ProblemEq]) -> TCMT IO [ProblemEq]
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
      Con ConHead
c ConInfo
ci Elims
es -> do
        let vs :: [Arg Term]
vs = Elims -> [Arg Term]
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims Elims
es
        -- we should only simplify equations between fully applied constructors
        contype <- ConHead
-> Type'' Term Term
-> TCMT
     IO
     (Maybe ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term))
forall (m :: * -> *).
PureTCM m =>
ConHead
-> Type'' Term Term
-> m (Maybe
        ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term))
getFullyAppliedConType ConHead
c (Type'' Term Term
 -> TCMT
      IO
      (Maybe ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term)))
-> TCMT IO (Type'' Term Term)
-> TCMT
     IO
     (Maybe ((QName, Type'' Term Term, [Arg Term]), Type'' Term Term))
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type'' Term Term -> TCMT IO (Type'' Term Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom Dom (Type'' Term Term)
a)
        caseMaybe contype (return [eq]) $ \((QName
d,Type'' Term Term
_,[Arg Term]
pars),Type'' Term Term
b) -> do
        TelV ctel _ <- Type'' Term Term -> TCMT IO (TelV (Type'' Term Term))
forall (m :: * -> *).
PureTCM m =>
Type'' Term Term -> m (TelV (Type'' Term Term))
telViewPath Type'' Term Term
b

        -- Andrea 15/10/2020: propagate modality to constructor arguments
        let updMod = Modality -> Modality -> Modality
composeModality (Dom (Type'' Term Term) -> Modality
forall a. LensModality a => a -> Modality
getModality Dom (Type'' Term Term)
a)
        ctel <- return $ mapModality updMod <$> ctel

        let bs = Tele (Dom (Type'' Term Term)) -> [Term] -> [Dom (Type'' Term Term)]
instTel Tele (Dom (Type'' Term Term))
ctel ((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)

        p <- expandLitPattern p
        case p of
          A.AsP{} -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
          A.ConP ConPatInfo
cpi AmbiguousQName
ambC [Arg (Named_ (Pattern' Expr))]
ps -> do
            (c',_) <- AmbiguousQName
-> QName -> [Arg Term] -> TCM (ConHead, Type'' Term Term)
disambiguateConstructor AmbiguousQName
ambC QName
d [Arg Term]
pars

            -- Issue #3014: If the constructor is forced but the user wrote a
            -- different constructor,that's an error. We simply keep the
            -- problem equation, this will result in a proper error message later.
            if conName c /= conName c' then return [eq] else do

            -- Insert implicit patterns
            ps <- insertImplicitPatterns ExpandLast ps ctel
            reportSDoc "tc.lhs.imp" 20 $
              "insertImplicitPatternsT returned" <+> fsep (map' prettyA ps)

            -- Check argument count and hiding (not just count: #3074)
            let checkArgs [] [] Int
_ Int
_ = () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                checkArgs (Arg (Named_ (Pattern' Expr))
p : [Arg (Named_ (Pattern' Expr))]
ps) (Arg Term
v : [Arg Term]
vs) Int
nExpected Int
nActual
                  | Arg (Named_ (Pattern' Expr)) -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg (Named_ (Pattern' Expr))
p Hiding -> Hiding -> Bool
forall a. Eq a => a -> a -> Bool
== Arg Term -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg Term
v = [Arg (Named_ (Pattern' Expr))]
-> [Arg Term] -> Int -> Int -> TCMT IO ()
checkArgs [Arg (Named_ (Pattern' Expr))]
ps [Arg Term]
vs (Int
nExpected Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) (Int
nActual Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
                  | Bool
otherwise                  = Arg (Named_ (Pattern' Expr)) -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Arg (Named_ (Pattern' Expr))
p (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
WrongHidingInLHS
                checkArgs [] [Arg Term]
vs Int
nExpected Int
nActual = TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
                  QName -> Int -> Int -> TypeError
WrongNumberOfConstructorArguments (ConHead -> QName
conName ConHead
c) (Int
nExpected Int -> Int -> Int
forall a. Num a => a -> a -> a
+ [Arg Term] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg Term]
vs) Int
nActual
                checkArgs (Arg (Named_ (Pattern' Expr))
p : [Arg (Named_ (Pattern' Expr))]
ps) [] Int
nExpected Int
nActual = Arg (Named_ (Pattern' Expr)) -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Arg (Named_ (Pattern' Expr))
p (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
                  QName -> Int -> Int -> TypeError
WrongNumberOfConstructorArguments (ConHead -> QName
conName ConHead
c) Int
nExpected (Int
nActual Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ ([Arg (Named_ (Pattern' Expr))] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Arg (Named_ (Pattern' Expr))]
ps))

            checkArgs ps vs 0 0

            updates $ zipWith3 ProblemEq (map' namedArg ps) (map' unArg vs) bs

          A.RecP KwRange
_ ConPatInfo
_ [FieldAssignment' (Pattern' Expr)]
fs -> do
            axs <- (Dom' Term QName -> Arg QName) -> [Dom' Term QName] -> [Arg QName]
forall a b. (a -> b) -> [a] -> [b]
map' Dom' Term QName -> Arg QName
forall t a. Dom' t a -> Arg a
argFromDom ([Dom' Term QName] -> [Arg QName])
-> (Definition -> [Dom' Term QName]) -> Definition -> [Arg QName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defn -> [Dom' Term QName]
recFields (Defn -> [Dom' Term QName])
-> (Definition -> Defn) -> Definition -> [Dom' Term QName]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Defn
theDef (Definition -> [Arg QName])
-> TCMT IO Definition -> TCMT IO [Arg QName]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
d

            -- Andreas, 2018-09-06, issue #3122.
            -- Associate the concrete record field names used in the record pattern
            -- to their counterpart in the record type definition.
            disambiguateRecordFields (map' _nameFieldA fs) (map' unArg axs)

            let cxs = (Arg QName -> Arg Name) -> [Arg QName] -> [Arg Name]
forall a b. (a -> b) -> [a] -> [b]
map' ((QName -> Name) -> Arg QName -> Arg Name
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Name
nameConcrete (Name -> Name) -> (QName -> Name) -> QName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName)) [Arg QName]
axs

            -- In fs omitted explicit fields are replaced by underscores,
            -- and the fields are put in the correct order.
            ps <- insertMissingFieldsFail ConORec d (const $ A.WildP empty) fs cxs

            -- We also need to insert missing implicit or instance fields.
            ps <- insertImplicitPatterns ExpandLast ps ctel

            let eqs = (Pattern' Expr -> Term -> Dom (Type'' Term Term) -> ProblemEq)
-> [Pattern' Expr]
-> [Term]
-> [Dom (Type'' Term Term)]
-> [ProblemEq]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Pattern' Expr -> Term -> Dom (Type'' Term Term) -> ProblemEq
ProblemEq ((Arg (Named_ (Pattern' Expr)) -> Pattern' Expr)
-> [Arg (Named_ (Pattern' Expr))] -> [Pattern' Expr]
forall a b. (a -> b) -> [a] -> [b]
map' Arg (Named_ (Pattern' Expr)) -> Pattern' Expr
forall a. NamedArg a -> a
namedArg [Arg (Named_ (Pattern' Expr))]
ps) ((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) [Dom (Type'' Term Term)]
bs
            updates eqs

          Pattern' Expr
_ -> [ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]

      Lit Literal
l | A.LitP PatInfo
_ Literal
l' <- Pattern' Expr
p , Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l' -> [ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

      Term
_ | A.EqualP{} <- Pattern' Expr
p -> do
        itisone <- TCMT IO Term -> TCMT IO Term
forall a. TCM a -> TCM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
        ifM (tryConversion $ equalTerm (unDom a) v itisone) (return []) (return [eq])

      Term
_ -> [ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]

    instTel :: Telescope -> [Term] -> [Dom Type]
    instTel :: Tele (Dom (Type'' Term Term)) -> [Term] -> [Dom (Type'' Term Term)]
instTel Tele (Dom (Type'' Term Term))
EmptyTel [Term]
_                   = []
    instTel (ExtendTel Dom (Type'' Term Term)
arg Abs (Tele (Dom (Type'' Term Term)))
tel) (Term
u : [Term]
us) = Dom (Type'' Term Term)
arg Dom (Type'' Term Term)
-> [Dom (Type'' Term Term)] -> [Dom (Type'' Term Term)]
forall a. a -> [a] -> [a]
: Tele (Dom (Type'' Term Term)) -> [Term] -> [Dom (Type'' Term Term)]
instTel (Abs (Tele (Dom (Type'' Term Term)))
-> SubstArg (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs (Tele (Dom (Type'' Term Term)))
tel Term
SubstArg (Tele (Dom (Type'' Term Term)))
u) [Term]
us
    instTel ExtendTel{} []               = [Dom (Type'' Term Term)]
forall a. HasCallStack => a
__IMPOSSIBLE__


-- | Check if a problem is solved.
--   That is, if the patterns are all variables,
--   and there is no 'problemRest'.
isSolvedProblem :: Problem a -> Bool
isSolvedProblem :: forall a. Problem a -> Bool
isSolvedProblem Problem a
problem = [Arg (Named_ (Pattern' Expr))] -> Bool
forall a. Null a => a -> Bool
null (Problem a
problem Problem a
-> Getting
     [Arg (Named_ (Pattern' Expr))]
     (Problem a)
     [Arg (Named_ (Pattern' Expr))]
-> [Arg (Named_ (Pattern' Expr))]
forall s a. s -> Getting a s a -> a
^. Getting
  [Arg (Named_ (Pattern' Expr))]
  (Problem a)
  [Arg (Named_ (Pattern' Expr))]
forall a (f :: * -> *).
Functor f =>
([Arg (Named_ (Pattern' Expr))]
 -> f [Arg (Named_ (Pattern' Expr))])
-> Problem a -> f (Problem a)
problemRestPats) Bool -> Bool -> Bool
&&
  Problem a -> Bool
forall a. Problem a -> Bool
problemAllVariables Problem a
problem

-- | Check if a problem consists only of variable patterns.
--   (Includes the 'problemRest').
problemAllVariables :: Problem a -> Bool
problemAllVariables :: forall a. Problem a -> Bool
problemAllVariables Problem a
problem =
    (Pattern' Expr -> Bool) -> [Pattern' Expr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pattern' Expr -> Bool
forall {e}. Pattern' e -> Bool
isSolved ([Pattern' Expr] -> Bool) -> [Pattern' Expr] -> Bool
forall a b. (a -> b) -> a -> b
$
      (Arg (Named_ (Pattern' Expr)) -> Pattern' Expr)
-> [Arg (Named_ (Pattern' Expr))] -> [Pattern' Expr]
forall a b. (a -> b) -> [a] -> [b]
map' Arg (Named_ (Pattern' Expr)) -> Pattern' Expr
forall a. NamedArg a -> a
namedArg (Problem a
problem Problem a
-> Getting
     [Arg (Named_ (Pattern' Expr))]
     (Problem a)
     [Arg (Named_ (Pattern' Expr))]
-> [Arg (Named_ (Pattern' Expr))]
forall s a. s -> Getting a s a -> a
^. Getting
  [Arg (Named_ (Pattern' Expr))]
  (Problem a)
  [Arg (Named_ (Pattern' Expr))]
forall a (f :: * -> *).
Functor f =>
([Arg (Named_ (Pattern' Expr))]
 -> f [Arg (Named_ (Pattern' Expr))])
-> Problem a -> f (Problem a)
problemRestPats) [Pattern' Expr] -> [Pattern' Expr] -> [Pattern' Expr]
forall a. [a] -> [a] -> [a]
++! Problem a -> [Pattern' Expr]
forall a. Problem a -> [Pattern' Expr]
problemInPats Problem a
problem
  where
    -- need further splitting:
    isSolved :: Pattern' e -> Bool
isSolved A.ConP{}        = Bool
False
    isSolved A.LitP{}        = Bool
False
    isSolved A.RecP{}        = Bool
False  -- record pattern
    -- solved:
    isSolved A.VarP{}        = Bool
True
    isSolved A.WildP{}       = Bool
True
    isSolved A.DotP{}        = Bool
True
    isSolved A.AbsurdP{}     = Bool
True
    -- recursive cases
    isSolved (A.AsP PatInfo
_ BindName
_ Pattern' e
p)   = Pattern' e -> Bool
isSolved Pattern' e
p
    -- impossible:
    isSolved A.ProjP{}       = Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
    isSolved A.DefP{}        = Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
    isSolved A.PatternSynP{} = Bool
forall a. HasCallStack => a
__IMPOSSIBLE__  -- expanded before
    isSolved A.EqualP{}      = Bool
False -- __IMPOSSIBLE__
    isSolved A.WithP{}       = Bool
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | For each user-defined pattern variable in the 'Problem', check
-- that the corresponding data type (if any) does not contain a
-- constructor of the same name (which is not in scope); this
-- \"shadowing\" could indicate an error, and is not allowed.
--
-- Precondition: The problem has to be solved.

noShadowingOfConstructors :: ProblemEq -> TCM ()
noShadowingOfConstructors :: ProblemEq -> TCMT IO ()
noShadowingOfConstructors problem :: ProblemEq
problem@(ProblemEq Pattern' Expr
p Term
_ dom :: Dom (Type'' Term Term)
dom@(Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> El Sort' Term
_ Term
a)) = do
  let info :: ArgInfo
info = Dom (Type'' Term Term)
dom Dom (Type'' Term Term)
-> Getting ArgInfo (Dom (Type'' Term Term)) ArgInfo -> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo
  case Pattern' Expr
p of
   A.WildP       {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   A.AbsurdP     {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   A.DotP        {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   A.EqualP      {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   A.AsP PatInfo
_ BindName
_ Pattern' Expr
p      -> ProblemEq -> TCMT IO ()
noShadowingOfConstructors (ProblemEq -> TCMT IO ()) -> ProblemEq -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ProblemEq
problem { problemInPat = p }
   A.ConP        {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
   A.RecP        {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
   A.ProjP       {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
   A.DefP        {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
   A.LitP        {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
   A.PatternSynP {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
   A.WithP       {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
   -- Andreas, 2017-12-01, issue #2859.
   -- Due to parameter refinement, there can be (invisible) variable patterns from module
   -- parameters that shadow constructors.
   -- Thus, only complain about user written variable that shadow constructors.
   A.VarP A.BindName{unBind :: BindName -> Name
unBind = Name
x} -> Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
when (ArgInfo -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin ArgInfo
info Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
UserWritten) (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.lhs.shadow" Int
30 (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
      [ [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]
"checking whether pattern variable " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! [Char]
" shadows a constructor"
      , 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
"type of variable =" 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
a
      , 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
"position of variable =" 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)
-> (Range' SrcFile -> [Char]) -> Range' SrcFile -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range' SrcFile -> [Char]
forall a. Show a => a -> [Char]
show) (Name -> Range' SrcFile
forall a. HasRange a => a -> Range' SrcFile
getRange Name
x)
      ]
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.shadow" Int
70 (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
"a =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
a

    -- Get a conflicting data or record constructor, if any.
    mc <- MaybeT (TCMT IO) QName -> TCMT IO (Maybe QName)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do

      -- Is the type of the pattern variable a data or pattern record type?
      a  <- TCMT IO Term -> MaybeT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO Term -> MaybeT (TCMT IO) Term)
-> TCMT IO Term -> MaybeT (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
a
      (d, dr) <- MaybeT $ isDataOrRecord a
      guard $ patternMatchingAllowed dr

      -- Look for a constructor with the same name as the pattern variable.
      cs <- lift $ getConstructors d
      MaybeT $ pure $ List.find ((A.nameConcrete x ==) . A.nameConcrete . A.qnameName) cs

    -- Alert if there is a constructor of the same name.
    whenJust mc \ QName
c -> Name -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Name
x (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
$ Name -> QName -> Warning
PatternShadowsConstructor (Name -> Name
nameConcrete Name
x) QName
c
    --
    -- Andreas, 2023-09-08, issue #6829:
    -- I rewrote the code originally dating from 2009, commit:
    -- https://github.com/agda/agda/commit/5d5095ba080b04f16867d4ed5af4ba7091f1a773
    -- The code survived for almost 15 years, but it slept through the advent
    -- of matchable record constructors in 2010 (Agda 2.2.8):
    -- https://github.com/agda/agda/blob/283730b392d7c21c54b53b0f486802ec143e4af7/doc/release-notes/2.2.8.md#L7-L9
    -- Here are comments on the last version of the code I'd like to preserve,
    -- as they reflect some considerations and design decisions:
    --
            -- Abstract constructors cannot be brought into scope,
            -- even by a bigger import list.
            -- Thus, they cannot be confused with variables.
            -- Alternatively, we could do getConstInfo in ignoreAbstractMode,
            -- then Agda would complain if a variable shadowed an abstract constructor.
          -- TODO: in the future some stuck primitives might allow constructors
      -- TODO: If the type is a meta-variable, should the test be
      -- postponed? If there is a problem, then it will be caught when
      -- the completed module is type checked, so it is safe to skip
      -- the test here. However, users may be annoyed if they get an
      -- error in code which has already passed the type checker.

-- | Check that a dot pattern matches it's instantiation.
checkDotPattern :: DotPattern -> TCM ()
checkDotPattern :: DotPattern -> TCMT IO ()
checkDotPattern (Dot Expr
e Term
v dom :: Dom (Type'' Term Term)
dom@(Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> Type'' Term Term
a)) =
  Call -> TCMT IO () -> TCMT IO ()
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Expr -> Term -> Call
CheckDotPattern Expr
e Term
v) (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.lhs.dot" Int
15 (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
"checking dot 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
$ Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Expr
e
        , 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 -> 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
v
        , 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 -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
a
        ]
  Dom (Type'' Term Term) -> TCMT IO () -> TCMT IO ()
forall e a. Dom e -> TCM a -> TCM a
applyDomToContext Dom (Type'' Term Term)
dom (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    u <- Expr -> Type'' Term Term -> TCMT IO Term
checkExpr Expr
e Type'' Term Term
a
    reportSDoc "tc.lhs.dot" 50 $
      sep [ "equalTerm"
          , nest 2 $ pretty a
          , nest 2 $ pretty u
          , nest 2 $ pretty v
          ]
    equalTerm a u v

checkAbsurdPattern :: AbsurdPattern -> TCM ()
checkAbsurdPattern :: AbsurdPattern -> TCMT IO ()
checkAbsurdPattern (Absurd Range' SrcFile
r Type'' Term Term
a) = Range' SrcFile -> Type'' Term Term -> TCMT IO ()
ensureEmptyType Range' SrcFile
r Type'' Term Term
a

checkAnnotationPattern :: AnnotationPattern -> TCM ()
checkAnnotationPattern :: AnnotationPattern -> TCMT IO ()
checkAnnotationPattern (Ann Expr
t Type'' Term Term
a) = do
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.ann" Int
15 (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
"checking type annotation in 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
$ Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Expr
t
        , 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 -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
a
        ]
  b <- Expr -> TCMT IO (Type'' Term Term)
isType_ Expr
t
  equalType a b

-- | After splitting is complete, we transfer the origins
--   We also transfer the locations of absurd patterns, since these haven't
--   been introduced yet in the internal pattern.
transferOrigins :: [NamedArg A.Pattern]
                -> [NamedArg DeBruijnPattern]
                -> TCM [NamedArg DeBruijnPattern]
transferOrigins :: [Arg (Named_ (Pattern' Expr))]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transferOrigins [Arg (Named_ (Pattern' Expr))]
ps [NamedArg DeBruijnPattern]
qs = do
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.origin" 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
"transferOrigins"
    , 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
<+> [Arg (Named_ (Pattern' Expr))] -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA [Arg (Named_ (Pattern' Expr))]
ps
      , TCMT IO Doc
"qs  =   " 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]
qs
      ]
    ]
  [Arg (Named_ (Pattern' Expr))]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [Arg (Named_ (Pattern' Expr))]
ps [NamedArg DeBruijnPattern]
qs

  where
    transfers :: [NamedArg A.Pattern]
              -> [NamedArg DeBruijnPattern]
              -> TCM [NamedArg DeBruijnPattern]
    transfers :: [Arg (Named_ (Pattern' Expr))]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [] [NamedArg DeBruijnPattern]
qs
      | (NamedArg DeBruijnPattern -> Bool)
-> [NamedArg DeBruijnPattern] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NamedArg DeBruijnPattern -> Bool
forall a. LensHiding a => a -> Bool
notVisible [NamedArg DeBruijnPattern]
qs = [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ (NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern)
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> [a] -> [b]
map' (Origin -> NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted) [NamedArg DeBruijnPattern]
qs
      | Bool
otherwise         = TCM [NamedArg DeBruijnPattern]
forall a. HasCallStack => a
__IMPOSSIBLE__
    transfers (Arg (Named_ (Pattern' Expr))
p : [Arg (Named_ (Pattern' Expr))]
ps) [] = TCM [NamedArg DeBruijnPattern]
forall a. HasCallStack => a
__IMPOSSIBLE__
    transfers (Arg (Named_ (Pattern' Expr))
p : [Arg (Named_ (Pattern' Expr))]
ps) (NamedArg DeBruijnPattern
q : [NamedArg DeBruijnPattern]
qs)
      | Arg (Named_ (Pattern' Expr)) -> NamedArg DeBruijnPattern -> Bool
matchingArgs Arg (Named_ (Pattern' Expr))
p NamedArg DeBruijnPattern
q = do
          q' <- (Maybe (NameOf (NamedArg DeBruijnPattern))
 -> Maybe (NameOf (NamedArg DeBruijnPattern)))
-> NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern
forall a.
LensNamed a =>
(Maybe (NameOf a) -> Maybe (NameOf a)) -> a -> a
mapNameOf ((Maybe (NameOf (NamedArg DeBruijnPattern))
 -> Maybe (NameOf (NamedArg DeBruijnPattern)))
-> (NamedName
    -> Maybe (NameOf (NamedArg DeBruijnPattern))
    -> Maybe (NameOf (NamedArg DeBruijnPattern)))
-> Maybe NamedName
-> Maybe (NameOf (NamedArg DeBruijnPattern))
-> Maybe (NameOf (NamedArg DeBruijnPattern))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (NameOf (NamedArg DeBruijnPattern))
-> Maybe (NameOf (NamedArg DeBruijnPattern))
Maybe NamedName -> Maybe NamedName
forall a. a -> a
id (Maybe NamedName -> Maybe NamedName -> Maybe NamedName
forall a b. a -> b -> a
const (Maybe NamedName -> Maybe NamedName -> Maybe NamedName)
-> (NamedName -> Maybe NamedName)
-> NamedName
-> Maybe NamedName
-> Maybe NamedName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedName -> Maybe NamedName
forall a. a -> Maybe a
Just) (Maybe NamedName
 -> Maybe (NameOf (NamedArg DeBruijnPattern))
 -> Maybe (NameOf (NamedArg DeBruijnPattern)))
-> Maybe NamedName
-> Maybe (NameOf (NamedArg DeBruijnPattern))
-> Maybe (NameOf (NamedArg DeBruijnPattern))
forall a b. (a -> b) -> a -> b
$ Arg (Named_ (Pattern' Expr))
-> Maybe (NameOf (Arg (Named_ (Pattern' Expr))))
forall a. LensNamed a => a -> Maybe (NameOf a)
getNameOf Arg (Named_ (Pattern' Expr))
p) -- take NamedName from p if present
              (NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern)
-> (NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern)
-> NamedArg DeBruijnPattern
-> NamedArg DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Origin -> NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern
forall a. LensOrigin a => Origin -> a -> a
setOrigin (Arg (Named_ (Pattern' Expr)) -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin Arg (Named_ (Pattern' Expr))
p)
            (NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern)
-> TCMT IO (NamedArg DeBruijnPattern)
-> TCMT IO (NamedArg DeBruijnPattern)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ((Named NamedName DeBruijnPattern
 -> TCMT IO (Named NamedName DeBruijnPattern))
-> NamedArg DeBruijnPattern -> TCMT IO (NamedArg DeBruijnPattern)
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 ((Named NamedName DeBruijnPattern
  -> TCMT IO (Named NamedName DeBruijnPattern))
 -> NamedArg DeBruijnPattern -> TCMT IO (NamedArg DeBruijnPattern))
-> (Named NamedName DeBruijnPattern
    -> TCMT IO (Named NamedName DeBruijnPattern))
-> NamedArg DeBruijnPattern
-> TCMT IO (NamedArg DeBruijnPattern)
forall a b. (a -> b) -> a -> b
$ (DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> Named NamedName DeBruijnPattern
-> TCMT IO (Named NamedName DeBruijnPattern)
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) -> Named NamedName a -> f (Named NamedName b)
traverse ((DeBruijnPattern -> TCMT IO DeBruijnPattern)
 -> Named NamedName DeBruijnPattern
 -> TCMT IO (Named NamedName DeBruijnPattern))
-> (DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> Named NamedName DeBruijnPattern
-> TCMT IO (Named NamedName DeBruijnPattern)
forall a b. (a -> b) -> a -> b
$ Pattern' Expr -> DeBruijnPattern -> TCMT IO DeBruijnPattern
transfer (Pattern' Expr -> DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> Pattern' Expr -> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ Arg (Named_ (Pattern' Expr)) -> Pattern' Expr
forall a. NamedArg a -> a
namedArg Arg (Named_ (Pattern' Expr))
p) NamedArg DeBruijnPattern
q
          (q' :) <$> transfers ps qs
      | Bool
otherwise = (Origin -> NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted NamedArg DeBruijnPattern
q NamedArg DeBruijnPattern
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. a -> [a] -> [a]
:) ([NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern])
-> TCM [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Arg (Named_ (Pattern' Expr))]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers (Arg (Named_ (Pattern' Expr))
p Arg (Named_ (Pattern' Expr))
-> [Arg (Named_ (Pattern' Expr))] -> [Arg (Named_ (Pattern' Expr))]
forall a. a -> [a] -> [a]
: [Arg (Named_ (Pattern' Expr))]
ps) [NamedArg DeBruijnPattern]
qs

    transfer :: A.Pattern -> DeBruijnPattern -> TCM DeBruijnPattern
    transfer :: Pattern' Expr -> DeBruijnPattern -> TCMT IO DeBruijnPattern
transfer Pattern' Expr
p DeBruijnPattern
q = case (Pattern' Expr -> ([Name], Pattern' Expr)
asView Pattern' Expr
p , DeBruijnPattern
q) of

      (([Name]
asB , A.ConP ConPatInfo
pi AmbiguousQName
_ [Arg (Named_ (Pattern' Expr))]
ps) , ConP ConHead
c (ConPatternInfo PatternInfo
i Bool
r Bool
ft Maybe (Arg (Type'' Term Term))
mb Bool
l) [NamedArg DeBruijnPattern]
qs) -> do
        let cpi :: ConPatternInfo
cpi = PatternInfo
-> Bool
-> Bool
-> Maybe (Arg (Type'' Term Term))
-> Bool
-> ConPatternInfo
ConPatternInfo (PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatOCon [Name]
asB) Bool
r Bool
ft Maybe (Arg (Type'' Term Term))
mb Bool
l
        ConHead
-> ConPatternInfo -> [NamedArg DeBruijnPattern] -> DeBruijnPattern
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c ConPatternInfo
cpi ([NamedArg DeBruijnPattern] -> DeBruijnPattern)
-> TCM [NamedArg DeBruijnPattern] -> TCMT IO DeBruijnPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Arg (Named_ (Pattern' Expr))]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [Arg (Named_ (Pattern' Expr))]
ps [NamedArg DeBruijnPattern]
qs

      (([Name]
asB , A.RecP KwRange
_kwr ConPatInfo
pi [FieldAssignment' (Pattern' Expr)]
fs) , ConP ConHead
c (ConPatternInfo PatternInfo
i Bool
r Bool
ft Maybe (Arg (Type'' Term Term))
mb Bool
l) [NamedArg DeBruijnPattern]
qs) -> do
        let Def QName
d Elims
_  = Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl (Type'' Term Term -> Term) -> Type'' Term Term -> Term
forall a b. (a -> b) -> a -> b
$ Arg (Type'' Term Term) -> Type'' Term Term
forall e. Arg e -> e
unArg (Arg (Type'' Term Term) -> Type'' Term Term)
-> Arg (Type'' Term Term) -> Type'' Term Term
forall a b. (a -> b) -> a -> b
$ Arg (Type'' Term Term)
-> Maybe (Arg (Type'' Term Term)) -> Arg (Type'' Term Term)
forall a. a -> Maybe a -> a
fromMaybe Arg (Type'' Term Term)
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg (Type'' Term Term))
mb
            axs :: [Arg Name]
axs = (Arg QName -> Name) -> [Arg QName] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map' (Name -> Name
nameConcrete (Name -> Name) -> (Arg QName -> Name) -> Arg QName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName (QName -> Name) -> (Arg QName -> QName) -> Arg QName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg QName -> QName
forall e. Arg e -> e
unArg) (ConHead -> [Arg QName]
conFields ConHead
c) [Name] -> [NamedArg DeBruijnPattern] -> [Arg Name]
forall a b. [a] -> [Arg b] -> [Arg a]
`withArgsFrom` [NamedArg DeBruijnPattern]
qs
            cpi :: ConPatternInfo
cpi = PatternInfo
-> Bool
-> Bool
-> Maybe (Arg (Type'' Term Term))
-> Bool
-> ConPatternInfo
ConPatternInfo (PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatORec [Name]
asB) Bool
r Bool
ft Maybe (Arg (Type'' Term Term))
mb Bool
l
        ps <- ConInfo
-> QName
-> (Name -> Pattern' Expr)
-> [FieldAssignment' (Pattern' Expr)]
-> [Arg Name]
-> TCMT IO [Arg (Named_ (Pattern' Expr))]
forall a.
HasRange a =>
ConInfo
-> QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFieldsFail ConInfo
ConORec QName
d (Pattern' Expr -> Name -> Pattern' Expr
forall a b. a -> b -> a
const (Pattern' Expr -> Name -> Pattern' Expr)
-> Pattern' Expr -> Name -> Pattern' Expr
forall a b. (a -> b) -> a -> b
$ PatInfo -> Pattern' Expr
forall e. PatInfo -> Pattern' e
A.WildP PatInfo
forall a. Null a => a
empty) [FieldAssignment' (Pattern' Expr)]
fs [Arg Name]
axs
        ConP c cpi <$> transfers ps qs

      (([Name]
asB , Pattern' Expr
p) , ConP ConHead
c (ConPatternInfo PatternInfo
i Bool
r Bool
ft Maybe (Arg (Type'' Term Term))
mb Bool
l) [NamedArg DeBruijnPattern]
qs) -> do
        let cpi :: ConPatternInfo
cpi = PatternInfo
-> Bool
-> Bool
-> Maybe (Arg (Type'' Term Term))
-> Bool
-> ConPatternInfo
ConPatternInfo (PatOrigin -> [Name] -> PatternInfo
PatternInfo (Pattern' Expr -> PatOrigin
patOrig Pattern' Expr
p) [Name]
asB) Bool
r Bool
ft Maybe (Arg (Type'' Term Term))
mb Bool
l
        DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ ConHead
-> ConPatternInfo -> [NamedArg DeBruijnPattern] -> DeBruijnPattern
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c ConPatternInfo
cpi [NamedArg DeBruijnPattern]
qs

      (([Name]
asB , Pattern' Expr
p) , VarP PatternInfo
_ DBPatVar
x) -> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a b. (a -> b) -> a -> b
$! PatternInfo -> DBPatVar -> DeBruijnPattern
forall x. PatternInfo -> x -> Pattern' x
VarP (PatOrigin -> [Name] -> PatternInfo
PatternInfo (Pattern' Expr -> PatOrigin
patOrig Pattern' Expr
p) [Name]
asB) DBPatVar
x

      (([Name]
asB , Pattern' Expr
p) , DotP PatternInfo
_ Term
u) -> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a b. (a -> b) -> a -> b
$! PatternInfo -> Term -> DeBruijnPattern
forall x. PatternInfo -> Term -> Pattern' x
DotP (PatOrigin -> [Name] -> PatternInfo
PatternInfo (Pattern' Expr -> PatOrigin
patOrig Pattern' Expr
p) [Name]
asB) Term
u

      (([Name]
asB , Pattern' Expr
p) , LitP PatternInfo
_ Literal
l) -> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a b. (a -> b) -> a -> b
$! PatternInfo -> Literal -> DeBruijnPattern
forall x. PatternInfo -> Literal -> Pattern' x
LitP (PatOrigin -> [Name] -> PatternInfo
PatternInfo (Pattern' Expr -> PatOrigin
patOrig Pattern' Expr
p) [Name]
asB) Literal
l

      (([Name], Pattern' Expr), DeBruijnPattern)
_ -> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return DeBruijnPattern
q

    patOrig :: A.Pattern -> PatOrigin
    patOrig :: Pattern' Expr -> PatOrigin
patOrig (A.VarP BindName
x)      = Name -> PatOrigin
PatOVar (BindName -> Name
A.unBind BindName
x)
    patOrig A.DotP{}        = PatOrigin
PatODot
    patOrig A.ConP{}        = PatOrigin
PatOCon
    patOrig A.RecP{}        = PatOrigin
PatORec
    patOrig A.WildP{}       = PatOrigin
PatOWild
    patOrig A.AbsurdP{}     = PatOrigin
PatOAbsurd
    patOrig A.LitP{}        = PatOrigin
PatOLit
    patOrig A.EqualP{}      = PatOrigin
PatOCon --TODO: origin for EqualP
    patOrig A.AsP{}         = PatOrigin
forall a. HasCallStack => a
__IMPOSSIBLE__
    patOrig A.ProjP{}       = PatOrigin
forall a. HasCallStack => a
__IMPOSSIBLE__
    patOrig A.DefP{}        = PatOrigin
forall a. HasCallStack => a
__IMPOSSIBLE__
    patOrig A.PatternSynP{} = PatOrigin
forall a. HasCallStack => a
__IMPOSSIBLE__
    patOrig A.WithP{}       = PatOrigin
forall a. HasCallStack => a
__IMPOSSIBLE__

    matchingArgs :: NamedArg A.Pattern -> NamedArg DeBruijnPattern -> Bool
    matchingArgs :: Arg (Named_ (Pattern' Expr)) -> NamedArg DeBruijnPattern -> Bool
matchingArgs Arg (Named_ (Pattern' Expr))
p NamedArg DeBruijnPattern
q
      -- The arguments match if
      -- 1. they are both projections,
      | Maybe (ProjOrigin, AmbiguousQName) -> Bool
forall a. Maybe a -> Bool
isJust (Arg (Named_ (Pattern' Expr)) -> Maybe (ProjOrigin, AmbiguousQName)
forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
A.isProjP Arg (Named_ (Pattern' Expr))
p) = Maybe (ProjOrigin, AmbiguousQName) -> Bool
forall a. Maybe a -> Bool
isJust (NamedArg DeBruijnPattern -> Maybe (ProjOrigin, AmbiguousQName)
forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
isProjP NamedArg DeBruijnPattern
q)
      -- 2. or they are both visible,
      | Arg (Named_ (Pattern' Expr)) -> Bool
forall a. LensHiding a => a -> Bool
visible Arg (Named_ (Pattern' Expr))
p Bool -> Bool -> Bool
&& NamedArg DeBruijnPattern -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg DeBruijnPattern
q = Bool
True
      -- 3. or they have the same hiding and the argument is not named,
      | Arg (Named_ (Pattern' Expr)) -> NamedArg DeBruijnPattern -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding Arg (Named_ (Pattern' Expr))
p NamedArg DeBruijnPattern
q Bool -> Bool -> Bool
&& Maybe NamedName -> Bool
forall a. Maybe a -> Bool
isNothing (Arg (Named_ (Pattern' Expr))
-> Maybe (NameOf (Arg (Named_ (Pattern' Expr))))
forall a. LensNamed a => a -> Maybe (NameOf a)
getNameOf Arg (Named_ (Pattern' Expr))
p) = Bool
True
      -- 4. or they have the same hiding and the same name.
      | Arg (Named_ (Pattern' Expr)) -> NamedArg DeBruijnPattern -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding Arg (Named_ (Pattern' Expr))
p NamedArg DeBruijnPattern
q Bool -> Bool -> Bool
&& Arg (Named_ (Pattern' Expr)) -> NamedArg DeBruijnPattern -> Bool
forall a b.
(LensNamed a, LensNamed b, NameOf a ~ NamedName,
 NameOf b ~ NamedName) =>
a -> b -> Bool
namedSame Arg (Named_ (Pattern' Expr))
p NamedArg DeBruijnPattern
q = Bool
True
      -- Otherwise this argument was inserted by the typechecker.
      | Bool
otherwise = Bool
False


-- | If a user-written variable occurs more than once, it should be bound
--   to the same internal variable (or term) in all positions.
--   Returns the list of patterns with the duplicate user patterns removed.
checkPatternLinearity :: [ProblemEq] -> TCM [ProblemEq]
checkPatternLinearity :: [ProblemEq] -> TCMT IO [ProblemEq]
checkPatternLinearity [ProblemEq]
eqs = do
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.linear" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Checking linearity of pattern variables"
  Map BindName (Term, Type'' Term Term)
-> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type'' Term Term)
forall k a. Map k a
Map.empty [ProblemEq]
eqs
  where
    check :: Map A.BindName (Term, Type) -> [ProblemEq] -> TCM [ProblemEq]
    check :: Map BindName (Term, Type'' Term Term)
-> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type'' Term Term)
_ [] = [ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    check Map BindName (Term, Type'' Term Term)
vars (eq :: ProblemEq
eq@(ProblemEq Pattern' Expr
p Term
u Dom (Type'' Term Term)
a) : [ProblemEq]
eqs) = do
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.linear" 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
sep
        [ TCMT IO Doc
"linearity: checking pattern "
        , Pattern' Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern' Expr
p
        , TCMT IO Doc
" equal to term "
        , Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
u
        , TCMT IO Doc
" of type "
        , Dom (Type'' Term Term) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Dom (Type'' Term Term) -> m Doc
prettyTCM Dom (Type'' Term Term)
a
        ]
      case Pattern' Expr
p of
        A.VarP BindName
x -> do
          let y :: Name
y = BindName -> Name
A.unBind BindName
x
          [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.lhs.linear" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
            [Char]
"pattern variable " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Name -> Name
A.nameConcrete Name
y) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! [Char]
" with id " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! NameId -> [Char]
forall a. Show a => a -> [Char]
show (Name -> NameId
forall a. HasNameId a => a -> NameId
A.nameId Name
y)
          case BindName
-> Map BindName (Term, Type'' Term Term)
-> Maybe (Term, Type'' Term Term)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BindName
x Map BindName (Term, Type'' Term Term)
vars of
            Just (Term
v , Type'' Term Term
b) -> do
              Call -> TCMT IO () -> TCMT IO ()
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Name -> Call
CheckPatternLinearityType (Name -> Call) -> Name -> Call
forall a b. (a -> b) -> a -> b
$ Name -> Name
A.nameConcrete Name
y) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
                TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) =>
m a -> m a
noConstraints (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Type'' Term Term -> Type'' Term Term -> TCMT IO ()
equalType (Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom Dom (Type'' Term Term)
a) Type'' Term Term
b
              Call -> TCMT IO () -> TCMT IO ()
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Name -> Call
CheckPatternLinearityValue (Name -> Call) -> Name -> Call
forall a b. (a -> b) -> a -> b
$ Name -> Name
A.nameConcrete Name
y) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
                TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(MonadConstraint m, MonadWarning m, MonadFresh ProblemId m) =>
m a -> m a
noConstraints (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Type'' Term Term -> Term -> Term -> TCMT IO ()
equalTerm (Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom Dom (Type'' Term Term)
a) Term
u Term
v
              Map BindName (Term, Type'' Term Term)
-> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type'' Term Term)
vars [ProblemEq]
eqs
            Maybe (Term, Type'' Term Term)
Nothing -> (ProblemEq
eqProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              Map BindName (Term, Type'' Term Term)
-> [ProblemEq] -> TCMT IO [ProblemEq]
check (BindName
-> (Term, Type'' Term Term)
-> Map BindName (Term, Type'' Term Term)
-> Map BindName (Term, Type'' Term Term)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BindName
x (Term
u,Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom Dom (Type'' Term Term)
a) Map BindName (Term, Type'' Term Term)
vars) [ProblemEq]
eqs
        A.AsP PatInfo
_ BindName
x Pattern' Expr
p ->
          Map BindName (Term, Type'' Term Term)
-> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type'' Term Term)
vars ([ProblemEq] -> TCMT IO [ProblemEq])
-> [ProblemEq] -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ [Pattern' Expr -> Term -> Dom (Type'' Term Term) -> ProblemEq
ProblemEq (BindName -> Pattern' Expr
forall e. BindName -> Pattern' e
A.VarP BindName
x) Term
u Dom (Type'' Term Term)
a, Pattern' Expr -> Term -> Dom (Type'' Term Term) -> ProblemEq
ProblemEq Pattern' Expr
p Term
u Dom (Type'' Term Term)
a] [ProblemEq] -> [ProblemEq] -> [ProblemEq]
forall a. [a] -> [a] -> [a]
++! [ProblemEq]
eqs
        A.WildP{}       -> TCMT IO [ProblemEq]
continue
        A.DotP{}        -> TCMT IO [ProblemEq]
continue
        A.AbsurdP{}     -> TCMT IO [ProblemEq]
continue
        A.ConP{}        -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.ProjP{}       -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.DefP{}        -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.LitP{}        -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.PatternSynP{} -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.RecP{}        -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.EqualP{}      -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.WithP{}       -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__

      where continue :: TCMT IO [ProblemEq]
continue = (ProblemEq
eqProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map BindName (Term, Type'' Term Term)
-> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type'' Term Term)
vars [ProblemEq]
eqs

-- | Construct the context for a left hand side, making up out-of-scope names
--   for unnamed variables.
computeLHSContext :: [Maybe A.Name] -> Telescope -> TCM Context
computeLHSContext :: [Maybe Name] -> Tele (Dom (Type'' Term Term)) -> TCM Context
computeLHSContext = Context
-> [Name]
-> [Maybe Name]
-> Tele (Dom (Type'' Term Term))
-> TCM Context
forall {m :: * -> *}.
(MonadDebug m, MonadFresh NameId m) =>
Context
-> [Name]
-> [Maybe Name]
-> Tele (Dom (Type'' Term Term))
-> m Context
go Context
CxEmpty []
  where
    go :: Context
-> [Name]
-> [Maybe Name]
-> Tele (Dom (Type'' Term Term))
-> m Context
go Context
cxt [Name]
_ []        tel :: Tele (Dom (Type'' Term Term))
tel@ExtendTel{} = do
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"impossible" Int
10 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"computeLHSContext: no patterns left, but tel =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
tel
      m Context
forall a. HasCallStack => a
__IMPOSSIBLE__
    go Context
cxt [Name]
_ (Maybe Name
_ : [Maybe Name]
_)   Tele (Dom (Type'' Term Term))
EmptyTel = m Context
forall a. HasCallStack => a
__IMPOSSIBLE__
    go Context
cxt [Name]
_ []        Tele (Dom (Type'' Term Term))
EmptyTel = Context -> m Context
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Context
cxt
    go Context
cxt [Name]
taken (Maybe Name
x : [Maybe Name]
xs) tel0 :: Tele (Dom (Type'' Term Term))
tel0@(ExtendTel Dom (Type'' Term Term)
a Abs (Tele (Dom (Type'' Term Term)))
tel) = do
        name <- m Name -> (Name -> m Name) -> Maybe Name -> m Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Name] -> [Char] -> m Name
forall {m :: * -> *} {p}.
MonadFresh NameId m =>
p -> [Char] -> m Name
dummyName [Name]
taken ([Char] -> m Name) -> [Char] -> m Name
forall a b. (a -> b) -> a -> b
$ Abs (Tele (Dom (Type'' Term Term))) -> [Char]
forall a. Abs a -> [Char]
absName Abs (Tele (Dom (Type'' Term Term)))
tel) Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
x
        go (CxExtendVar name a cxt) (name : taken) xs (absBody tel)

    dummyName :: p -> [Char] -> m Name
dummyName p
taken [Char]
s =
      if [Char] -> Bool
forall a. Underscore a => a -> Bool
isUnderscore [Char]
s then m Name
forall (m :: * -> *). MonadFresh NameId m => m Name
freshNoName_
      else Name -> Name
forall a. LensInScope a => a -> a
setNotInScope (Name -> Name) -> m Name -> m Name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [Char] -> m Name
forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
forall (m :: * -> *). MonadFresh NameId m => [Char] -> m Name
freshName_ ([Char] -> [Char]
argNameToString [Char]
s)

-- | Bind as patterns
bindAsPatterns :: [AsBinding] -> TCM a -> TCM a
bindAsPatterns :: forall a. [AsBinding] -> TCM a -> TCM a
bindAsPatterns []                TCM a
ret = TCM a
ret
bindAsPatterns (AsB Name
x Term
v Dom (Type'' Term Term)
a : [AsBinding]
asb) TCM a
ret = do
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.as" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"as pattern" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Name -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Name -> m Doc
prettyTCM Name
x TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
":" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Dom (Type'' Term Term) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Dom (Type'' Term Term) -> m Doc
prettyTCM Dom (Type'' Term Term)
a
        , TCMT IO Doc
"=" 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
v
        ]
  IsAxiom
-> Origin
-> Name
-> Term
-> Dom (Type'' Term Term)
-> TCM a
-> TCM a
forall a.
IsAxiom
-> Origin
-> Name
-> Term
-> Dom (Type'' Term Term)
-> TCMT IO a
-> TCMT IO a
forall (m :: * -> *) a.
MonadAddContext m =>
IsAxiom
-> Origin -> Name -> Term -> Dom (Type'' Term Term) -> m a -> m a
addLetBinding' IsAxiom
NoAxiom Origin
Inserted Name
x Term
v Dom (Type'' Term Term)
a (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$ [AsBinding] -> TCM a -> TCM a
forall a. [AsBinding] -> TCM a -> TCM a
bindAsPatterns [AsBinding]
asb TCM a
ret

-- | Since with-abstraction can change the type of a variable, we have to
--   recheck the stripped with patterns when checking a with function.
recheckStrippedWithPattern :: ProblemEq -> TCM ()
recheckStrippedWithPattern :: ProblemEq -> TCMT IO ()
recheckStrippedWithPattern (ProblemEq Pattern' Expr
p Term
v Dom (Type'' Term Term)
a)
  | A.WildP{} <- Pattern' Expr
p = () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  | Bool
otherwise      = Term -> Comparison -> TypeOf Term -> TCMT IO ()
forall a.
CheckInternal a =>
a -> Comparison -> TypeOf a -> TCMT IO ()
checkInternal Term
v Comparison
CmpLeq (Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom Dom (Type'' Term Term)
a)
      TCMT IO () -> (TCErr -> TCMT IO ()) -> TCMT IO ()
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
_ -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Pattern' Expr -> TypeError
IllTypedPatternAfterWithAbstraction Pattern' Expr
p

-- | Result of checking the LHS of a clause.
data LHSResult = LHSResult
  { LHSResult -> Int
lhsParameters   :: Nat
    -- ^ The number of original module parameters. These are present in the
    -- the patterns.
  , LHSResult -> Tele (Dom (Type'' Term Term))
lhsVarTele      :: Telescope
    -- ^ Δ : The types of the pattern variables, in internal dependency order.
    -- Corresponds to 'clauseTel'.
    -- Like the other components (e.g. `lhsBodyType`), this telescope lives
    -- in the ambient context.
    -- To print it, we need /not/ drop Δ from the ambient context.
  , LHSResult -> [NamedArg DeBruijnPattern]
lhsPatterns     :: [NamedArg DeBruijnPattern]
    -- ^ The patterns in internal syntax.
  , LHSResult -> Bool
lhsHasAbsurd    :: Bool
    -- ^ Whether the LHS has at least one absurd pattern.
  , LHSResult -> Arg (Type'' Term Term)
lhsBodyType     :: Arg Type
    -- ^ The type of the body. Is @bσ@ if @Γ@ is defined.
    -- 'Irrelevant' to indicate the rhs must be checked in irrelevant mode.
  , LHSResult -> Substitution
lhsPatSubst     :: Substitution
    -- ^ Substitution version of @lhsPatterns@, only up to the first projection
    -- pattern. @Δ |- lhsPatSubst : Γ@. Where @Γ@ is the argument telescope of
    -- the function. This is used to update inherited dot patterns in
    -- with-function clauses.
  , LHSResult -> [AsBinding]
lhsAsBindings   :: [AsBinding]
    -- ^ As-bindings from the left-hand side. Return instead of bound since we
    -- want them in where's and right-hand sides, but not in with-clauses
    -- (Issue 2303).
  , LHSResult -> IntSet
lhsPartialSplit :: IntSet
    -- ^ have we done a partial split?
  , LHSResult -> Bool
lhsIndexedSplit :: Bool
    -- ^ have we split on an indexed type?
  }

instance InstantiateFull LHSResult where
  instantiateFull' :: LHSResult -> ReduceM LHSResult
instantiateFull' (LHSResult Int
n Tele (Dom (Type'' Term Term))
tel [NamedArg DeBruijnPattern]
ps Bool
abs Arg (Type'' Term Term)
t Substitution
sub [AsBinding]
as IntSet
psplit Bool
ixsplit) = Int
-> Tele (Dom (Type'' Term Term))
-> [NamedArg DeBruijnPattern]
-> Bool
-> Arg (Type'' Term Term)
-> Substitution
-> [AsBinding]
-> IntSet
-> Bool
-> LHSResult
LHSResult Int
n
    (Tele (Dom (Type'' Term Term))
 -> [NamedArg DeBruijnPattern]
 -> Bool
 -> Arg (Type'' Term Term)
 -> Substitution
 -> [AsBinding]
 -> IntSet
 -> Bool
 -> LHSResult)
-> ReduceM (Tele (Dom (Type'' Term Term)))
-> ReduceM
     ([NamedArg DeBruijnPattern]
      -> Bool
      -> Arg (Type'' Term Term)
      -> Substitution
      -> [AsBinding]
      -> IntSet
      -> Bool
      -> LHSResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tele (Dom (Type'' Term Term))
-> ReduceM (Tele (Dom (Type'' Term Term)))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Tele (Dom (Type'' Term Term))
tel
    ReduceM
  ([NamedArg DeBruijnPattern]
   -> Bool
   -> Arg (Type'' Term Term)
   -> Substitution
   -> [AsBinding]
   -> IntSet
   -> Bool
   -> LHSResult)
-> ReduceM [NamedArg DeBruijnPattern]
-> ReduceM
     (Bool
      -> Arg (Type'' Term Term)
      -> Substitution
      -> [AsBinding]
      -> IntSet
      -> Bool
      -> LHSResult)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [NamedArg DeBruijnPattern] -> ReduceM [NamedArg DeBruijnPattern]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [NamedArg DeBruijnPattern]
ps
    ReduceM
  (Bool
   -> Arg (Type'' Term Term)
   -> Substitution
   -> [AsBinding]
   -> IntSet
   -> Bool
   -> LHSResult)
-> ReduceM Bool
-> ReduceM
     (Arg (Type'' Term Term)
      -> Substitution -> [AsBinding] -> IntSet -> Bool -> LHSResult)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> ReduceM Bool
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Bool
abs
    ReduceM
  (Arg (Type'' Term Term)
   -> Substitution -> [AsBinding] -> IntSet -> Bool -> LHSResult)
-> ReduceM (Arg (Type'' Term Term))
-> ReduceM
     (Substitution -> [AsBinding] -> IntSet -> Bool -> LHSResult)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Arg (Type'' Term Term) -> ReduceM (Arg (Type'' Term Term))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Arg (Type'' Term Term)
t
    ReduceM
  (Substitution -> [AsBinding] -> IntSet -> Bool -> LHSResult)
-> ReduceM Substitution
-> ReduceM ([AsBinding] -> IntSet -> Bool -> LHSResult)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Substitution -> ReduceM Substitution
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Substitution
sub
    ReduceM ([AsBinding] -> IntSet -> Bool -> LHSResult)
-> ReduceM [AsBinding] -> ReduceM (IntSet -> Bool -> LHSResult)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [AsBinding] -> ReduceM [AsBinding]
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [AsBinding]
as
    ReduceM (IntSet -> Bool -> LHSResult)
-> ReduceM IntSet -> ReduceM (Bool -> LHSResult)
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> IntSet -> ReduceM IntSet
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure IntSet
psplit
    ReduceM (Bool -> LHSResult) -> ReduceM Bool -> ReduceM LHSResult
forall a b. ReduceM (a -> b) -> ReduceM a -> ReduceM b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> Bool -> ReduceM Bool
forall a. a -> ReduceM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
ixsplit

-- | Compute substitution from the out patterns @ps@
--
---  We have two slightly different cases here: normal function and
--   with-function. In both cases the goal is to build a substitution
--   from the context Γ of the previous checkpoint to the current lhs
--   context Δ:
--
--      Δ ⊢ paramSub : Γ
--
--    * Normal function, f
--
--      Γ = cxt = module parameter telescope of f
--      Ψ = non-parameter arguments of f (we have f : Γ Ψ → A)
--      Δ   ⊢ patSub  : Γ Ψ
--      Γ Ψ ⊢ weakSub : Γ
--      paramSub = patSub ∘ weakSub
--
--    * With-function
--
--      Γ = lhs context of the parent clause (cxt = [])
--      Ψ = argument telescope of with-function
--      Θ = inserted implicit patterns not in Ψ (#2827)
--          (this happens if the goal computes to an implicit
--           function type after some matching in the with-clause)
--
--      Ψ   ⊢ withSub : Γ
--      Δ   ⊢ patSub  : Ψ Θ
--      Ψ Θ ⊢ weakSub : Ψ
--      paramSub = patSub ∘ weakSub ∘ withSub
--
--      To compute Θ we can look at the arity of the with-function
--      and compare it to numPats. This works since the with-function
--      type is fully reduced.
buildLHSSubstitutions :: Context -> NAPs -> IsWithFunction (Arity, Substitution)
  -> (Substitution, Substitution)
buildLHSSubstitutions :: Context
-> [NamedArg DeBruijnPattern]
-> IsWithFunction (Int, Substitution)
-> (Substitution, Substitution)
buildLHSSubstitutions Context
cxt [NamedArg DeBruijnPattern]
ps IsWithFunction (Int, Substitution)
isWithFun = do
  let notProjPats :: [NamedArg DeBruijnPattern]
notProjPats = (NamedArg DeBruijnPattern -> Bool)
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (Maybe (ProjOrigin, AmbiguousQName) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (ProjOrigin, AmbiguousQName) -> Bool)
-> (NamedArg DeBruijnPattern -> Maybe (ProjOrigin, AmbiguousQName))
-> NamedArg DeBruijnPattern
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg DeBruijnPattern -> Maybe (ProjOrigin, AmbiguousQName)
forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
isProjP) [NamedArg DeBruijnPattern]
ps
      numPats :: Int
numPats = [NamedArg DeBruijnPattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NamedArg DeBruijnPattern]
notProjPats
      patSub :: Substitution
patSub = (NamedArg DeBruijnPattern -> Term)
-> [NamedArg DeBruijnPattern] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' (DeBruijnPattern -> Term
patternToTerm (DeBruijnPattern -> Term)
-> (NamedArg DeBruijnPattern -> DeBruijnPattern)
-> NamedArg DeBruijnPattern
-> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg DeBruijnPattern -> DeBruijnPattern
forall a. NamedArg a -> a
namedArg) ([NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. [a] -> [a]
reverse [NamedArg DeBruijnPattern]
notProjPats) [Term] -> Substitution -> Substitution
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++#
        Impossible -> Substitution
forall a. Impossible -> Substitution' a
EmptyS Impossible
HasCallStack => Impossible
impossible
      (Substitution
weakSub, Substitution
withSub) = case IsWithFunction (Int, Substitution)
isWithFun of
        IsWithFunction (Int, Substitution)
NoWithFunction             ->
          (Int -> Substitution -> Substitution
forall a. Int -> Substitution' a -> Substitution' a
wkS (Int
numPats Int -> Int -> Int
forall a. Num a => a -> a -> a
- Context -> Int
forall a. Context' a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
cxt) Substitution
forall a. Substitution' a
idS, Substitution
forall a. Substitution' a
idS)
        WithFunction (Int
arity, Substitution
withSub) ->
          -- if numPats < arity, Θ is empty
          (Int -> Substitution -> Substitution
forall a. Int -> Substitution' a -> Substitution' a
wkS (Int -> Int -> Int
forall a. Ord a => a -> a -> a
max Int
0 (Int -> Int) -> Int -> Int
forall a b. (a -> b) -> a -> b
$ Int
numPats Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
arity) Substitution
forall a. Substitution' a
idS, Substitution
withSub)
      paramSub :: Substitution
paramSub = Substitution
patSub Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Substitution
weakSub Substitution -> Substitution -> Substitution
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Substitution
withSub
  (Substitution
patSub, Substitution
paramSub)

-- | Check a LHS. Main function.
--
--   @checkLeftHandSide a ps a ret@ checks that user patterns @ps@ eliminate
--   the type @a@ of the defined function, and calls continuation @ret@
--   if successful.

checkLeftHandSide :: forall a.
     Call
     -- ^ Trace, e.g. 'CheckLHS' or 'CheckPattern'.
  -> Range
     -- ^ 'Range' of the entire left hand side, for error reporting.
  -> LetOrClause
     -- ^ Are we checking a let-pattern or a function clause?
  -> [NamedArg A.Pattern]
     -- ^ The patterns.
  -> Type
     -- ^ The expected type @a = Γ → b@.
  -> IsWithFunction Substitution
     -- ^ Module parameter substitution from with-abstraction.
  -> [ProblemEq]
     -- ^ Patterns that have been stripped away by with-desugaring.
     -- ^ These should not contain any proper matches.
  -> (LHSResult -> TCM a)
     -- ^ Continuation, called in the context constructed from
     --   the 'lhsVarTele' via 'computeLHSContext'.
     --   All components of 'LHSResult' live in this context, including 'lhsVarTele'.
  -> TCM a
checkLeftHandSide :: forall a.
Call
-> Range' SrcFile
-> LetOrClause
-> [Arg (Named_ (Pattern' Expr))]
-> Type'' Term Term
-> IsWithFunction Substitution
-> [ProblemEq]
-> (LHSResult -> TCM a)
-> TCM a
checkLeftHandSide Call
call Range' SrcFile
lhsRng LetOrClause
f [Arg (Named_ (Pattern' Expr))]
ps Type'' Term Term
a IsWithFunction Substitution
withSub' [ProblemEq]
strippedPats =
 Account (BenchPhase (TCMT IO))
-> ((LHSResult -> TCMT IO a) -> TCMT IO a)
-> (LHSResult -> TCMT IO a)
-> TCMT IO a
forall (m :: * -> *) b c.
MonadBench m =>
Account (BenchPhase m) -> ((b -> m c) -> m c) -> (b -> m c) -> m c
Bench.billToCPS [BenchPhase (TCMT IO)
Phase
Bench.Typing, BenchPhase (TCMT IO)
Phase
Bench.CheckLHS] (((LHSResult -> TCMT IO a) -> TCMT IO a)
 -> (LHSResult -> TCMT IO a) -> TCMT IO a)
-> ((LHSResult -> TCMT IO a) -> TCMT IO a)
-> (LHSResult -> TCMT IO a)
-> TCMT IO a
forall a b. (a -> b) -> a -> b
$
 Call
-> ((LHSResult -> TCMT IO a) -> TCMT IO a)
-> (LHSResult -> TCMT IO a)
-> TCMT IO a
forall a b.
Call
-> ((a -> TCMT IO b) -> TCMT IO b) -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b.
MonadTrace m =>
Call -> ((a -> m b) -> m b) -> (a -> m b) -> m b
traceCallCPS Call
call (((LHSResult -> TCMT IO a) -> TCMT IO a)
 -> (LHSResult -> TCMT IO a) -> TCMT IO a)
-> ((LHSResult -> TCMT IO a) -> TCMT IO a)
-> (LHSResult -> TCMT IO a)
-> TCMT IO a
forall a b. (a -> b) -> a -> b
$ \ LHSResult -> TCMT IO a
ret -> do

  -- To allow module parameters to be refined by matching, we're adding the
  -- context arguments as wildcard patterns and extending the type with the
  -- context telescope.
  --
  -- To pick up instances from {{}}-fields in a record module, we have
  -- to preserve which variable is the 'self' variable of that record.
  cxt <- (ContextEntry -> ContextEntry) -> Context -> Context
forall a b. (a -> b) -> Context' a -> Context' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Origin -> Origin) -> ContextEntry -> ContextEntry
forall a. LensOrigin a => (Origin -> Origin) -> a -> a
mapOrigin \case{ Origin
RecordSelf -> Origin
RecordSelf ; Origin
_ -> Origin
Inserted }) (Context -> Context) -> TCM Context -> TCM Context
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
         TCM Context
forall (m :: * -> *). MonadTCEnv m => m Context
getContext
  let tel = Context -> Tele (Dom (Type'' Term Term))
contextToTel Context
cxt
      cps = [ Dom' Term Name -> Arg Name
forall t a. Dom' t a -> Arg a
argFromDom Dom' Term Name
dom Arg Name -> Named_ (Pattern' Expr) -> Arg (Named_ (Pattern' Expr))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Pattern' Expr -> Named_ (Pattern' Expr)
forall a name. a -> Named name a
unnamed (BindName -> Pattern' Expr
forall e. BindName -> Pattern' e
A.VarP (BindName -> Pattern' Expr) -> BindName -> Pattern' Expr
forall a b. (a -> b) -> a -> b
$ Name -> BindName
A.mkBindName (Name -> BindName) -> Name -> BindName
forall a b. (a -> b) -> a -> b
$ Dom' Term Name -> Name
forall t e. Dom' t e -> e
unDom Dom' Term Name
dom)
            | (Int
_,Dom' Term Name
dom) <- Context -> [(Int, Dom' Term Name)]
contextVars Context
cxt ]
      eqs0 = (Pattern' Expr -> Term -> Dom (Type'' Term Term) -> ProblemEq)
-> [Pattern' Expr]
-> [Term]
-> [Dom (Type'' Term Term)]
-> [ProblemEq]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Pattern' Expr -> Term -> Dom (Type'' Term Term) -> ProblemEq
ProblemEq ((Arg (Named_ (Pattern' Expr)) -> Pattern' Expr)
-> [Arg (Named_ (Pattern' Expr))] -> [Pattern' Expr]
forall a b. (a -> b) -> [a] -> [b]
map' Arg (Named_ (Pattern' Expr)) -> Pattern' Expr
forall a. NamedArg a -> a
namedArg [Arg (Named_ (Pattern' Expr))]
cps) ((Int -> Term) -> [Int] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Int -> Term
var ([Int] -> [Term]) -> [Int] -> [Term]
forall a b. (a -> b) -> a -> b
$ Int -> [Int]
forall a. Integral a => a -> [a]
downFrom (Int -> [Int]) -> Int -> [Int]
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
tel) (Tele (Dom (Type'' Term Term)) -> [Dom (Type'' Term Term)]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel Tele (Dom (Type'' Term Term))
tel)

  let finalChecks :: LHSState a -> TCM a
      finalChecks (LHSState Tele (Dom (Type'' Term Term))
delta [NamedArg DeBruijnPattern]
qs0 (Problem [ProblemEq]
eqs [Arg (Named_ (Pattern' Expr))]
rps LHSState a -> TCMT IO a
_) Arg (Type'' Term Term)
b [Maybe Int]
psplit Bool
ixsplit) = do

        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" 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
"lhs: final checks with remaining equations"
          , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
4 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ if [ProblemEq] -> Bool
forall a. Null a => a -> Bool
null [ProblemEq]
eqs then TCMT IO Doc
"(none)" else Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta (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
$ (ProblemEq -> TCMT IO Doc) -> [ProblemEq] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map' ProblemEq -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ProblemEq -> m Doc
prettyTCM [ProblemEq]
eqs
          , 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
"qs0 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta ([NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList [NamedArg DeBruijnPattern]
qs0)
          ]

        Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless ([Arg (Named_ (Pattern' Expr))] -> Bool
forall a. Null a => a -> Bool
null [Arg (Named_ (Pattern' Expr))]
rps) TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__

        Tele (Dom (Type'' Term Term)) -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
          (ProblemEq -> TCMT IO ()) -> [ProblemEq] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProblemEq -> TCMT IO ()
noShadowingOfConstructors [ProblemEq]
eqs

          -- When working --without-K or --cubical=compatible, we have
          -- to check that the target type can be used at the “ambient”
          -- modality. For --cubical=compatible, this just improves an
          -- error message (printing the type rather than the generated
          -- RHS). For --without-K, it implements the same check without
          -- necessarily generating --cubical code.
          -- The reason for this check is that a clause
          --    foo : x ≡ y → ... → T y
          --    foo refl ... = ...
          -- in Cubical mode, gets elaborated to an extra clause of the
          -- form
          --    foo (transp p φ x) ... = transp (λ i → T (p i)) φ (foo x ...)
          -- (approximately), where T is the target type. That is: to
          -- implement the substitution T[y/x], we use an actual
          -- transport. See #5448.

        arity_a <- Type'' Term Term -> TCM Int
arityPiPath Type'' Term Term
a

        reportSDoc "tc.lhs.top" 30 $ vcat
          [ nest 2 $ "a        =" <+> prettyTCM a
          , nest 2 $ "arity_a  =" <+> prettyTCM arity_a
          , nest 2 $ "withSub' =" <+> prettyTCM withSub'
          ]

        let (patSub, paramSub) = buildLHSSubstitutions cxt qs0 $
              fmap (arity_a,) withSub'

        eqs <- addContext delta $ checkPatternLinearity eqs

        leftovers@(LeftoverPatterns patVars asb0 dots absurds annps otherPats)
          <- addContext delta $ getLeftoverPatterns eqs

        reportSDoc "tc.lhs.leftover" 30 $ vcat
          [ "leftover patterns: " , nest 2 (addContext delta $ prettyTCM leftovers) ]

        unless (null otherPats) __IMPOSSIBLE__

        -- Get the user-written names for the pattern variables
        let (vars, asb1) = getUserVariableNames delta patVars
            asb          = [AsBinding]
asb0 [AsBinding] -> [AsBinding] -> [AsBinding]
forall a. [a] -> [a] -> [a]
++! [AsBinding]
asb1

        -- Rename internal patterns with these names
        let makeVar     = (Int -> DeBruijnPattern)
-> (Name -> Int -> DeBruijnPattern)
-> Maybe Name
-> Int
-> DeBruijnPattern
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int -> DeBruijnPattern
forall a. DeBruijn a => Int -> a
deBruijnVar ((Name -> Int -> DeBruijnPattern)
 -> Maybe Name -> Int -> DeBruijnPattern)
-> (Name -> Int -> DeBruijnPattern)
-> Maybe Name
-> Int
-> DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> DeBruijnPattern
forall a. DeBruijn a => [Char] -> Int -> a
deBruijnNamedVar ([Char] -> Int -> DeBruijnPattern)
-> (Name -> [Char]) -> Name -> Int -> DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameToArgName
            ren         = [DeBruijnPattern] -> Substitution' DeBruijnPattern
forall a. DeBruijn a => [a] -> Substitution' a
parallelS ([DeBruijnPattern] -> Substitution' DeBruijnPattern)
-> [DeBruijnPattern] -> Substitution' DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ (Maybe Name -> Int -> DeBruijnPattern)
-> [Maybe Name] -> [Int] -> [DeBruijnPattern]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith' Maybe Name -> Int -> DeBruijnPattern
makeVar ([Maybe Name] -> [Maybe Name]
forall a. [a] -> [a]
reverse [Maybe Name]
vars) [Int
0..]

        qs <- transferOrigins (cps ++! ps) $ applySubst ren qs0

        let hasAbsurd = Bool -> Bool
not (Bool -> Bool)
-> ([AbsurdPattern] -> Bool) -> [AbsurdPattern] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [AbsurdPattern] -> Bool
forall a. Null a => a -> Bool
null ([AbsurdPattern] -> Bool) -> [AbsurdPattern] -> Bool
forall a b. (a -> b) -> a -> b
$ [AbsurdPattern]
absurds

        let lhsResult = Int
-> Tele (Dom (Type'' Term Term))
-> [NamedArg DeBruijnPattern]
-> Bool
-> Arg (Type'' Term Term)
-> Substitution
-> [AsBinding]
-> IntSet
-> Bool
-> LHSResult
LHSResult (Context -> Int
forall a. Context' a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
cxt) Tele (Dom (Type'' Term Term))
delta [NamedArg DeBruijnPattern]
qs Bool
hasAbsurd Arg (Type'' Term Term)
b Substitution
patSub [AsBinding]
asb ([Int] -> IntSet
IntSet.fromList ([Int] -> IntSet) -> [Int] -> IntSet
forall a b. (a -> b) -> a -> b
$ [Maybe Int] -> [Int]
forall a. [Maybe a] -> [a]
catMaybes [Maybe Int]
psplit) Bool
ixsplit

        -- Debug output
        reportSDoc "tc.lhs.top" 10 $
          vcat [ "checked lhs:"
               , nest 2 $ vcat
                 [ "delta   = " <+> prettyTCM delta
                 , "dots    = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map' prettyTCM dots)
                 , "asb     = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map' prettyTCM asb)
                 , "absurds = " <+> addContext delta (brackets $ fsep $ punctuate comma $ map' prettyTCM absurds)
                 , "qs      = " <+> addContext delta (prettyList $ map' pretty qs)
                 , "b       = " <+> addContext delta (prettyTCM b)
                 ]
               ]
        reportSDoc "tc.lhs.top" 30 $
          nest 2 $ vcat
                 [ "vars   = " <+> pretty vars
                 , "b      = " <+> pretty b
                 ]
        reportSDoc "tc.lhs.top" 20 $ nest 2 $ "patSub   = " <+> pretty patSub
        reportSDoc "tc.lhs.top" 20 $ nest 2 $ "paramSub = " <+> pretty paramSub

        newCxt <- computeLHSContext vars delta

        updateContext paramSub (const newCxt) $ do

          reportSDoc "tc.lhs.top" 10 $ "bound pattern variables"
          reportSDoc "tc.lhs.top" 60 $ nest 2 $ "context = " <+> (pretty =<< getContextTelescope)
          reportSDoc "tc.lhs.top" 10 $ nest 2 $ "type  = " <+> prettyTCM b
          reportSDoc "tc.lhs.top" 60 $ nest 2 $ "type  = " <+> pretty b

          bindAsPatterns asb $ do

            -- Check dot patterns
            mapM_ checkDotPattern dots
            mapM_ checkAbsurdPattern absurds
            mapM_ checkAnnotationPattern annps

          -- Issue2303: don't bind asb' for the continuation (return in lhsResult instead)
          ret lhsResult

  st0 <- initLHSState tel eqs0 ps a finalChecks

  -- after we have introduced variables, we can add the patterns stripped by
  -- with-desugaring to the state.
  let withSub = case IsWithFunction Substitution
withSub' of
        IsWithFunction Substitution
NoWithFunction -> Substitution
forall a. HasCallStack => a
__IMPOSSIBLE__
        WithFunction Substitution
sub -> Substitution
sub
  withEqs <- updateProblemEqs $ applySubst withSub strippedPats
  -- Jesper, 2017-05-13: re-check the stripped patterns here!
  inTopContext $ addContext (st0 ^. lhsTel) $
    forM_ withEqs recheckStrippedWithPattern

  let st = ASetter (LHSState a) (LHSState a) [ProblemEq] [ProblemEq]
-> ([ProblemEq] -> [ProblemEq]) -> LHSState a -> LHSState a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Problem a -> Identity (Problem a))
-> LHSState a -> Identity (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
lhsProblem ((Problem a -> Identity (Problem a))
 -> LHSState a -> Identity (LHSState a))
-> (([ProblemEq] -> Identity [ProblemEq])
    -> Problem a -> Identity (Problem a))
-> ASetter (LHSState a) (LHSState a) [ProblemEq] [ProblemEq]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ProblemEq] -> Identity [ProblemEq])
-> Problem a -> Identity (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs) ([ProblemEq] -> [ProblemEq] -> [ProblemEq]
forall a. [a] -> [a] -> [a]
++! [ProblemEq]
withEqs) LHSState a
st0

  -- doing the splits:
  let initLHSContext = LHSContext { lhsRange :: Range' SrcFile
lhsRange = Range' SrcFile
lhsRng, lhsContextSize :: Int
lhsContextSize = Context -> Int
forall a. Sized a => a -> Int
size Context
cxt }
  (result, block) <- unsafeInTopContext $ runWriterT $ (`runReaderT` initLHSContext) $ checkLHS f st
  return result

-- | Check that this split will generate a modality-correct internal
-- clause when --cubical=compatible is used. This means that the type of
-- anything which might be transported must be modality-correct. This is
-- necessarily an approximate check. We assume that any argument which
-- (a) comes after and (b) mentions a dotted argument will be
-- transported, which is probably an overestimate.
conSplitModalityCheck ::
     Range
       -- ^ Range of the whole left hand side, for error reporting.
  -> Modality
       -- ^ Modality to check at.
  -> PatternSubstitution
      -- ^ Substitution resulting from index unification. @Γ ⊢ ρ : Δ'@,
      -- where @Δ'@ is the context we're in, and @Γ@ is the clause telescope
      -- before unification.
  -> Int       -- ^ Variable @x@ at which we split.
  -> Telescope -- ^ The telescope @Γ@ itself.
  -> Type      -- ^ Target type of the clause.
  -> TCM ()
conSplitModalityCheck :: Range' SrcFile
-> Modality
-> Substitution' DeBruijnPattern
-> Int
-> Tele (Dom (Type'' Term Term))
-> Type'' Term Term
-> TCMT IO ()
conSplitModalityCheck Range' SrcFile
lhsRng Modality
mod Substitution' DeBruijnPattern
rho Int
blocking Tele (Dom (Type'' Term Term))
gamma Type'' Term Term
target = Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
when ((Dom (Type'' Term Term) -> Bool)
-> Tele (Dom (Type'' Term Term)) -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((Modality -> Modality -> Bool
forall a. Eq a => a -> a -> Bool
/= Modality
defaultModality) (Modality -> Bool)
-> (Dom (Type'' Term Term) -> Modality)
-> Dom (Type'' Term Term)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom (Type'' Term Term) -> Modality
forall a. LensModality a => a -> Modality
getModality) Tele (Dom (Type'' Term Term))
gamma) (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.lhs.top" Int
30 (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
"LHS modality check for modality: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Modality -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Modality -> m Doc
prettyTCM Modality
mod
    , TCMT IO Doc
"rho:    " 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 (Substitution' DeBruijnPattern -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Substitution' DeBruijnPattern -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho)
    , TCMT IO Doc
"gamma:  " 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 (Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
gamma)
    , TCMT IO Doc
"target: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
target
    , TCMT IO Doc
"target (raw): " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type'' Term Term
target
    , TCMT IO Doc
"Δ'target: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM (Substitution' DeBruijnPattern
-> Type'' Term Term -> Type'' Term Term
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Type'' Term Term
target)
    , TCMT IO Doc
"blocking:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Int -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Int -> m Doc
prettyTCM Int
blocking
    ]
  Maybe Int -> (Int -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust (Substitution' DeBruijnPattern -> Int -> Maybe Int
firstForced Substitution' DeBruijnPattern
rho (Tele (Dom (Type'' Term Term)) -> Int
forall a. Tele a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Tele (Dom (Type'' Term Term))
gamma)) \ Int
ix -> do
      -- We've found a forced argument. This means that the unifier has
      -- decided to kill a unification variable, and any of its
      -- occurrences in the generated term will be replaced by an
      -- occurrence of a path, and any terms whose types mention that
      -- variable will be transported.
      let
        (Tele (Dom (Type'' Term Term))
gamma0, Tele (Dom (Type'' Term Term))
delta) = Int
-> Tele (Dom (Type'' Term Term))
-> (Tele (Dom (Type'' Term Term)), Tele (Dom (Type'' Term Term)))
splitTelescopeAt (Tele (Dom (Type'' Term Term)) -> Int
forall a. Tele a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Tele (Dom (Type'' Term Term))
gamma Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
ix) Tele (Dom (Type'' Term Term))
gamma
        name :: Int -> TCMT IO Name
name = TCMT IO Name -> TCMT IO Name
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCMT IO Name -> TCMT IO Name)
-> (Int -> TCMT IO Name) -> Int -> TCMT IO Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Tele (Dom (Type'' Term Term)) -> TCMT IO Name -> TCMT IO Name
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
gamma (TCMT IO Name -> TCMT IO Name)
-> (Int -> TCMT IO Name) -> Int -> TCMT IO Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Int -> TCMT IO Name
forall (m :: * -> *). (MonadDebug m, MonadTCEnv m) => Int -> m Name
nameOfBV
        delta'target :: Type'' Term Term
delta'target = Substitution' DeBruijnPattern
-> Type'' Term Term -> Type'' Term Term
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Type'' Term Term
target
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
30 (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
"found forced argument!"
        , TCMT IO Doc
"forced: " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Int -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Int -> m Doc
prettyTCM Int
ix
        , TCMT IO Doc
"before: " 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 (Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
gamma0)
        , TCMT IO Doc
"after:  " 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 (Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
gamma0 (Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
delta))
        ]
      forced <- Int -> TCMT IO Name
name Int
ix
      forM_ (zip' [ix - 1, ix - 2 ..] (telToList delta)) $ \(Int
arg, Dom ([Char], Type'' Term Term)
d) -> do
        -- Example: The first argument after the first forced variable. So
        -- we have e.g.:
        --   Γ = Γ₀.x.Δ
        --   Δ' ⊢ ρ : Γ₀.x.Δ
        --   Γ₀ ⊢ x : Type
        -- but we need
        --   Δ' ⊢ x : Type,
        -- since Δ' is the context we are in. Then we have
        --   Γ ⊢ x[wkS |Δ|] : Type
        -- and consequently
        --   Δ' ⊢ x[wkS |Δ|][ρ] : Type
        let
          rho' :: Substitution' DeBruijnPattern
rho' = Substitution' DeBruijnPattern
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
composeS Substitution' DeBruijnPattern
rho (Int
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. Int -> Substitution' a -> Substitution' a
wkS (Int
arg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Substitution' DeBruijnPattern
forall a. Substitution' a
idS)
        ty' <- Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Substitution' DeBruijnPattern -> Term -> Term
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho' (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl (([Char], Type'' Term Term) -> Type'' Term Term
forall a b. (a, b) -> b
snd (Dom ([Char], Type'' Term Term) -> ([Char], Type'' Term Term)
forall t e. Dom' t e -> e
unDom Dom ([Char], Type'' Term Term)
d))))
        let
          -- It's actually rather tricky to know when, exactly, a
          -- transport will be needed in a position that forces an
          -- usable-at-modality check. Our current heuristic is:
          --
          -- The variable we're looking at has a fibrant type, with the
          -- first forced variable free.
          -- The variable appears free in the result type.
          docheck = [Bool] -> Bool
forall (t :: * -> *). Foldable t => t Bool -> Bool
and
            [ Int
ix Int -> Term -> Bool
forall t. Free t => Int -> t -> Bool
`freeIn` Substitution' (SubstArg Term) -> Term -> Term
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst (Int -> Substitution -> Substitution
forall a. Int -> Substitution' a -> Substitution' a
wkS (Int
arg Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1) Substitution
forall a. Substitution' a
idS) (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl (([Char], Type'' Term Term) -> Type'' Term Term
forall a b. (a, b) -> b
snd (Dom ([Char], Type'' Term Term) -> ([Char], Type'' Term Term)
forall t e. Dom' t e -> e
unDom Dom ([Char], Type'' Term Term)
d)))
            , Int
arg Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
/= Int
blocking
            , Int
arg Int -> Type'' Term Term -> Bool
forall t. Free t => Int -> t -> Bool
`freeIn` Type'' Term Term
target
            ]
        reportSDoc "tc.lhs.top" 30 $ vcat
          [ "arg:        " <+> pretty arg
          , "arg type:   " <+> prettyTCM (applySubst (wkS (arg + 1) idS) (unEl (snd (unDom d))))
          , "check       " <+> pretty docheck
          ]
        argn <- name arg
        when docheck $
          usableAtModality (IndexedClauseArg forced argn) mod ty'

  -- ALways check the target clause type. Specifically, we check it both
  -- in Δ' and in Γ. The check in Δ' will sometimes let slip by a
  -- quantity violation which is masked by an indexed match (recall that
  -- the unifier likes to replace @0-variables for @ω-variables). A
  -- concrete case where this happens is #5468. Check in Δ' first since
  -- that will have the forced variable names.
  Range' SrcFile -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Range' SrcFile
lhsRng do
    WhyCheckModality -> Modality -> Term -> TCMT IO ()
MonadConstraint (TCMT IO) =>
WhyCheckModality -> Modality -> Term -> TCMT IO ()
usableAtModality WhyCheckModality
IndexedClause Modality
mod (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl (Substitution' DeBruijnPattern
-> Type'' Term Term -> Type'' Term Term
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Type'' Term Term
target))
    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
$ Tele (Dom (Type'' Term Term)) -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
gamma (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ WhyCheckModality -> Modality -> Term -> TCMT IO ()
MonadConstraint (TCMT IO) =>
WhyCheckModality -> Modality -> Term -> TCMT IO ()
usableAtModality WhyCheckModality
IndexedClause Modality
mod (Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
target)
  where
    -- Find the first dotted pattern in the substitution. "First" =
    -- "earliest bound", so counts down from the length of the
    -- telescope.
    firstForced :: PatternSubstitution -> Int -> Maybe Int
    firstForced :: Substitution' DeBruijnPattern -> Int -> Maybe Int
firstForced Substitution' DeBruijnPattern
pat Int
level
      | Int
level Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
0 = case Substitution' DeBruijnPattern -> Int -> DeBruijnPattern
forall a. EndoSubst a => Substitution' a -> Int -> a
lookupS Substitution' DeBruijnPattern
pat Int
level of
        DotP{} -> Int -> Maybe Int
forall a. a -> Maybe a
Just Int
level
        DeBruijnPattern
_ -> Substitution' DeBruijnPattern -> Int -> Maybe Int
firstForced Substitution' DeBruijnPattern
pat (Int
level Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1)
      | Bool
otherwise = Maybe Int
forall a. Maybe a
Nothing

-- | Determine which splits should be tried.
splitStrategy :: [ProblemEq] -> [ProblemEq]
splitStrategy :: [ProblemEq] -> [ProblemEq]
splitStrategy = (ProblemEq -> Bool) -> [ProblemEq] -> [ProblemEq]
forall a. (a -> Bool) -> [a] -> [a]
filter ProblemEq -> Bool
shouldSplit
  where
    shouldSplit :: ProblemEq -> Bool
    shouldSplit :: ProblemEq -> Bool
shouldSplit problem :: ProblemEq
problem@(ProblemEq Pattern' Expr
p Term
v Dom (Type'' Term Term)
a) = case Pattern' Expr
p of
      A.LitP{}    -> Bool
True
      A.RecP{}    -> Bool
True
      A.ConP{}    -> Bool
True
      A.EqualP{}  -> Bool
True

      A.VarP{}    -> Bool
False
      A.WildP{}   -> Bool
False
      A.DotP{}    -> Bool
False
      A.AbsurdP{} -> Bool
False

      A.AsP PatInfo
_ BindName
_ Pattern' Expr
p  -> ProblemEq -> Bool
shouldSplit (ProblemEq -> Bool) -> ProblemEq -> Bool
forall a b. (a -> b) -> a -> b
$ ProblemEq
problem { problemInPat = p }

      A.ProjP{}       -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
      A.DefP{}        -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
      A.PatternSynP{} -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
      A.WithP{}       -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__

type CheckLHSM = ReaderT LHSContext (WriterT Blocked_ TCM)

-- | The loop (tail-recursive): split at a variable in the problem until problem is solved
checkLHS ::
     forall a.
     LetOrClause      -- ^ Are we checking a let-pattern or a function clause?
  -> LHSState a       -- ^ The current state.
  -> CheckLHSM a
checkLHS :: forall a. LetOrClause -> LHSState a -> CheckLHSM a
checkLHS LetOrClause
mf = (LHSState a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a)
-> LHSState a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall {tcm :: * -> *} {a} {a}.
(MonadTCEnv tcm, ExpandCase (tcm a)) =>
(LHSState a -> tcm a) -> LHSState a -> tcm a
updateModality LHSState a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
checkLHS_ where

 {-# INLINE updateModality #-}
    -- If the target type is irrelevant or in Prop,
    -- we need to check the lhs in irr. cxt. (see Issue 939).
 updateModality :: (LHSState a -> tcm a) -> LHSState a -> tcm a
updateModality LHSState a -> tcm a
cont = \st :: LHSState a
st@(LHSState Tele (Dom (Type'' Term Term))
tel [NamedArg DeBruijnPattern]
ip Problem a
problem Arg (Type'' Term Term)
target [Maybe Int]
psplit Bool
_) -> do
      let m :: Modality
m = Arg (Type'' Term Term) -> Modality
forall a. LensModality a => a -> Modality
getModality Arg (Type'' Term Term)
target
      Modality -> tcm a -> tcm a
forall (tcm :: * -> *) a m.
(MonadTCEnv tcm, ExpandCase (tcm a), LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext Modality
m (tcm a -> tcm a) -> tcm a -> tcm a
forall a b. (a -> b) -> a -> b
$ do
        LHSState a -> tcm a
cont (LHSState a -> tcm a) -> LHSState a -> tcm a
forall a b. (a -> b) -> a -> b
$ ASetter
  (LHSState a)
  (LHSState a)
  [Dom ([Char], Type'' Term Term)]
  [Dom ([Char], Type'' Term Term)]
-> ([Dom ([Char], Type'' Term Term)]
    -> [Dom ([Char], Type'' Term Term)])
-> LHSState a
-> LHSState a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ((Tele (Dom (Type'' Term Term))
 -> Identity (Tele (Dom (Type'' Term Term))))
-> LHSState a -> Identity (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Tele (Dom (Type'' Term Term))
 -> f (Tele (Dom (Type'' Term Term))))
-> LHSState a -> f (LHSState a)
lhsTel ((Tele (Dom (Type'' Term Term))
  -> Identity (Tele (Dom (Type'' Term Term))))
 -> LHSState a -> Identity (LHSState a))
-> (([Dom ([Char], Type'' Term Term)]
     -> Identity [Dom ([Char], Type'' Term Term)])
    -> Tele (Dom (Type'' Term Term))
    -> Identity (Tele (Dom (Type'' Term Term))))
-> ASetter
     (LHSState a)
     (LHSState a)
     [Dom ([Char], Type'' Term Term)]
     [Dom ([Char], Type'' Term Term)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Dom ([Char], Type'' Term Term)]
 -> Identity [Dom ([Char], Type'' Term Term)])
-> Tele (Dom (Type'' Term Term))
-> Identity (Tele (Dom (Type'' Term Term)))
Lens'
  (Tele (Dom (Type'' Term Term))) [Dom ([Char], Type'' Term Term)]
listTel)
                 ((Dom ([Char], Type'' Term Term) -> Dom ([Char], Type'' Term Term))
-> [Dom ([Char], Type'' Term Term)]
-> [Dom ([Char], Type'' Term Term)]
forall a b. (a -> b) -> [a] -> [b]
map' ((Dom ([Char], Type'' Term Term) -> Dom ([Char], Type'' Term Term))
 -> [Dom ([Char], Type'' Term Term)]
 -> [Dom ([Char], Type'' Term Term)])
-> (Dom ([Char], Type'' Term Term)
    -> Dom ([Char], Type'' Term Term))
-> [Dom ([Char], Type'' Term Term)]
-> [Dom ([Char], Type'' Term Term)]
forall a b. (a -> b) -> a -> b
$ Modality
-> Dom ([Char], Type'' Term Term) -> Dom ([Char], Type'' Term Term)
forall a. LensModality a => Modality -> a -> a
inverseApplyModalityButNotQuantity Modality
m) LHSState a
st
        -- Andreas, 2018-10-23, issue #3309
        -- the modalities in the clause telescope also need updating.

 checkLHS_ :: LHSState a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
checkLHS_ st :: LHSState a
st@(LHSState Tele (Dom (Type'' Term Term))
tel [NamedArg DeBruijnPattern]
ip Problem a
problem Arg (Type'' Term Term)
target [Maybe Int]
psplit Bool
ixsplit) = do
  [Char]
-> Int
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs" Int
40 (TCMT IO Doc -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ())
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"tel is" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
tel
  [Char]
-> Int
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs" Int
40 (TCMT IO Doc -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ())
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"ip is" 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]
ip
  [Char]
-> Int
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs" Int
40 (TCMT IO Doc -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ())
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target is" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
tel (Arg (Type'' Term Term) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Arg (Type'' Term Term) -> m Doc
prettyTCM Arg (Type'' Term Term)
target)
  if Problem a -> Bool
forall a. Problem a -> Bool
isSolvedProblem Problem a
problem then
    TCM a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall a.
TCM a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a)
-> TCM a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall a b. (a -> b) -> a -> b
$ (Problem a
problem Problem a
-> Getting (LHSState a -> TCM a) (Problem a) (LHSState a -> TCM a)
-> LHSState a
-> TCM a
forall s a. s -> Getting a s a -> a
^. Getting (LHSState a -> TCM a) (Problem a) (LHSState a -> TCM a)
forall a (f :: * -> *).
Functor f =>
((LHSState a -> TCM a) -> f (LHSState a -> TCM a))
-> Problem a -> f (Problem a)
problemCont) LHSState a
st
  else do

    [Char]
-> Int
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
30 (TCMT IO Doc -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ())
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ (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
"LHS state: " , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (LHSState a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => LHSState a -> m Doc
prettyTCM LHSState a
st) ]

    ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) Bool
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optPatternMatching (PragmaOptions -> Bool)
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) PragmaOptions
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCState -> PragmaOptions)
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) PragmaOptions
forall (m :: * -> *) a. ReadTCState m => (TCState -> a) -> m a
getsTC TCState -> PragmaOptions
forall a. LensPragmaOptions a => a -> PragmaOptions
getPragmaOptions) (ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
 -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ())
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall a b. (a -> b) -> a -> b
$
      Bool
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (Problem a -> Bool
forall a. Problem a -> Bool
problemAllVariables Problem a
problem) (ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
 -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ())
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall a b. (a -> b) -> a -> b
$
        TypeError -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
NeedOptionPatternMatching

    let splitsToTry :: [ProblemEq]
splitsToTry = [ProblemEq] -> [ProblemEq]
splitStrategy ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a
-> Getting [ProblemEq] (Problem a) [ProblemEq] -> [ProblemEq]
forall s a. s -> Getting a s a -> a
^. Getting [ProblemEq] (Problem a) [ProblemEq]
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs

    (ProblemEq
 -> ReaderT
      LHSContext
      (WriterT Blocked_ (TCMT IO))
      (Either [TCErr] (LHSState a))
 -> ReaderT
      LHSContext
      (WriterT Blocked_ (TCMT IO))
      (Either [TCErr] (LHSState a)))
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
-> [ProblemEq]
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ProblemEq
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
trySplit ReaderT
  LHSContext
  (WriterT Blocked_ (TCMT IO))
  (Either [TCErr] (LHSState a))
trySplitRest [ProblemEq]
splitsToTry ReaderT
  LHSContext
  (WriterT Blocked_ (TCMT IO))
  (Either [TCErr] (LHSState a))
-> (Either [TCErr] (LHSState a)
    -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a)
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall a b.
ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
-> (a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) b)
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right LHSState a
st' -> LetOrClause
-> LHSState a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall a. LetOrClause -> LHSState a -> CheckLHSM a
checkLHS LetOrClause
mf LHSState a
st'
      -- If no split works, give error from first split.
      -- This is conservative, but might not be the best behavior.
      -- It might be better to print all the errors instead.
      Left (TCErr
err:[TCErr]
_) -> TCErr -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall a.
TCErr -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
      Left []      -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall a. HasCallStack => a
__IMPOSSIBLE__

  where

    trySplit :: ProblemEq
             -> CheckLHSM (Either [TCErr] (LHSState a))
             -> CheckLHSM (Either [TCErr] (LHSState a))
    trySplit :: ProblemEq
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
trySplit ProblemEq
eq ReaderT
  LHSContext
  (WriterT Blocked_ (TCMT IO))
  (Either [TCErr] (LHSState a))
tryNextSplit = ExceptT TCErr CheckLHSM (LHSState a)
-> ReaderT
     LHSContext (WriterT Blocked_ (TCMT IO)) (Either TCErr (LHSState a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ProblemEq -> ExceptT TCErr CheckLHSM (LHSState a)
splitArg ProblemEq
eq) ReaderT
  LHSContext (WriterT Blocked_ (TCMT IO)) (Either TCErr (LHSState a))
-> (Either TCErr (LHSState a)
    -> ReaderT
         LHSContext
         (WriterT Blocked_ (TCMT IO))
         (Either [TCErr] (LHSState a)))
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
forall a b.
ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
-> (a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) b)
-> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right LHSState a
st' -> Either [TCErr] (LHSState a)
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
forall a. a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TCErr] (LHSState a)
 -> ReaderT
      LHSContext
      (WriterT Blocked_ (TCMT IO))
      (Either [TCErr] (LHSState a)))
-> Either [TCErr] (LHSState a)
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
forall a b. (a -> b) -> a -> b
$ LHSState a -> Either [TCErr] (LHSState a)
forall a b. b -> Either a b
Right LHSState a
st'
      Left TCErr
err  -> ([TCErr] -> [TCErr])
-> Either [TCErr] (LHSState a) -> Either [TCErr] (LHSState a)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (TCErr
errTCErr -> [TCErr] -> [TCErr]
forall a. a -> [a] -> [a]
:) (Either [TCErr] (LHSState a) -> Either [TCErr] (LHSState a))
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  LHSContext
  (WriterT Blocked_ (TCMT IO))
  (Either [TCErr] (LHSState a))
tryNextSplit

    -- If there are any remaining user patterns, try to split on them
    trySplitRest :: CheckLHSM (Either [TCErr] (LHSState a))
    trySplitRest :: ReaderT
  LHSContext
  (WriterT Blocked_ (TCMT IO))
  (Either [TCErr] (LHSState a))
trySplitRest = case Problem a
problem Problem a
-> Getting
     [Arg (Named_ (Pattern' Expr))]
     (Problem a)
     [Arg (Named_ (Pattern' Expr))]
-> [Arg (Named_ (Pattern' Expr))]
forall s a. s -> Getting a s a -> a
^. Getting
  [Arg (Named_ (Pattern' Expr))]
  (Problem a)
  [Arg (Named_ (Pattern' Expr))]
forall a (f :: * -> *).
Functor f =>
([Arg (Named_ (Pattern' Expr))]
 -> f [Arg (Named_ (Pattern' Expr))])
-> Problem a -> f (Problem a)
problemRestPats of
      []    -> Either [TCErr] (LHSState a)
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
forall a. a -> ReaderT LHSContext (WriterT Blocked_ (TCMT IO)) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TCErr] (LHSState a)
 -> ReaderT
      LHSContext
      (WriterT Blocked_ (TCMT IO))
      (Either [TCErr] (LHSState a)))
-> Either [TCErr] (LHSState a)
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
forall a b. (a -> b) -> a -> b
$ [TCErr] -> Either [TCErr] (LHSState a)
forall a b. a -> Either a b
Left []
      (Arg (Named_ (Pattern' Expr))
p:[Arg (Named_ (Pattern' Expr))]
_) -> (TCErr -> [TCErr])
-> Either TCErr (LHSState a) -> Either [TCErr] (LHSState a)
forall a b c. (a -> b) -> Either a c -> Either b c
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first TCErr -> [TCErr]
forall el coll. Singleton el coll => el -> coll
singleton (Either TCErr (LHSState a) -> Either [TCErr] (LHSState a))
-> ReaderT
     LHSContext (WriterT Blocked_ (TCMT IO)) (Either TCErr (LHSState a))
-> ReaderT
     LHSContext
     (WriterT Blocked_ (TCMT IO))
     (Either [TCErr] (LHSState a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT TCErr CheckLHSM (LHSState a)
-> ReaderT
     LHSContext (WriterT Blocked_ (TCMT IO)) (Either TCErr (LHSState a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (Arg (Named_ (Pattern' Expr))
-> ExceptT TCErr CheckLHSM (LHSState a)
splitRest Arg (Named_ (Pattern' Expr))
p)

    splitArg :: ProblemEq -> ExceptT TCErr CheckLHSM (LHSState a)
    -- Split on constructor/literal pattern
    splitArg :: ProblemEq -> ExceptT TCErr CheckLHSM (LHSState a)
splitArg (ProblemEq Pattern' Expr
p Term
v (Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> Type'' Term Term
a)) = Call
-> ExceptT TCErr CheckLHSM (LHSState a)
-> ExceptT TCErr CheckLHSM (LHSState a)
forall a.
Call -> ExceptT TCErr CheckLHSM a -> ExceptT TCErr CheckLHSM a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Pattern' Expr
-> Tele (Dom (Type'' Term Term)) -> Type'' Term Term -> Call
CheckPattern Pattern' Expr
p Tele (Dom (Type'' Term Term))
tel Type'' Term Term
a) (ExceptT TCErr CheckLHSM (LHSState a)
 -> ExceptT TCErr CheckLHSM (LHSState a))
-> ExceptT TCErr CheckLHSM (LHSState a)
-> ExceptT TCErr CheckLHSM (LHSState a)
forall a b. (a -> b) -> a -> b
$ do

      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
30 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
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 looking at 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
$ TCMT IO Doc
"p =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Pattern' Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern' Expr
p
        ]

      -- in order to split, v must be a variable.
      i <- TCM Int -> ExceptT TCErr CheckLHSM Int
forall a. TCM a -> ExceptT TCErr CheckLHSM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Int -> ExceptT TCErr CheckLHSM Int)
-> TCM Int -> ExceptT TCErr CheckLHSM Int
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> TCM Int -> TCM Int
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
tel (TCM Int -> TCM Int) -> TCM Int -> TCM Int
forall a b. (a -> b) -> a -> b
$ TCMT IO (Maybe Int) -> (Int -> TCM Int) -> TCM Int -> TCM Int
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m b -> m b
ifJustM (Term -> Type'' Term Term -> TCMT IO (Maybe Int)
forall (m :: * -> *).
PureTCM m =>
Term -> Type'' Term Term -> m (Maybe Int)
isEtaVar Term
v Type'' Term Term
a) Int -> TCM Int
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (TCM Int -> TCM Int) -> TCM Int -> TCM Int
forall a b. (a -> b) -> a -> b
$
             TypeError -> TCM Int
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> TCM Int) -> TypeError -> TCM Int
forall a b. (a -> b) -> a -> b
$ Term -> Type'' Term Term -> TypeError
SplitOnNonVariable Term
v Type'' Term Term
a

      let pos = Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
tel Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
i Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Int
1)
          (delta1, tel'@(ExtendTel dom adelta2)) = splitTelescopeAt pos tel -- TODO:: tel' defined but not used

      p <- expandLitPattern p

      -- Andreas, 2026-01-20, issue #8327
      -- Exit early when we are checking a let-pattern and encounter a non-record pattern.
      -- This is mainly to serve the correct error message to the user.
      let notRecPat ExceptT TCErr CheckLHSM (LHSState a)
cont = case LetOrClause
mf of
            -- We are checking a let-pattern which only admits record constructors
            LetOrClause
LetLHS -> TypeError -> ExceptT TCErr CheckLHSM (LHSState a)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
ShouldBeRecordPattern
            -- We are checking a clause which allows any kind of pattern.
            ClauseLHS{} -> ExceptT TCErr CheckLHSM (LHSState a)
cont
      let splitOnPat = \case
            (A.LitP PatInfo
_ Literal
l)      -> ExceptT TCErr CheckLHSM (LHSState a)
-> ExceptT TCErr CheckLHSM (LHSState a)
notRecPat (ExceptT TCErr CheckLHSM (LHSState a)
 -> ExceptT TCErr CheckLHSM (LHSState a))
-> ExceptT TCErr CheckLHSM (LHSState a)
-> ExceptT TCErr CheckLHSM (LHSState a)
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term))
-> Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Literal
-> ExceptT TCErr CheckLHSM (LHSState a)
splitLit Tele (Dom (Type'' Term Term))
delta1 Dom (Type'' Term Term)
dom Abs (Tele (Dom (Type'' Term Term)))
adelta2 Literal
l
            p :: Pattern' Expr
p@A.RecP{}        -> Tele (Dom (Type'' Term Term))
-> Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Pattern' Expr
-> Maybe AmbiguousQName
-> ExceptT TCErr CheckLHSM (LHSState a)
splitCon Tele (Dom (Type'' Term Term))
delta1 Dom (Type'' Term Term)
dom Abs (Tele (Dom (Type'' Term Term)))
adelta2 Pattern' Expr
p Maybe AmbiguousQName
forall a. Maybe a
Nothing
            p :: Pattern' Expr
p@(A.ConP ConPatInfo
_ AmbiguousQName
c [Arg (Named_ (Pattern' Expr))]
ps) -> Tele (Dom (Type'' Term Term))
-> Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Pattern' Expr
-> Maybe AmbiguousQName
-> ExceptT TCErr CheckLHSM (LHSState a)
splitCon Tele (Dom (Type'' Term Term))
delta1 Dom (Type'' Term Term)
dom Abs (Tele (Dom (Type'' Term Term)))
adelta2 Pattern' Expr
p (Maybe AmbiguousQName -> ExceptT TCErr CheckLHSM (LHSState a))
-> Maybe AmbiguousQName -> ExceptT TCErr CheckLHSM (LHSState a)
forall a b. (a -> b) -> a -> b
$ AmbiguousQName -> Maybe AmbiguousQName
forall a. a -> Maybe a
Just AmbiguousQName
c
            p :: Pattern' Expr
p@(A.EqualP PatInfo
_ List1 (Expr, Expr)
ts) -> ExceptT TCErr CheckLHSM (LHSState a)
-> ExceptT TCErr CheckLHSM (LHSState a)
notRecPat (ExceptT TCErr CheckLHSM (LHSState a)
 -> ExceptT TCErr CheckLHSM (LHSState a))
-> ExceptT TCErr CheckLHSM (LHSState a)
-> ExceptT TCErr CheckLHSM (LHSState a)
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term))
-> Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> List1 (Expr, Expr)
-> ExceptT TCErr CheckLHSM (LHSState a)
splitPartial Tele (Dom (Type'' Term Term))
delta1 Dom (Type'' Term Term)
dom Abs (Tele (Dom (Type'' Term Term)))
adelta2 List1 (Expr, Expr)
ts
            A.AsP PatInfo
_ BindName
_ Pattern' Expr
p       -> Pattern' Expr -> ExceptT TCErr CheckLHSM (LHSState a)
splitOnPat Pattern' Expr
p

            A.VarP{}        -> ExceptT TCErr CheckLHSM (LHSState a)
forall a. HasCallStack => a
__IMPOSSIBLE__
            A.WildP{}       -> ExceptT TCErr CheckLHSM (LHSState a)
forall a. HasCallStack => a
__IMPOSSIBLE__
            A.DotP{}        -> ExceptT TCErr CheckLHSM (LHSState a)
forall a. HasCallStack => a
__IMPOSSIBLE__
            A.AbsurdP{}     -> ExceptT TCErr CheckLHSM (LHSState a)
forall a. HasCallStack => a
__IMPOSSIBLE__
            A.ProjP{}       -> ExceptT TCErr CheckLHSM (LHSState a)
forall a. HasCallStack => a
__IMPOSSIBLE__
            A.DefP{}        -> ExceptT TCErr CheckLHSM (LHSState a)
forall a. HasCallStack => a
__IMPOSSIBLE__
            A.PatternSynP{} -> ExceptT TCErr CheckLHSM (LHSState a)
forall a. HasCallStack => a
__IMPOSSIBLE__
            A.WithP{}       -> ExceptT TCErr CheckLHSM (LHSState a)
forall a. HasCallStack => a
__IMPOSSIBLE__
      splitOnPat p


    splitRest :: NamedArg A.Pattern -> ExceptT TCErr CheckLHSM (LHSState a)
    splitRest :: Arg (Named_ (Pattern' Expr))
-> ExceptT TCErr CheckLHSM (LHSState a)
splitRest Arg (Named_ (Pattern' Expr))
p = Arg (Named_ (Pattern' Expr))
-> ExceptT TCErr CheckLHSM (LHSState a)
-> ExceptT TCErr CheckLHSM (LHSState a)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Arg (Named_ (Pattern' Expr))
p (ExceptT TCErr CheckLHSM (LHSState a)
 -> ExceptT TCErr CheckLHSM (LHSState a))
-> ExceptT TCErr CheckLHSM (LHSState a)
-> ExceptT TCErr CheckLHSM (LHSState a)
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
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
"splitting problem rest"
        , 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
"projection pattern =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg (Named_ (Pattern' Expr)) -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Arg (Named_ (Pattern' Expr))
p
        , 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
"eliminates type    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg (Type'' Term Term) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Arg (Type'' Term Term) -> m Doc
prettyTCM Arg (Type'' Term Term)
target
        ]
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
80 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
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
        [ 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
$ [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]
"projection pattern (raw) = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Arg (Named_ (Pattern' Expr)) -> [Char]
forall a. Show a => a -> [Char]
show Arg (Named_ (Pattern' Expr))
p
        ]

      -- @p@ should be a projection pattern projection from @target@
      (orig, ambProjName) <- Maybe (ProjOrigin, AmbiguousQName)
-> ((ProjOrigin, AmbiguousQName)
    -> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName))
-> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
-> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
forall a b. Maybe a -> (a -> b) -> b -> b
ifJust (Arg (Named_ (Pattern' Expr)) -> Maybe (ProjOrigin, AmbiguousQName)
forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
A.isProjP Arg (Named_ (Pattern' Expr))
p) (ProjOrigin, AmbiguousQName)
-> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
forall a. a -> ExceptT TCErr CheckLHSM a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
 -> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName))
-> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
-> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term))
-> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
-> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
tel (ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
 -> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName))
-> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
-> ExceptT TCErr CheckLHSM (ProjOrigin, AmbiguousQName)
forall a b. (a -> b) -> a -> b
$ do
        block <- Arg (Type'' Term Term) -> ExceptT TCErr CheckLHSM (Maybe Blocker)
forall t (m :: * -> *).
(Reduce t, IsMeta t, MonadReduce m) =>
t -> m (Maybe Blocker)
isBlocked Arg (Type'' Term Term)
target
        softTypeError $ CannotEliminateWithPattern block p (unArg target)

      (projName, comatchingAllowed, recName, projType, ai) <- suspendErrors $ do
        -- Andreas, 2018-10-18, issue #3289: postfix projections do not have hiding
        -- information for their principal argument; we do not parse @{r}.p@ and the like.
        let h = if ProjOrigin
orig ProjOrigin -> ProjOrigin -> Bool
forall a. Eq a => a -> a -> Bool
== ProjOrigin
ProjPostfix then Maybe Hiding
forall a. Maybe a
Nothing else Hiding -> Maybe Hiding
forall a. a -> Maybe a
Just (Hiding -> Maybe Hiding) -> Hiding -> Maybe Hiding
forall a b. (a -> b) -> a -> b
$ Arg (Named_ (Pattern' Expr)) -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg (Named_ (Pattern' Expr))
p
        addContext tel $ disambiguateProjection h ambProjName target

      unless comatchingAllowed $ do
        hardTypeError $ ComatchingDisabledForRecord recName

      -- Compute the new rest type by applying the projection type to 'self'.
      -- Note: we cannot be in a let binding.
      let f = case LetOrClause
mf of
            LetOrClause
LetLHS -> QName
forall a. HasCallStack => a
__IMPOSSIBLE__
            ClauseLHS QName
x -> QName
x
      let self = QName -> Elims -> Term
Def QName
f (Elims -> Term) -> Elims -> Term
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> Elims
patternsToElims [NamedArg DeBruijnPattern]
ip
      target' <- traverse (`piApplyM` self) projType

      -- Compute the new state
      let projP    = Bool
-> (NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern)
-> NamedArg DeBruijnPattern
-> NamedArg DeBruijnPattern
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen (ProjOrigin
orig ProjOrigin -> ProjOrigin -> Bool
forall a. Eq a => a -> a -> Bool
== ProjOrigin
ProjPostfix) (Hiding -> NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
NotHidden) (NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern)
-> NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern
forall a b. (a -> b) -> a -> b
$
                       ArgInfo
-> Named NamedName DeBruijnPattern -> NamedArg DeBruijnPattern
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
ai (Named NamedName DeBruijnPattern -> NamedArg DeBruijnPattern)
-> Named NamedName DeBruijnPattern -> NamedArg DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ Maybe NamedName
-> DeBruijnPattern -> Named NamedName DeBruijnPattern
forall name a. Maybe name -> a -> Named name a
Named Maybe NamedName
forall a. Maybe a
Nothing (ProjOrigin -> QName -> DeBruijnPattern
forall x. ProjOrigin -> QName -> Pattern' x
ProjP ProjOrigin
orig QName
projName)
          ip'      = [NamedArg DeBruijnPattern]
ip [NamedArg DeBruijnPattern]
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++! [NamedArg DeBruijnPattern
projP]
          -- drop the projection pattern (already splitted)
          problem' = ASetter
  (Problem a)
  (Problem a)
  [Arg (Named_ (Pattern' Expr))]
  [Arg (Named_ (Pattern' Expr))]
-> ([Arg (Named_ (Pattern' Expr))]
    -> [Arg (Named_ (Pattern' Expr))])
-> Problem a
-> Problem a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Problem a)
  (Problem a)
  [Arg (Named_ (Pattern' Expr))]
  [Arg (Named_ (Pattern' Expr))]
forall a (f :: * -> *).
Functor f =>
([Arg (Named_ (Pattern' Expr))]
 -> f [Arg (Named_ (Pattern' Expr))])
-> Problem a -> f (Problem a)
problemRestPats (Int
-> [Arg (Named_ (Pattern' Expr))] -> [Arg (Named_ (Pattern' Expr))]
forall a. Int -> [a] -> [a]
drop Int
1) Problem a
problem
      liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit ixsplit)


    -- Split a Partial.
    --
    -- Example for splitPartial:
    -- @
    --   g : ∀ i j → Partial (i ∨ j) A
    --   g i j (i = 1) = a i j
    --   g i j (j = 1) = b i j
    -- @
    -- leads to, in the first clause:
    -- @
    --   dom   = IsOne (i ∨ j)
    --   ts    = [(i, 1)]
    --   phi   = i
    --   sigma = [1/i]
    -- @
    -- Final clauses:
    -- @
    --   g : ∀ i j → Partial (i ∨ j) A
    --   g 1? j  .itIsOne = a 1 j
    --   g i  1? .itIsOne = b i 1
    -- @
    -- Herein, ? indicates a 'conPFallThrough' pattern.
    --
    -- Example for splitPartial:
    -- @
    --   h : ∀ i j → Partial (i & ¬ j) A
    --   h i j (i = 1) (j = 0)
    --   -- ALT: h i j (i & ¬ j = 1)
    -- @
    -- gives
    -- @
    --   dom = IsOne (i & ¬ j)
    --   ts  = [(i,1), (j,0)]  -- ALT: [(i & ¬ j, 1)]
    --   phi = i & ¬ j
    --   sigma = [1/i,0/j]
    -- @
    --
    -- Example for splitPartial:
    -- @
    --   g : ∀ i j → Partial (i ∨ j) A
    --   g i j (i ∨ j = 1) = a i j
    -- @
    -- leads to, in the first clause:
    -- @
    --   dom   = IsOne (i ∨ j)
    --   ts    = [(i ∨ j, 1)]
    --   phi   = i ∨ j
    --   sigma = fails because several substitutions [[1/i],[1/j]] correspond to phi
    -- @

    splitPartial ::
         Telescope
            -- The types of arguments before the one we split on.
      -> Dom Type
            -- The type of the argument we split on.
      -> Abs Telescope
            -- The types of arguments after the one we split on.
      -> List1 (A.Expr, A.Expr)
            -- [(φ₁ = b1),..,(φn = bn)]
      -> ExceptT TCErr CheckLHSM (LHSState a)

    splitPartial :: Tele (Dom (Type'' Term Term))
-> Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> List1 (Expr, Expr)
-> ExceptT TCErr CheckLHSM (LHSState a)
splitPartial Tele (Dom (Type'' Term Term))
delta1 Dom (Type'' Term Term)
dom Abs (Tele (Dom (Type'' Term Term)))
adelta2 List1 (Expr, Expr)
ts = do

      Bool -> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (Dom (Type'' Term Term) -> Bool
forall t e. Dom' t e -> Bool
domIsFinite Dom (Type'' Term Term)
dom) (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO () -> ExceptT TCErr CheckLHSM ()
forall a. TCM a -> ExceptT TCErr CheckLHSM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> ExceptT TCErr CheckLHSM ())
-> TCMT IO () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term) -> TypeError
SplitOnPartial Dom (Type'' Term Term)
dom

      tInterval <- TCMT IO (Type'' Term Term)
-> ExceptT TCErr CheckLHSM (Type'' Term Term)
forall a. TCM a -> ExceptT TCErr CheckLHSM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (Type'' Term Term)
 -> ExceptT TCErr CheckLHSM (Type'' Term Term))
-> TCMT IO (Type'' Term Term)
-> ExceptT TCErr CheckLHSM (Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m (Type'' Term Term)
primIntervalType

      names <- liftTCM $ addContext tel $ do
        LeftoverPatterns{patternVariables = vars} <- getLeftoverPatterns $ problem ^. problemEqs
        return $! take' (size delta1) $ fst $ getUserVariableNames tel vars

      -- Problem: The context does not match the checkpoints in checkLHS,
      --          however we still need a proper checkpoint substitution
      --          for checkExpr below.
      --
      -- Solution: partial splits are not allowed when there are
      --           constructor patterns (checked in checkDef), so
      --           newContext is an extension of the definition
      --           context.
      --
      -- i.e.: Given
      --
      --             Γ = context where def is checked, also last checkpoint.
      --
      --       Then
      --
      --             newContext = Γ Ξ
      --             cpSub = raiseS |Ξ|
      --
      lhsCxtSize <- asks lhsContextSize -- size of the context before checkLHS call.
      reportSDoc "tc.lhs.split.partial" 10 $ "lhsCxtSize =" <+> prettyTCM lhsCxtSize

      newContext <- liftTCM $ computeLHSContext names delta1
      reportSDoc "tc.lhs.split.partial" 10 $ "newContext =" <+> prettyTCM newContext

      let cpSub = Int -> Substitution
forall a. Int -> Substitution' a
raiseS (Int -> Substitution) -> Int -> Substitution
forall a b. (a -> b) -> a -> b
$ Context -> Int
forall a. Sized a => a -> Int
size Context
newContext Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
lhsCxtSize

      (gamma,sigma) <- liftTCM $ updateContext cpSub (const newContext) $ do
         ts <- forM ts $ \ (Expr
lhs, Expr
rhs) -> do
                 [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"currentCxt =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Context -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Context -> m Doc
prettyTCM (Context -> TCMT IO Doc) -> TCM Context -> TCMT IO Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCM Context
forall (m :: * -> *). MonadTCEnv m => m Context
getContext)
                 [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 (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]
"t, u (Expr) =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Expr, Expr) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => (Expr, Expr) -> m Doc
prettyTCM (Expr
lhs, Expr
rhs)
                 t <- Expr -> Type'' Term Term -> TCMT IO Term
checkExpr Expr
lhs Type'' Term Term
tInterval
                 u <- checkExpr rhs tInterval
                 reportSDoc "tc.lhs.split.partial" 10 $ text "t, u        =" <+> pretty (t, u)
                 reduce u >>= intervalView >>= \case
                   IntervalView
IZero -> TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg TCMT IO Term -> TCMT IO Term -> TCMT IO Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
t
                   IntervalView
IOne  -> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
                   IntervalView
_     -> TypeError -> TCMT IO Term
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO Term) -> TypeError -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ Expr -> TypeError
ExpectedIntervalLiteral Expr
rhs
         -- Example: ts = (i=0) (j=1) will result in phi = ¬ i & j
         phi <- foldl (\ TCMT IO Term
x TCMT IO Term
y -> TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin TCMT IO Term -> TCMT IO Term -> TCMT IO Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term
x TCMT IO Term -> TCMT IO Term -> TCMT IO Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term
y) primIOne (fmap pure ts)
         reportSDoc "tc.lhs.split.partial" 10 $ text "phi           =" <+> prettyTCM phi
         reportSDoc "tc.lhs.split.partial" 30 $ text "phi           =" <+> pretty phi
         phi <- reduce phi
         reportSDoc "tc.lhs.split.partial" 10 $ text "phi (reduced) =" <+> prettyTCM phi
         refined <- forallFaceMaps phi (\ IntMap Bool
bs Blocker
m Term
t -> Blocker -> TCM (Tele (Dom (Type'' Term Term)), Substitution)
forall a. Blocker -> TCMT IO a
forall (m :: * -> *) a. MonadBlock m => Blocker -> m a
patternViolation Blocker
m)
                            (\IntMap Bool
_ Substitution
sigma -> (,Substitution
sigma) (Tele (Dom (Type'' Term Term))
 -> (Tele (Dom (Type'' Term Term)), Substitution))
-> TCMT IO (Tele (Dom (Type'' Term Term)))
-> TCM (Tele (Dom (Type'' Term Term)), Substitution)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO (Tele (Dom (Type'' Term Term)))
forall (m :: * -> *).
MonadTCEnv m =>
m (Tele (Dom (Type'' Term Term)))
getContextTelescope)
         case refined of
           [(Tele (Dom (Type'' Term Term))
gamma,Substitution
sigma)] -> (Tele (Dom (Type'' Term Term)), Substitution)
-> TCM (Tele (Dom (Type'' Term Term)), Substitution)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tele (Dom (Type'' Term Term))
gamma,Substitution
sigma)
           []              -> TypeError -> TCM (Tele (Dom (Type'' Term Term)), Substitution)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
FaceConstraintUnsatisfiable
           [(Tele (Dom (Type'' Term Term)), Substitution)]
_               -> TypeError -> TCM (Tele (Dom (Type'' Term Term)), Substitution)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
FaceConstraintDisjunction
      itisone <- liftTCM primItIsOne
      -- substitute the literal in p1 and dpi
      reportSDoc "tc.lhs.faces" 60 $ text $ show sigma

      let oix = Abs (Tele (Dom (Type'' Term Term))) -> Int
forall a. Sized a => a -> Int
size Abs (Tele (Dom (Type'' Term Term)))
adelta2 -- de brujin index of IsOne
          o_n = 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
$
            (NamedArg DeBruijnPattern -> Bool)
-> [NamedArg DeBruijnPattern] -> Maybe Int
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\ NamedArg DeBruijnPattern
x -> case Named NamedName DeBruijnPattern -> DeBruijnPattern
forall name a. Named name a -> a
namedThing (NamedArg DeBruijnPattern -> Named NamedName DeBruijnPattern
forall e. Arg e -> e
unArg NamedArg DeBruijnPattern
x) of
                                   VarP PatternInfo
_ DBPatVar
x -> DBPatVar -> Int
dbPatVarIndex DBPatVar
x Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
oix
                                   DeBruijnPattern
_        -> Bool
False) [NamedArg DeBruijnPattern]
ip
          delta2' = Abs (Tele (Dom (Type'' Term Term)))
-> SubstArg (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs (Tele (Dom (Type'' Term Term)))
adelta2 Term
SubstArg (Tele (Dom (Type'' Term Term)))
itisone
          delta2 = Substitution' (SubstArg (Tele (Dom (Type'' Term Term))))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg (Tele (Dom (Type'' Term Term))))
sigma Tele (Dom (Type'' Term Term))
delta2'
          mkConP (Con ConHead
c ConInfo
_ [])
             = ConHead
-> ConPatternInfo -> [NamedArg DeBruijnPattern] -> DeBruijnPattern
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c (ConPatternInfo
noConPatternInfo { conPType = Just (Arg defaultArgInfo tInterval)
                                              , conPFallThrough = True })
                          []
          mkConP (Var Int
i []) = PatternInfo -> DBPatVar -> DeBruijnPattern
forall x. PatternInfo -> x -> Pattern' x
VarP PatternInfo
defaultPatternInfo ([Char] -> Int -> DBPatVar
DBPatVar [Char]
"x" Int
i)
          mkConP Term
_          = DeBruijnPattern
forall a. HasCallStack => a
__IMPOSSIBLE__
          rho0 = (Term -> DeBruijnPattern)
-> Substitution -> Substitution' DeBruijnPattern
forall a b. (a -> b) -> Substitution' a -> Substitution' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> DeBruijnPattern
mkConP Substitution
sigma

          rho    = Int
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. Int -> Substitution' a -> Substitution' a
liftS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
delta2) (Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern)
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ DeBruijnPattern
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS (PatternInfo -> Term -> DeBruijnPattern
forall x. PatternInfo -> Term -> Pattern' x
DotP PatternInfo
defaultPatternInfo Term
itisone) Substitution' DeBruijnPattern
rho0

          delta'   = Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
gamma Tele (Dom (Type'' Term Term))
delta2
          eqs'     = Substitution' DeBruijnPattern -> [ProblemEq] -> [ProblemEq]
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a
-> Getting [ProblemEq] (Problem a) [ProblemEq] -> [ProblemEq]
forall s a. s -> Getting a s a -> a
^. Getting [ProblemEq] (Problem a) [ProblemEq]
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs
          ip'      = Substitution' (SubstArg [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' DeBruijnPattern
Substitution' (SubstArg [NamedArg DeBruijnPattern])
rho [NamedArg DeBruijnPattern]
ip
          target'  = Substitution' DeBruijnPattern
-> Arg (Type'' Term Term) -> Arg (Type'' Term Term)
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Arg (Type'' Term Term)
target

      -- Compute the new state
      let problem' = ASetter (Problem a) (Problem a) [ProblemEq] [ProblemEq]
-> [ProblemEq] -> Problem a -> Problem a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Problem a) (Problem a) [ProblemEq] [ProblemEq]
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs [ProblemEq]
eqs' Problem a
problem
      reportSDoc "tc.lhs.split.partial" 60 $ text (show problem')
      liftTCM $ updateLHSState (LHSState delta' ip' problem' target' (psplit ++! [Just o_n]) ixsplit)


    splitLit :: Telescope      -- The types of arguments before the one we split on
             -> Dom Type       -- The type of the literal we split on
             -> Abs Telescope  -- The types of arguments after the one we split on
             -> Literal        -- The literal written by the user
             -> ExceptT TCErr CheckLHSM (LHSState a)
    splitLit :: Tele (Dom (Type'' Term Term))
-> Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Literal
-> ExceptT TCErr CheckLHSM (LHSState a)
splitLit Tele (Dom (Type'' Term Term))
delta1 dom :: Dom (Type'' Term Term)
dom@(Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> Type'' Term Term
a) Abs (Tele (Dom (Type'' Term Term)))
adelta2 Literal
lit = do
      let info :: ArgInfo
info = Dom (Type'' Term Term)
dom Dom (Type'' Term Term)
-> Getting ArgInfo (Dom (Type'' Term Term)) ArgInfo -> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo
      let delta2 :: Tele (Dom (Type'' Term Term))
delta2 = Abs (Tele (Dom (Type'' Term Term)))
-> SubstArg (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs (Tele (Dom (Type'' Term Term)))
adelta2 (Literal -> Term
Lit Literal
lit)
          delta' :: Tele (Dom (Type'' Term Term))
delta' = Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
abstract Tele (Dom (Type'' Term Term))
delta1 Tele (Dom (Type'' Term Term))
delta2
          rho :: Substitution' DeBruijnPattern
rho    = Int -> DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. DeBruijn a => Int -> a -> Substitution' a
singletonS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
delta2) (Literal -> DeBruijnPattern
forall a. Literal -> Pattern' a
litP Literal
lit)
          -- Andreas, 2015-06-13 Literals are closed, so no need to raise them!
          -- rho    = liftS (size delta2) $ singletonS 0 (Lit lit)
          -- rho    = [ var i | i <- [0..size delta2 - 1] ]
          --       ++! [ raise (size delta2) $ Lit lit ]
          --       ++! [ var i | i <- [size delta2 ..] ]
          eqs' :: [ProblemEq]
eqs'     = Substitution' DeBruijnPattern -> [ProblemEq] -> [ProblemEq]
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a
-> Getting [ProblemEq] (Problem a) [ProblemEq] -> [ProblemEq]
forall s a. s -> Getting a s a -> a
^. Getting [ProblemEq] (Problem a) [ProblemEq]
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs
          ip' :: [NamedArg DeBruijnPattern]
ip'      = Substitution' (SubstArg [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' DeBruijnPattern
Substitution' (SubstArg [NamedArg DeBruijnPattern])
rho [NamedArg DeBruijnPattern]
ip
          target' :: Arg (Type'' Term Term)
target'  = Substitution' DeBruijnPattern
-> Arg (Type'' Term Term) -> Arg (Type'' Term Term)
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Arg (Type'' Term Term)
target

      -- Andreas, 2010-09-07 cannot split on irrelevant args
      Bool -> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (ArgInfo -> Bool
forall a. LensRelevance a => a -> Bool
usableRelevance ArgInfo
info) (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$
        Tele (Dom (Type'' Term Term))
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ TypeError -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr CheckLHSM ())
-> TypeError -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term) -> TypeError
SplitOnIrrelevant Dom (Type'' Term Term)
dom

      -- Andreas, 2018-10-17, we can however split on erased things
      -- if there is a single constructor (checked in Coverage).
      --
      -- Thus, no checking of (usableQuantity info) here.

      ExceptT TCErr CheckLHSM Bool
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (ArgInfo -> ExceptT TCErr CheckLHSM Bool
forall (m :: * -> *) a.
(HasOptions m, LensCohesion a) =>
a -> m Bool
splittableCohesion ArgInfo
info) (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$
        Tele (Dom (Type'' Term Term))
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ TypeError -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr CheckLHSM ())
-> TypeError -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term) -> TypeError
SplitOnUnusableCohesion Dom (Type'' Term Term)
dom

      Bool -> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (PolarityModality -> Bool
forall a. LensModalPolarity a => a -> Bool
splittablePolarity (ArgInfo -> PolarityModality
forall a. LensModalPolarity a => a -> PolarityModality
getModalPolarity ArgInfo
info)) (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$
        Tele (Dom (Type'' Term Term))
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ TypeError -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr CheckLHSM ())
-> TypeError -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term) -> TypeError
SplitOnUnusablePolarity Dom (Type'' Term Term)
dom

      -- check that a is indeed the type of lit (otherwise fail softly)
      -- if not, fail softly since it could be instantiated by a later split.
      TCMT IO () -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors (TCMT IO () -> ExceptT TCErr CheckLHSM ())
-> TCMT IO () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Type'' Term Term -> Type'' Term Term -> TCMT IO ()
equalType Type'' Term Term
a (Type'' Term Term -> TCMT IO ())
-> TCMT IO (Type'' Term Term) -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Literal -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
Literal -> m (Type'' Term Term)
litType Literal
lit

      -- Compute the new state
      let problem' :: Problem a
problem' = ASetter (Problem a) (Problem a) [ProblemEq] [ProblemEq]
-> [ProblemEq] -> Problem a -> Problem a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Problem a) (Problem a) [ProblemEq] [ProblemEq]
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs [ProblemEq]
eqs' Problem a
problem
      TCM (LHSState a) -> ExceptT TCErr CheckLHSM (LHSState a)
forall a. TCM a -> ExceptT TCErr CheckLHSM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (LHSState a) -> ExceptT TCErr CheckLHSM (LHSState a))
-> TCM (LHSState a) -> ExceptT TCErr CheckLHSM (LHSState a)
forall a b. (a -> b) -> a -> b
$ LHSState a -> TCM (LHSState a)
forall a. LHSState a -> TCM (LHSState a)
updateLHSState (Tele (Dom (Type'' Term Term))
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg (Type'' Term Term)
-> [Maybe Int]
-> Bool
-> LHSState a
forall a.
Tele (Dom (Type'' Term Term))
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg (Type'' Term Term)
-> [Maybe Int]
-> Bool
-> LHSState a
LHSState Tele (Dom (Type'' Term Term))
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg (Type'' Term Term)
target' [Maybe Int]
psplit Bool
ixsplit)


    splitCon :: Telescope      -- The types of arguments before the one we split on
             -> Dom Type       -- The type of the constructor we split on
             -> Abs Telescope  -- The types of arguments after the one we split on
             -> A.Pattern      -- The pattern written by the user
             -> Maybe AmbiguousQName  -- @Just c@ for a (possibly ambiguous) constructor @c@, or
                                      -- @Nothing@ for a record pattern
             -> ExceptT TCErr CheckLHSM (LHSState a)
    splitCon :: Tele (Dom (Type'' Term Term))
-> Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> Pattern' Expr
-> Maybe AmbiguousQName
-> ExceptT TCErr CheckLHSM (LHSState a)
splitCon Tele (Dom (Type'' Term Term))
delta1 dom :: Dom (Type'' Term Term)
dom@(Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom -> Type'' Term Term
a) Abs (Tele (Dom (Type'' Term Term)))
adelta2 Pattern' Expr
focusPat Maybe AmbiguousQName
ambC = do
      let info :: ArgInfo
info = Dom (Type'' Term Term)
dom Dom (Type'' Term Term)
-> Getting ArgInfo (Dom (Type'' Term Term)) ArgInfo -> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom (Type'' Term Term)) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo
      let delta2 :: Tele (Dom (Type'' Term Term))
delta2 = Abs (Tele (Dom (Type'' Term Term)))
-> Tele (Dom (Type'' Term Term))
forall a. Subst a => Abs a -> a
absBody Abs (Tele (Dom (Type'' Term Term)))
adelta2

      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
10 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
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 lhs"
        , 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
"tel =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
tel
        , 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
"rel =" 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 (Relevance -> [Char]
forall a. Show a => a -> [Char]
show (Relevance -> [Char]) -> Relevance -> [Char]
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance ArgInfo
info)
        , 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
"mod =" 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 (Modality -> [Char]
forall a. Show a => a -> [Char]
show (Modality -> [Char]) -> Modality -> [Char]
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Modality
forall a. LensModality a => a -> Modality
getModality  ArgInfo
info)
        ]

      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
15 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
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
"split problem"
        , 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
"delta1 = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
delta1
          , TCMT IO Doc
"a      = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
a)
          , TCMT IO Doc
"delta2 = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1
                              (([Char], Dom (Type'' Term Term)) -> 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], Dom (Type'' Term Term)) -> m a -> m a
addContext ([Char]
"x" :: String, Dom (Type'' Term Term)
dom) (Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
delta2))
          ]
        ]

      -- We cannot split on (shape-)irrelevant arguments.
      [Char] -> Int -> [Char] -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.lhs.split" Int
30 ([Char] -> ExceptT TCErr CheckLHSM ())
-> [Char] -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ [Char]
"split ConP: relevance is " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++! Relevance -> [Char]
forall a. Show a => a -> [Char]
show (ArgInfo -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance ArgInfo
info)
      Bool -> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (ArgInfo -> Bool
forall a. LensRelevance a => a -> Bool
usableRelevance ArgInfo
info) (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term))
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$
        TypeError -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr CheckLHSM ())
-> TypeError -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term) -> TypeError
SplitOnIrrelevant Dom (Type'' Term Term)
dom

      -- Andreas, 2018-10-17, we can however split on erased things
      -- if there is a single constructor (checked in Coverage).
      --
      -- Thus, no checking of (usableQuantity info) here.

      ExceptT TCErr CheckLHSM Bool
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (ArgInfo -> ExceptT TCErr CheckLHSM Bool
forall (m :: * -> *) a.
(HasOptions m, LensCohesion a) =>
a -> m Bool
splittableCohesion ArgInfo
info) (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$
        Tele (Dom (Type'' Term Term))
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ TypeError -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr CheckLHSM ())
-> TypeError -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term) -> TypeError
SplitOnUnusableCohesion Dom (Type'' Term Term)
dom

      Bool -> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (PolarityModality -> Bool
forall a. LensModalPolarity a => a -> Bool
splittablePolarity (ArgInfo -> PolarityModality
forall a. LensModalPolarity a => a -> PolarityModality
getModalPolarity ArgInfo
info)) (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$
        Tele (Dom (Type'' Term Term))
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ TypeError -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr CheckLHSM ())
-> TypeError -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Dom (Type'' Term Term) -> TypeError
SplitOnUnusablePolarity Dom (Type'' Term Term)
dom

      -- 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 genTrx :: Maybe NoLeftInv
genTrx = 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

      -- We should be at a data/record type
      (dr, d, s, pars, ixs) <- Tele (Dom (Type'' Term Term))
-> ExceptT
     TCErr
     CheckLHSM
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
-> ExceptT
     TCErr
     CheckLHSM
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom (Type'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1 (ExceptT
   TCErr
   CheckLHSM
   (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
 -> ExceptT
      TCErr
      CheckLHSM
      (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT
     TCErr
     CheckLHSM
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
-> ExceptT
     TCErr
     CheckLHSM
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a b. (a -> b) -> a -> b
$ Type'' Term Term
-> ExceptT
     TCErr
     CheckLHSM
     (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *).
(MonadTCM m, PureTCM m) =>
Type'' Term Term
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
isDataOrRecordType Type'' Term Term
a
      let isRec = case DataOrRecord
dr of
            IsData{}   -> Bool
False
            IsRecord{} -> Bool
True

      checkMatchingAllowed mf d dr  -- No splitting on e.g. coinductive constructors.

      -- Issue #7503: use principal sort for checking if split is ok
      let a' = ASetter
  (Type'' Term Term) (Type'' Term Term) (Sort' Term) (Sort' Term)
-> Sort' Term -> Type'' Term Term -> Type'' Term Term
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter
  (Type'' Term Term) (Type'' Term Term) (Sort' Term) (Sort' Term)
forall a. LensSort a => Lens' a (Sort' Term)
Lens' (Type'' Term Term) (Sort' Term)
lensSort Sort' Term
s Type'' Term Term
a
      addContext delta1 $ checkSortOfSplitVar dr a' delta2 (Just target)

      -- Jesper, 2019-09-13: if the data type we split on is a strict
      -- set, we locally enable --with-K during unification.
      withKIfStrict <- reduce (getSort a) <&> \ Sort' Term
dsort ->
        Bool
-> (TCMT IO UnificationResult -> TCMT IO UnificationResult)
-> TCMT IO UnificationResult
-> TCMT IO UnificationResult
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen (Sort' Term -> Bool
forall t. Sort' t -> Bool
isStrictDataSort Sort' Term
dsort) ((TCMT IO UnificationResult -> TCMT IO UnificationResult)
 -> TCMT IO UnificationResult -> TCMT IO UnificationResult)
-> (TCMT IO UnificationResult -> TCMT IO UnificationResult)
-> TCMT IO UnificationResult
-> TCMT IO UnificationResult
forall a b. (a -> b) -> a -> b
$ Lens' TCEnv Bool
-> (Bool -> Bool)
-> TCMT IO UnificationResult
-> TCMT IO UnificationResult
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)
 -> TCMT IO UnificationResult -> TCMT IO UnificationResult)
-> (Bool -> Bool)
-> TCMT IO UnificationResult
-> TCMT IO UnificationResult
forall a b. (a -> b) -> a -> b
$ Bool -> Bool -> Bool
forall a b. a -> b -> a
const Bool
True

      -- The constructor should construct an element of this datatype
      (c :: ConHead, b :: Type) <- liftTCM $ addContext delta1 $ case ambC of
        Just AmbiguousQName
ambC -> AmbiguousQName
-> QName -> [Arg Term] -> TCM (ConHead, Type'' Term Term)
disambiguateConstructor AmbiguousQName
ambC QName
d [Arg Term]
pars
        Maybe AmbiguousQName
Nothing   -> QName
-> [Arg Term]
-> Type'' Term Term
-> TCM (ConHead, Type'' Term Term)
getRecordConstructor QName
d [Arg Term]
pars Type'' Term Term
a

      -- Don't split on lazy (non-eta) constructor
      case focusPat of
        A.ConP ConPatInfo
cpi AmbiguousQName
_ [Arg (Named_ (Pattern' Expr))]
_ | ConPatInfo -> ConPatLazy
A.conPatLazy ConPatInfo
cpi ConPatLazy -> ConPatLazy -> Bool
forall a. Eq a => a -> a -> Bool
== ConPatLazy
A.ConPatLazy ->
          ExceptT TCErr CheckLHSM Bool
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (QName -> ExceptT TCErr CheckLHSM Bool
forall (m :: * -> *).
(HasCallStack, HasConstInfo m) =>
QName -> m Bool
isEtaRecord QName
d) (ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ())
-> ExceptT TCErr CheckLHSM () -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ TypeError -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr CheckLHSM ())
-> TypeError -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Pattern' Expr -> TypeError
ForcedConstructorNotInstantiated Pattern' Expr
focusPat
        Pattern' Expr
_ -> () -> ExceptT TCErr CheckLHSM ()
forall a. a -> ExceptT TCErr CheckLHSM a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

      -- The type of the constructor will end in an application of the datatype
      (TelV gamma (El _ ctarget), boundary) <- liftTCM $ telViewPathBoundary b
      let Def d' es' = ctarget
          cixs = 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] -> [Arg Term]) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$ Elims -> [Arg Term]
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims Elims
es'

      -- Δ₁Γ ⊢ boundary
      reportSDoc "tc.lhs.split.con" 50 $ text "  boundary = " <+> prettyTCM boundary

      unless (d == d') {-'-} __IMPOSSIBLE__

      -- Get names for the constructor arguments from the user patterns
      gamma <- liftTCM $ case focusPat of
        A.ConP ConPatInfo
_ AmbiguousQName
_ [Arg (Named_ (Pattern' Expr))]
ps -> do
          ps <- ExpandHidden
-> [Arg (Named_ (Pattern' Expr))]
-> Tele (Dom (Type'' Term Term))
-> TCMT IO [Arg (Named_ (Pattern' Expr))]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
 MonadTrace m) =>
ExpandHidden
-> [Arg (Named_ (Pattern' Expr))]
-> Tele (Dom (Type'' Term Term))
-> m [Arg (Named_ (Pattern' Expr))]
insertImplicitPatterns ExpandHidden
ExpandLast [Arg (Named_ (Pattern' Expr))]
ps Tele (Dom (Type'' Term Term))
gamma
          return $ useNamesFromPattern ps gamma
        A.RecP KwRange
_ ConPatInfo
_ [FieldAssignment' (Pattern' Expr)]
fs -> do
          RecordDefn def <- Definition -> Defn
theDef (Definition -> Defn) -> TCMT IO Definition -> TCMT IO Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
d
          let axs = (Dom Name -> Arg Name) -> [Dom Name] -> [Arg Name]
forall a b. (a -> b) -> [a] -> [b]
map' Dom Name -> Arg Name
forall t a. Dom' t a -> Arg a
argFromDom ([Dom Name] -> [Arg Name]) -> [Dom Name] -> [Arg Name]
forall a b. (a -> b) -> a -> b
$ RecordData -> [Dom Name]
recordFieldNames RecordData
def
          ps <- insertMissingFieldsFail ConORec d (const $ A.WildP empty) fs axs
          ps <- insertImplicitPatterns ExpandLast ps gamma
          return $ useNamesFromPattern ps gamma
        Pattern' Expr
_ -> TCMT IO (Tele (Dom (Type'' Term Term)))
forall a. HasCallStack => a
__IMPOSSIBLE__

      -- Andreas 2010-09-07  propagate relevance info to new vars
      -- Andreas 2018-10-17  propagate modality
      let updMod = Modality -> Modality -> Modality
composeModality (ArgInfo -> Modality
forall a. LensModality a => a -> Modality
getModality ArgInfo
info)
      gamma <- return $ mapModality updMod <$> gamma

      -- Get the type of the datatype.
      da <- (`piApply` pars) . defType <$> getConstInfo d
      reportSDoc "tc.lhs.split" 30 $ "  da = " <+> prettyTCM da

      reportSDoc "tc.lhs.top" 15 $ addContext delta1 $
        sep [ "preparing to unify"
            , nest 2 $ vcat
              [ "c      =" <+> prettyTCM c <+> ":" <+> prettyTCM b
              , "d      =" <+> prettyTCM (Def d (map' Apply pars)) <+> ":" <+> prettyTCM da
              , "isRec  =" <+> (text . show) isRec
              , "gamma  =" <+> prettyTCM gamma
              , "pars   =" <+> brackets (fsep $ punctuate comma $ map' prettyTCM pars)
              , "ixs    =" <+> brackets (fsep $ punctuate comma $ map' prettyTCM ixs)
              , "cixs   =" <+> addContext gamma (brackets (fsep $ punctuate comma $ map' prettyTCM cixs))
              ]
            ]
                 -- We ignore forcing for make-case
      cforced <- ifM (viewTC eMakeCase) (return []) $
                 {-else-} defForced <$> getConstInfo (conName c)

      let delta1Gamma = Tele (Dom (Type'' Term Term))
delta1 Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
`abstract` Tele (Dom (Type'' Term Term))
gamma
          da'  = Int -> Type'' Term Term -> Type'' Term Term
forall a. Subst a => Int -> a -> a
raise (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma) Type'' Term Term
da
          ixs' = Int -> [Arg Term] -> [Arg Term]
forall a. Subst a => Int -> a -> a
raise (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma) [Arg Term]
ixs
          -- Variables in Δ₁ are not forced, since the unifier takes care to not introduce forced
          -- variables.
          forced = Int -> IsForced -> [IsForced]
forall a. Int -> a -> [a]
replicate (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
delta1) IsForced
NotForced [IsForced] -> [IsForced] -> [IsForced]
forall a. [a] -> [a] -> [a]
++! [IsForced]
cforced

      -- All variables are flexible.
      let flex = [IsForced] -> Tele (Dom (Type'' Term Term)) -> FlexibleVars
allFlexVars [IsForced]
forced (Tele (Dom (Type'' Term Term)) -> FlexibleVars)
-> Tele (Dom (Type'' Term Term)) -> FlexibleVars
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term))
delta1Gamma

      -- Unify constructor target and given type (in Δ₁Γ)
      -- Given: Δ₁  ⊢ D pars : Φ → Setᵢ
      --        Δ₁  ⊢ c      : Γ → D pars cixs
      --        Δ₁  ⊢ ixs    : Φ
      --        Δ₁Γ ⊢ cixs   : Φ
      -- unification of ixs and cixs in context Δ₁Γ gives us a telescope Δ₁'
      -- and a substitution ρ₀ such that
      --        Δ₁' ⊢ ρ₀ : Δ₁Γ
      --        Δ₁' ⊢ (ixs)ρ₀ ≡ (cixs)ρ₀ : Φρ₀
      -- We can split ρ₀ into two parts ρ₁ and ρ₂, giving
      --        Δ₁' ⊢ ρ₁ : Δ₁
      --        Δ₁' ⊢ ρ₂ : Γρ₁
      -- Application of the constructor c gives
      --        Δ₁' ⊢ (c Γ)(ρ₀) : (D pars cixs)(ρ₁;ρ₂)
      -- We have
      --        cixs(ρ₁;ρ₂)
      --         ≡ cixs(ρ₀)   (since ρ₀=ρ₁;ρ₂)
      --         ≡ ixs(ρ₀)    (by unification)
      --         ≡ ixs(ρ₁)    (since ixs doesn't actually depend on Γ)
      -- so     Δ₁' ⊢ (c Γ)(ρ₀) : (D pars ixs)ρ₁
      -- Putting this together with ρ₁ gives ρ₃ = ρ₁;c ρ₂
      --        Δ₁' ⊢ ρ₁;(c Γ)(ρ₀) : Δ₁(x : D vs ws)
      -- and lifting over Δ₂ gives the final substitution ρ = ρ₃;Δ₂
      -- from Δ' = Δ₁';Δ₂ρ₃
      --        Δ' ⊢ ρ : Δ₁(x : D vs ws)Δ₂

      -- Andrea 2019-07-17 propagate the Cohesion to the equation telescope
      -- TODO: should we propagate the modality in general?
      -- See also Coverage checking.
      da' <- addContext delta1Gamma $ do
             let updCoh = Cohesion -> Cohesion -> Cohesion
composeCohesion (ArgInfo -> Cohesion
forall a. LensCohesion a => a -> Cohesion
getCohesion ArgInfo
info)
             TelV tel dt <- telView da'
             return $ abstract (mapCohesion updCoh <$> tel) dt

      let stuck Maybe Blocker
b [UnificationFailure]
errs = TypeError -> ExceptT TCErr CheckLHSM (LHSState a)
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr CheckLHSM (LHSState a))
-> TypeError -> ExceptT TCErr CheckLHSM (LHSState a)
forall a b. (a -> b) -> a -> b
$ SplitError -> TypeError
SplitError (SplitError -> TypeError) -> SplitError -> TypeError
forall a b. (a -> b) -> a -> b
$
            Maybe Blocker
-> QName
-> Tele (Dom (Type'' Term Term))
-> [Arg Term]
-> [Arg Term]
-> [UnificationFailure]
-> SplitError
UnificationStuck Maybe Blocker
b (ConHead -> QName
conName ConHead
c) (Tele (Dom (Type'' Term Term))
delta1 Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
`abstract` Tele (Dom (Type'' Term Term))
gamma) [Arg Term]
cixs [Arg Term]
ixs' [UnificationFailure]
errs

      liftTCM (withKIfStrict $ unifyIndices genTrx delta1Gamma flex da' cixs ixs') >>= \case

        -- Mismatch.  Report and abort.
        NoUnify NegativeUnification
neg -> TypeError -> ExceptT TCErr CheckLHSM (LHSState a)
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr CheckLHSM (LHSState a))
-> TypeError -> ExceptT TCErr CheckLHSM (LHSState a)
forall a b. (a -> b) -> a -> b
$ QName -> NegativeUnification -> TypeError
ImpossibleConstructor (ConHead -> QName
conName ConHead
c) NegativeUnification
neg

        UnifyBlocked Blocker
block -> Maybe Blocker
-> [UnificationFailure] -> ExceptT TCErr CheckLHSM (LHSState a)
stuck (Blocker -> Maybe Blocker
forall a. a -> Maybe a
Just Blocker
block) []

        -- Unclear situation.  Try next split.
        UnifyStuck [UnificationFailure]
errs -> Maybe Blocker
-> [UnificationFailure] -> ExceptT TCErr CheckLHSM (LHSState a)
stuck Maybe Blocker
forall a. Maybe a
Nothing [UnificationFailure]
errs

        -- Success.
        Unifies (Tele (Dom (Type'' Term Term))
delta1',Substitution' DeBruijnPattern
rho0,[NamedArg DeBruijnPattern]
es) -> do

          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
15 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"unification successful"
          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
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
"delta1' =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
delta1'
            , TCMT IO Doc
"rho0    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1' (Substitution' DeBruijnPattern -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Substitution' DeBruijnPattern -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho0)
            , TCMT IO Doc
"es      =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1' ([Arg (Named NamedName Term)] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
[Arg (Named NamedName Term)] -> m Doc
prettyTCM ([Arg (Named NamedName Term)] -> TCMT IO Doc)
-> [Arg (Named NamedName Term)] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ ((NamedArg DeBruijnPattern -> Arg (Named NamedName Term))
-> [NamedArg DeBruijnPattern] -> [Arg (Named NamedName Term)]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NamedArg DeBruijnPattern -> Arg (Named NamedName Term))
 -> [NamedArg DeBruijnPattern] -> [Arg (Named NamedName Term)])
-> ((DeBruijnPattern -> Term)
    -> NamedArg DeBruijnPattern -> Arg (Named NamedName Term))
-> (DeBruijnPattern -> Term)
-> [NamedArg DeBruijnPattern]
-> [Arg (Named NamedName Term)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named NamedName DeBruijnPattern -> Named NamedName Term)
-> NamedArg DeBruijnPattern -> Arg (Named NamedName Term)
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named NamedName DeBruijnPattern -> Named NamedName Term)
 -> NamedArg DeBruijnPattern -> Arg (Named NamedName Term))
-> ((DeBruijnPattern -> Term)
    -> Named NamedName DeBruijnPattern -> Named NamedName Term)
-> (DeBruijnPattern -> Term)
-> NamedArg DeBruijnPattern
-> Arg (Named NamedName Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijnPattern -> Term)
-> Named NamedName DeBruijnPattern -> Named NamedName Term
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm [NamedArg DeBruijnPattern]
es)
            ]

          -- split substitution into part for Δ₁ and part for Γ
          let (Substitution' DeBruijnPattern
rho1,Substitution' DeBruijnPattern
rho2) = Int
-> Substitution' DeBruijnPattern
-> (Substitution' DeBruijnPattern, Substitution' DeBruijnPattern)
forall a.
Int -> Substitution' a -> (Substitution' a, Substitution' a)
splitS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
gamma) Substitution' DeBruijnPattern
rho0

          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1' (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
"rho1    =" 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 a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Substitution' DeBruijnPattern -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho1
            , TCMT IO Doc
"rho2    =" 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 a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Substitution' DeBruijnPattern -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho2
            ]

          -- Andreas, 2010-09-09, save the type.
          -- It is relative to Δ₁, but it should be relative to Δ₁'
          let a' :: Type'' Term Term
a' = Substitution' DeBruijnPattern
-> Type'' Term Term -> Type'' Term Term
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho1 Type'' Term Term
a

          -- Also remember if we are a record pattern.
          let cpi :: ConPatternInfo
cpi = ConPatternInfo { conPInfo :: PatternInfo
conPInfo   = PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatOCon []
                                   , conPRecord :: Bool
conPRecord = Bool
isRec
                                   , conPFallThrough :: Bool
conPFallThrough = Bool
False
                                   , conPType :: Maybe (Arg (Type'' Term Term))
conPType   = Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term))
forall a. a -> Maybe a
Just (Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term)))
-> Arg (Type'' Term Term) -> Maybe (Arg (Type'' Term Term))
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Type'' Term Term -> Arg (Type'' Term Term)
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info Type'' Term Term
a'
                                   , conPLazy :: Bool
conPLazy   = Bool
False } -- Don't mark eta-record matches as lazy (#4254)

          -- compute final context and substitution
          let crho :: DeBruijnPattern
crho    = ConHead
-> ConPatternInfo -> [NamedArg DeBruijnPattern] -> DeBruijnPattern
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c ConPatternInfo
cpi ([NamedArg DeBruijnPattern] -> DeBruijnPattern)
-> [NamedArg DeBruijnPattern] -> DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ Substitution' (SubstArg [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' DeBruijnPattern
Substitution' (SubstArg [NamedArg DeBruijnPattern])
rho0 ([NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ (Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [NamedArg DeBruijnPattern]
forall a.
DeBruijn a =>
Tele (Dom (Type'' Term Term))
-> Boundary' Int Term -> [NamedArg (Pattern' a)]
telePatterns Tele (Dom (Type'' Term Term))
gamma Boundary' Int Term
boundary)
              rho3 :: Substitution' DeBruijnPattern
rho3    = DeBruijnPattern
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS DeBruijnPattern
crho Substitution' DeBruijnPattern
rho1
              delta2' :: Tele (Dom (Type'' Term Term))
delta2' = Substitution' DeBruijnPattern
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho3 Tele (Dom (Type'' Term Term))
delta2
              delta' :: Tele (Dom (Type'' Term Term))
delta'  = Tele (Dom (Type'' Term Term))
delta1' Tele (Dom (Type'' Term Term))
-> Tele (Dom (Type'' Term Term)) -> Tele (Dom (Type'' Term Term))
forall t. Abstract t => Tele (Dom (Type'' Term Term)) -> t -> t
`abstract` Tele (Dom (Type'' Term Term))
delta2'
              rho :: Substitution' DeBruijnPattern
rho     = Int
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. Int -> Substitution' a -> Substitution' a
liftS (Tele (Dom (Type'' Term Term)) -> Int
forall a. Sized a => a -> Int
size Tele (Dom (Type'' Term Term))
delta2) Substitution' DeBruijnPattern
rho3

          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1' (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
"crho    =" 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 DeBruijnPattern
crho
            , TCMT IO Doc
"rho3    =" 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 a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Substitution' DeBruijnPattern -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho3
            , TCMT IO Doc
"delta2' =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
delta2'
            ]
          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
70 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta1' (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
"crho    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> DeBruijnPattern -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty DeBruijnPattern
crho
            , TCMT IO Doc
"rho3    =" 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
rho3
            , TCMT IO Doc
"delta2' =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Tele (Dom (Type'' Term Term))
delta2'
            ]

          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
15 (TCMT IO Doc -> ExceptT TCErr CheckLHSM ())
-> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
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
"delta'  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Tele (Dom (Type'' Term Term)) -> m Doc
prettyTCM Tele (Dom (Type'' Term Term))
delta'
            , TCMT IO Doc
"rho     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom (Type'' Term Term)) -> 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'' Term Term)) -> m a -> m a
addContext Tele (Dom (Type'' Term Term))
delta' (Substitution' DeBruijnPattern -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
Substitution' DeBruijnPattern -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho)
            ]

          -- Compute the new out patterns and target type.
          let ip' :: [NamedArg DeBruijnPattern]
ip'      = Substitution' (SubstArg [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution' DeBruijnPattern
Substitution' (SubstArg [NamedArg DeBruijnPattern])
rho [NamedArg DeBruijnPattern]
ip
              target' :: Arg (Type'' Term Term)
target'  = Substitution' DeBruijnPattern
-> Arg (Type'' Term Term) -> Arg (Type'' Term Term)
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Arg (Type'' Term Term)
target

          -- Update the problem equations
          let eqs' :: [ProblemEq]
eqs' = Substitution' DeBruijnPattern -> [ProblemEq] -> [ProblemEq]
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a
-> Getting [ProblemEq] (Problem a) [ProblemEq] -> [ProblemEq]
forall s a. s -> Getting a s a -> a
^. Getting [ProblemEq] (Problem a) [ProblemEq]
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs
              problem' :: Problem a
problem' = ASetter (Problem a) (Problem a) [ProblemEq] [ProblemEq]
-> [ProblemEq] -> Problem a -> Problem a
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter (Problem a) (Problem a) [ProblemEq] [ProblemEq]
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs [ProblemEq]
eqs' Problem a
problem

          -- The result type's quantity is set 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.
          cq <- Definition -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity (Definition -> Quantity)
-> ExceptT TCErr CheckLHSM Definition
-> ExceptT TCErr CheckLHSM Quantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ExceptT TCErr CheckLHSM Definition
forall (m :: * -> *).
(HasCallStack, ReadTCState m, HasConstInfo m) =>
QName -> m Definition
getOriginalConstInfo (ConHead -> QName
conName ConHead
c)
          let target'' = (Quantity -> Quantity)
-> Arg (Type'' Term Term) -> Arg (Type'' Term Term)
forall a. LensQuantity a => (Quantity -> Quantity) -> a -> a
mapQuantity Quantity -> Quantity
updResMod Arg (Type'' Term Term)
target'
                where
                  erased :: Bool
erased = case ArgInfo -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity ArgInfo
info of
                    Quantity0{} -> Bool
True
                    Quantity1{} -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
                    Quantityω{} -> Bool
False
                  -- either sets to Quantity0 or is the identity.
                  updResMod :: Quantity -> Quantity
updResMod Quantity
q =
                    case Quantity
cq of
                     Quantity
_ | Bool
erased  -> Quantity
q
                     Quantity0{} -> Quantity -> Quantity -> Quantity
composeQuantity Quantity
cq Quantity
q
                                 -- zero-out, preserves origin
                     Quantity1{} -> Quantity
forall a. HasCallStack => a
__IMPOSSIBLE__
                     Quantityω{} -> Quantity
q

          unless (null ixs) $
            whenM (withoutKOption `or2M` cubicalCompatibleOption) $ do
              mod <- currentModality
              lhsRng <- asks lhsRange
              liftTCM $ addContext delta' $
                conSplitModalityCheck lhsRng mod rho (length delta2) tel (unArg target)

          -- if rest type reduces,
          -- extend the split problem by previously not considered patterns
          st' <- liftTCM $ updateLHSState $ LHSState delta' ip' problem' target'' psplit (ixsplit || not (null ixs))

          reportSDoc "tc.lhs.top" 12 $ sep
            [ "new problem from rest"
            , nest 2 $ vcat
              [ "delta'  =" <+> prettyTCM (st' ^. lhsTel)
              , "eqs'    =" <+> addContext (st' ^. lhsTel) (prettyTCM $ st' ^. (lhsProblem . problemEqs))
              , "ip'     =" <+> addContext (st' ^. lhsTel) (pretty $ st' ^. lhsOutPat)
              ]
            ]
          return st'


-- | Ensures that we are not performing pattern matching on coinductive constructors.

checkMatchingAllowed :: (MonadTCError m)
  => LetOrClause   -- ^ Are we checking a clause lhs or a let-pattern?
  -> QName         -- ^ The name of the data or record type the constructor belongs to.
  -> DataOrRecord  -- ^ Information about data or (co)inductive (no-)eta-equality record.
  -> m ()
checkMatchingAllowed :: forall (m :: * -> *).
MonadTCError m =>
LetOrClause -> QName -> DataOrRecord -> m ()
checkMatchingAllowed LetOrClause
mf QName
d = \case
  IsRecord InductionAndEta { recordInduction :: InductionAndEta -> Maybe Induction
recordInduction=Maybe Induction
ind, recordEtaEquality :: InductionAndEta -> EtaEquality
recordEtaEquality=EtaEquality
eta }
    | Just Induction
CoInductive <- Maybe Induction
ind -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
SplitOnCoinductive
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ EtaEquality -> Bool
forall a. PatternMatchingAllowed a => a -> Bool
patternMatchingAllowed EtaEquality
eta -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m ()) -> TypeError -> m ()
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
SplitOnNonEtaRecord QName
d
    | Bool
otherwise -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  DataOrRecord
IsData -> case LetOrClause
mf of
    -- Andreas, 2026-01-20, issue #8327
    -- Exit early when we are checking a let-pattern and encounter a non-record pattern.
    -- This is mainly to serve the correct error message to the user.
    LetOrClause
LetLHS -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
ShouldBeRecordPattern
    ClauseLHS{} -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | When working with a monad @m@ implementing @MonadTCM@ and @MonadError TCErr@,
--   @suspendErrors f@ performs the TCM action @f@ but catches any errors and throws
--   them in the monad @m@ instead.
suspendErrors :: (MonadTCM m, MonadError TCErr m) => TCM a -> m a
suspendErrors :: forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors TCM a
f = do
  ok <- TCM (Either TCErr a) -> m (Either TCErr a)
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Either TCErr a) -> m (Either TCErr a))
-> TCM (Either TCErr a) -> m (Either TCErr a)
forall a b. (a -> b) -> a -> b
$ (a -> Either TCErr a
forall a b. b -> Either a b
Right (a -> Either TCErr a) -> TCM a -> TCM (Either TCErr a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCM a
f) TCM (Either TCErr a)
-> (TCErr -> TCM (Either TCErr a)) -> TCM (Either TCErr a)
forall a. TCMT IO a -> (TCErr -> TCMT IO a) -> TCMT IO a
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (Either TCErr a -> TCM (Either TCErr a)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either TCErr a -> TCM (Either TCErr a))
-> (TCErr -> Either TCErr a) -> TCErr -> TCM (Either TCErr a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TCErr -> Either TCErr a
forall a b. a -> Either a b
Left)
  either throwError return ok

-- | A more direct implementation of the specification
--   @softTypeError err == suspendErrors (typeError err)@
softTypeError :: (HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) => TypeError -> m a
softTypeError :: forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError TypeError
err = (CallStack -> m a) -> m a
forall b. HasCallStack => (CallStack -> b) -> b
withCallerCallStack ((CallStack -> m a) -> m a) -> (CallStack -> m a) -> m a
forall a b. (a -> b) -> a -> b
$ \CallStack
loc ->
  TCErr -> m a
forall a. TCErr -> m a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (TCErr -> m a) -> m TCErr -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< CallStack -> TypeError -> m TCErr
forall (m :: * -> *) a.
MonadTCError m =>
CallStack -> TypeError -> m a
typeError' CallStack
loc TypeError
err

-- | A convenient alias for @liftTCM . typeError@. Throws the error directly
--   in the TCM even if there is a surrounding monad also implementing
--   @MonadError TCErr@.
hardTypeError :: (HasCallStack, MonadTCM m) => TypeError -> m a
hardTypeError :: forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError = (CallStack -> TypeError -> m a) -> TypeError -> m a
forall b. HasCallStack => (CallStack -> b) -> b
withCallerCallStack ((CallStack -> TypeError -> m a) -> TypeError -> m a)
-> (CallStack -> TypeError -> m a) -> TypeError -> m a
forall a b. (a -> b) -> a -> b
$ \CallStack
loc -> TCM a -> m a
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM a -> m a) -> (TypeError -> TCM a) -> TypeError -> m a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CallStack -> TypeError -> TCM a
forall (m :: * -> *) a.
MonadTCError m =>
CallStack -> TypeError -> m a
typeError' CallStack
loc

type DataOrRecord = DataOrRecord' InductionAndEta

-- | Check if the type is a data or record type and return its name,
--   definition, sort, parameters, and indices. Fails softly if the type could become
--   a data/record type by instantiating a variable/metavariable, or fail hard
--   otherwise.
isDataOrRecordType
  :: (MonadTCM m, PureTCM m)
  => Type
  -> ExceptT TCErr m (DataOrRecord, QName, Sort, Args, Args)
       -- ^ The 'Args' are parameters and indices.

isDataOrRecordType :: forall (m :: * -> *).
(MonadTCM m, PureTCM m) =>
Type'' Term Term
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
isDataOrRecordType Type'' Term Term
a0 = Type'' Term Term
-> (Blocker
    -> Type'' Term Term
    -> ExceptT
         TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> (NotBlocked
    -> Type'' Term Term
    -> ExceptT
         TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked Type'' Term Term
a0 Blocker
-> Type'' Term Term
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
blocked ((NotBlocked
  -> Type'' Term Term
  -> ExceptT
       TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> (NotBlocked
    -> Type'' Term Term
    -> ExceptT
         TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a b. (a -> b) -> a -> b
$ \case
  NotBlocked
ReallyNotBlocked -> \ Type'' Term Term
a -> case Type'' Term Term -> Term
forall t a. Type'' t a -> a
unEl Type'' Term Term
a of

    -- Subcase: split type is a Def.
    Def QName
d Elims
es -> TCMT IO Definition -> ExceptT TCErr m Definition
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
d) ExceptT TCErr m Definition
-> (Definition
    -> ExceptT
         TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a b.
ExceptT TCErr m a -> (a -> ExceptT TCErr m b) -> ExceptT TCErr m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \Definition
def -> case Definition -> Defn
theDef Definition
def of

      Datatype{dataPars :: Defn -> Int
dataPars = Int
np, dataSort :: Defn -> Sort' Term
dataSort = Sort' Term
s} -> do

        ExceptT TCErr m Bool -> ExceptT TCErr m () -> ExceptT TCErr m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (Type'' Term Term -> ExceptT TCErr m Bool
forall (m :: * -> *). MonadTCM m => Type'' Term Term -> m Bool
isInterval Type'' Term Term
a) (ExceptT TCErr m () -> ExceptT TCErr m ())
-> ExceptT TCErr m () -> ExceptT TCErr m ()
forall a b. (a -> b) -> a -> b
$ TypeError -> ExceptT TCErr m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr m ())
-> ExceptT TCErr m TypeError -> ExceptT TCErr m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

        let ([Arg Term]
pars, [Arg Term]
ixs) = Int -> [Arg Term] -> ([Arg Term], [Arg Term])
forall a. Int -> [a] -> ([a], [a])
splitAt' Int
np ([Arg Term] -> ([Arg Term], [Arg Term]))
-> [Arg Term] -> ([Arg Term], [Arg Term])
forall a b. (a -> b) -> a -> b
$ Elims -> [Arg Term]
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims Elims
es
        (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. a -> ExceptT TCErr m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataOrRecord
forall p. DataOrRecord' p
IsData, QName
d, Sort' Term
s, [Arg Term]
pars, [Arg Term]
ixs)

      Record{ Maybe Induction
recInduction :: Maybe Induction
recInduction :: Defn -> Maybe Induction
recInduction, EtaEquality
recEtaEquality' :: EtaEquality
recEtaEquality' :: Defn -> EtaEquality
recEtaEquality' } -> do
        let pars :: [Arg Term]
pars = Elims -> [Arg Term]
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims Elims
es
        s <- Type'' Term Term -> ExceptT TCErr m (Sort' Term)
forall (m :: * -> *).
(PureTCM m, MonadBlock m, MonadError TCErr m) =>
Type'' Term Term -> m (Sort' Term)
shouldBeSort (Type'' Term Term -> ExceptT TCErr m (Sort' Term))
-> ExceptT TCErr m (Type'' Term Term)
-> ExceptT TCErr m (Sort' Term)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Definition -> Type'' Term Term
defType Definition
def Type'' Term Term
-> [Arg Term] -> ExceptT TCErr m (Type'' Term Term)
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type'' Term Term -> a -> m (Type'' Term Term)
forall (m :: * -> *).
(MonadReduce m, HasBuiltins m) =>
Type'' Term Term -> [Arg Term] -> m (Type'' Term Term)
`piApplyM` [Arg Term]
pars
        return (IsRecord InductionAndEta {recordInduction=recInduction, recordEtaEquality=recEtaEquality' }, d, s, pars, [])

      -- Issue #2253: the data type could be abstract.
      AbstractDefn{} -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
SplitOnAbstract QName
d

      -- the type could be an axiom
      Axiom{} -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

      -- Can't match before we have the definition
      DataOrRecSig{} -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
SplitOnUnchecked QName
d

      -- Issue #2997: the type could be a Def that does not reduce for some reason
      -- (abstract, failed termination checking, NON_TERMINATING, ...)
      Function{}    -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

      Constructor{} -> ExceptT
  TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. HasCallStack => a
__IMPOSSIBLE__

      -- Issue #3620: Some primitives are types too.
      -- Not data though, at least currently 11/03/2018.
      Primitive{}   -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

      PrimitiveSort{} -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

      GeneralizableVar{} -> ExceptT
  TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. HasCallStack => a
__IMPOSSIBLE__

    -- variable: fail softly
    Var{}      -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
    MetaV{}    -> ExceptT
  TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. HasCallStack => a
__IMPOSSIBLE__  -- That is handled in @blocked@.

    -- pi or sort: fail hard
    Pi{}       -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
    Sort{}     -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

    Lam{}      -> ExceptT
  TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. HasCallStack => a
__IMPOSSIBLE__
    Lit{}      -> ExceptT
  TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. HasCallStack => a
__IMPOSSIBLE__
    Con{}      -> ExceptT
  TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. HasCallStack => a
__IMPOSSIBLE__
    Level{}    -> ExceptT
  TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. HasCallStack => a
__IMPOSSIBLE__
    DontCare{} -> ExceptT
  TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. HasCallStack => a
__IMPOSSIBLE__
    Dummy DummyTermKind
s Elims
_  -> [Char]
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
[Char] -> m a
__IMPOSSIBLE_VERBOSE__ (DummyTermKind -> [Char]
forall a. Show a => a -> [Char]
show DummyTermKind
s)

  -- neutral type: fail softly
  StuckOn{}     -> \ Type'' Term Term
_a -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
  AbsurdMatch{} -> \ Type'' Term Term
_a -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

  -- missing clauses: fail hard
  -- TODO: postpone checking of the whole clause until later?
  MissingClauses{} -> \ Type'' Term Term
_a -> TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

  -- underapplied type: should not happen
  Underapplied{} -> Type'' Term Term
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall a. HasCallStack => a
__IMPOSSIBLE__

  where
  notData :: ExceptT TCErr m TypeError
notData      = TCM TypeError -> ExceptT TCErr m TypeError
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> ExceptT TCErr m TypeError)
-> TCM TypeError -> ExceptT TCErr m TypeError
forall a b. (a -> b) -> a -> b
$ SplitError -> TypeError
SplitError (SplitError -> TypeError)
-> (Closure (Type'' Term Term) -> SplitError)
-> Closure (Type'' Term Term)
-> TypeError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure (Type'' Term Term) -> SplitError
NotADatatype (Closure (Type'' Term Term) -> TypeError)
-> TCMT IO (Closure (Type'' Term Term)) -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type'' Term Term -> TCMT IO (Closure (Type'' Term Term))
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Type'' Term Term
a0
  blocked :: Blocker
-> Type'' Term Term
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
blocked Blocker
b Type'' Term Term
_a = TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError
 -> ExceptT
      TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT
     TCErr m (DataOrRecord, QName, Sort' Term, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do TCM TypeError -> ExceptT TCErr m TypeError
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> ExceptT TCErr m TypeError)
-> TCM TypeError -> ExceptT TCErr m TypeError
forall a b. (a -> b) -> a -> b
$ SplitError -> TypeError
SplitError (SplitError -> TypeError)
-> (Closure (Type'' Term Term) -> SplitError)
-> Closure (Type'' Term Term)
-> TypeError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocker -> Closure (Type'' Term Term) -> SplitError
BlockedType Blocker
b (Closure (Type'' Term Term) -> TypeError)
-> TCMT IO (Closure (Type'' Term Term)) -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type'' Term Term -> TCMT IO (Closure (Type'' Term Term))
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Type'' Term Term
a0

-- | Get the constructor of the given record type together with its type.
--   Throws an error if the type is not a record type.
getRecordConstructor
  :: QName  -- ^ Name @d@ of the record type
  -> Args   -- ^ Parameters @pars@ of the record type
  -> Type   -- ^ The record type @Def d pars@ (for error reporting)
  -> TCM (ConHead, Type)
getRecordConstructor :: QName
-> [Arg Term]
-> Type'' Term Term
-> TCM (ConHead, Type'' Term Term)
getRecordConstructor QName
d [Arg Term]
pars Type'' Term Term
a = do
  con <- (Definition -> Defn
theDef (Definition -> Defn) -> TCMT IO Definition -> TCMT IO Defn
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
d) TCMT IO Defn -> (Defn -> TCMT IO ConHead) -> TCMT IO ConHead
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
    Record{recConHead :: Defn -> ConHead
recConHead = ConHead
con} -> ConHead -> TCMT IO ConHead
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConHead -> TCMT IO ConHead) -> ConHead -> TCMT IO ConHead
forall a b. (a -> b) -> a -> b
$ KillRangeT ConHead
forall a. KillRange a => KillRangeT a
killRange ConHead
con
    Defn
_ -> TypeError -> TCMT IO ConHead
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ConHead) -> TypeError -> TCMT IO ConHead
forall a b. (a -> b) -> a -> b
$ Type'' Term Term -> TypeError
ShouldBeRecordType Type'' Term Term
a
  b <- (`piApply` pars) . defType <$> getConstInfo (conName con)
  return (con, b)


-- | Disambiguate a projection based on the record type it is supposed to be
--   projecting from. Returns the unambiguous projection name and its type.
--   Throws an error if the type is not a record type.
disambiguateProjection
  :: Maybe Hiding   -- ^ Hiding info of the projection's principal argument.
                    --   @Nothing@ if 'Postfix' projection.
  -> AmbiguousQName -- ^ Name of the projection to be disambiguated.
  -> Arg Type       -- ^ Record type we are projecting from.
  -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
       -- ^ @Bool@ signifies whether copattern matching is allowed at
       --   the inferred record type.
disambiguateProjection :: Maybe Hiding
-> AmbiguousQName
-> Arg (Type'' Term Term)
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
disambiguateProjection Maybe Hiding
h AmbiguousQName
ambD Arg (Type'' Term Term)
b = do
  -- If the target is not a record type, that's an error.
  -- It could be a meta, but since we cannot postpone lhs checking, we crash here.
  TCMT
  IO
  (Either
     (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData))
-> (Blocked (Type'' Term Term)
    -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> ((QName, [Arg Term], RecordData)
    -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall (m :: * -> *) a b c.
Monad m =>
m (Either a b) -> (a -> m c) -> (b -> m c) -> m c
caseEitherM (TCMT
  IO
  (Either
     (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData))
-> TCMT
     IO
     (Either
        (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData))
forall a. TCM a -> TCM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT
   IO
   (Either
      (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData))
 -> TCMT
      IO
      (Either
         (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData)))
-> TCMT
     IO
     (Either
        (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData))
-> TCMT
     IO
     (Either
        (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData))
forall a b. (a -> b) -> a -> b
$ Type'' Term Term
-> TCMT
     IO
     (Either
        (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData))
forall (m :: * -> *).
(HasCallStack, PureTCM m) =>
Type'' Term Term
-> m (Either
        (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData))
tryRecordType (Type'' Term Term
 -> TCMT
      IO
      (Either
         (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData)))
-> Type'' Term Term
-> TCMT
     IO
     (Either
        (Blocked (Type'' Term Term)) (QName, [Arg Term], RecordData))
forall a b. (a -> b) -> a -> b
$ Arg (Type'' Term Term) -> Type'' Term Term
forall e. Arg e -> e
unArg Arg (Type'' Term Term)
b) Blocked (Type'' Term Term)
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
notRecord
    \ (QName
r, [Arg Term]
vs, RecordData{ _recFields :: RecordData -> [Dom' Term QName]
_recFields = [Dom' Term QName]
fs, _recInduction :: RecordData -> Maybe Induction
_recInduction = Maybe Induction
ind, _recEtaEquality' :: RecordData -> EtaEquality
_recEtaEquality' = EtaEquality
eta }) -> do
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" 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
"we are of record type r  = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> TCMT IO Doc
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (QName -> Doc
forall a. Pretty a => a -> Doc
P.pretty QName
r)
        , TCMT IO Doc
"applied to parameters vs = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> [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
        , TCMT IO Doc
"and have fields       fs = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> Doc -> TCMT IO Doc
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([Arg QName] -> Doc
forall a. Pretty a => a -> Doc
P.pretty ([Arg QName] -> Doc) -> [Arg QName] -> Doc
forall a b. (a -> b) -> a -> b
$ (Dom' Term QName -> Arg QName) -> [Dom' Term QName] -> [Arg QName]
forall a b. (a -> b) -> [a] -> [b]
map' Dom' Term QName -> Arg QName
forall t a. Dom' t a -> Arg a
argFromDom [Dom' Term QName]
fs)
        ]
      let comatching :: Bool
comatching = Maybe Induction
ind 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
|| EtaEquality -> Bool
forall a. CopatternMatchingAllowed a => a -> Bool
copatternMatchingAllowed EtaEquality
eta
      -- Try the projection candidates.
      -- First, we try to find a disambiguation that doesn't produce
      -- any new constraints.
      Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> Bool
-> (([TCErr],
     [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
tryDisambiguate Bool
False [Dom' Term QName]
fs QName
r [Arg Term]
vs Bool
comatching ((([TCErr],
   [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
  -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
 -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> (([TCErr],
     [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall a b. (a -> b) -> a -> b
$ \ ([TCErr],
 [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
_ ->
          -- If this fails, we try again with constraints, but we require
          -- the solution to be unique.
          Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> Bool
-> (([TCErr],
     [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
tryDisambiguate Bool
True [Dom' Term QName]
fs QName
r [Arg Term]
vs Bool
comatching ((([TCErr],
   [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
  -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
 -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> (([TCErr],
     [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall a b. (a -> b) -> a -> b
$ \case
            (TCErr
err:[TCErr]
_, [] ) -> TCErr -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
            ([]   , [] ) -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall a. HasCallStack => a
__IMPOSSIBLE__
            ([TCErr]
_    , [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))
_]) -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall a. HasCallStack => a
__IMPOSSIBLE__
            ([TCErr]
_    , (QName
d,(Arg (Type'' Term Term), ArgInfo, Maybe TCState)
_) : (QName
d1,(Arg (Type'' Term Term), ArgInfo, Maybe TCState)
_) : [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))]
disambs) ->
              TypeError
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError
 -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> TypeError
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall a b. (a -> b) -> a -> b
$ QName -> NonEmpty QName -> TypeError
AmbiguousProjection QName
d (NonEmpty QName -> TypeError) -> NonEmpty QName -> TypeError
forall a b. (a -> b) -> a -> b
$ QName
d1 QName -> [QName] -> NonEmpty QName
forall a. a -> [a] -> NonEmpty a
:| ((QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))
 -> QName)
-> [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))]
-> [QName]
forall a b. (a -> b) -> [a] -> [b]
map' (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState)) -> QName
forall a b. (a, b) -> a
fst [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))]
disambs
  where
    ds :: NonEmpty QName
ds = AmbiguousQName -> NonEmpty QName
getAmbiguous AmbiguousQName
ambD
    tryDisambiguate :: Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> Bool
-> (([TCErr],
     [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
tryDisambiguate Bool
constraintsOk [Dom' Term QName]
fs QName
r [Arg Term]
vs Bool
comatching ([TCErr],
 [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
failure = do
      -- Note that tryProj wraps TCM in an ExceptT, collecting errors
      -- instead of throwing them to the user immediately.
      disambiguations :: List1 (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState)))
        <- (QName
 -> TCM
      (Either
         TCErr (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))))
-> NonEmpty QName
-> TCM
     (List1
        (Either
           TCErr (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))))
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) -> NonEmpty a -> m (NonEmpty b)
mapM (ExceptT
  TCErr
  (TCMT IO)
  (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))
-> TCM
     (Either
        TCErr (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   TCErr
   (TCMT IO)
   (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))
 -> TCM
      (Either
         TCErr (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))))
-> (QName
    -> ExceptT
         TCErr
         (TCMT IO)
         (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState)))
-> QName
-> TCM
     (Either
        TCErr (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> QName
-> ExceptT
     TCErr
     (TCMT IO)
     (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))
tryProj Bool
constraintsOk [Dom' Term QName]
fs QName
r [Arg Term]
vs) NonEmpty QName
ds
      case List1.partitionEithers disambiguations of
        ([TCErr]
_ , (QName
d, (Arg (Type'' Term Term)
a, ArgInfo
ai, Maybe TCState
mst)) : [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))]
disambs) | Bool
constraintsOk Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
<= [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))] -> Bool
forall a. Null a => a -> Bool
null [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))]
disambs -> do
          (TCState -> TCMT IO ()) -> Maybe TCState -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ TCState -> TCMT IO ()
forall (m :: * -> *). MonadTCState m => TCState -> m ()
putTC Maybe TCState
mst -- Activate state changes
          -- From here, we have the correctly disambiguated projection.
          -- For highlighting, we remember which name we disambiguated to.
          -- This is safe here (fingers crossed) as we won't decide on a
          -- different projection even if we backtrack and come here again.
          TCMT IO () -> TCMT IO ()
forall a. TCM a -> TCM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ QName -> TCMT IO ()
storeDisambiguatedProjection QName
d
          (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
d, Bool
comatching, QName
r, Arg (Type'' Term Term)
a, ArgInfo
ai)
        ([TCErr],
 [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
other -> ([TCErr],
 [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
failure ([TCErr],
 [(QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))])
other

    notRecord :: Blocked (Type'' Term Term)
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
notRecord Blocked (Type'' Term Term)
blk = Maybe Blocker
-> QName
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
Maybe Blocker -> QName -> m a
wrongProj (Blocker -> Maybe Blocker
forall a. a -> Maybe a
Just (Blocked (Type'' Term Term) -> Blocker
forall t a. Blocked' t a -> Blocker
getBlocker Blocked (Type'' Term Term)
blk)) (QName
 -> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo))
-> QName
-> TCM (QName, Bool, QName, Arg (Type'' Term Term), ArgInfo)
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> QName
forall a. NonEmpty a -> a
List1.head NonEmpty QName
ds

    wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => Maybe Blocker -> QName -> m a
    wrongProj :: forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
Maybe Blocker -> QName -> m a
wrongProj Maybe Blocker
blk QName
d = TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m a) -> m TypeError -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM TypeError -> m TypeError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> m TypeError) -> TCM TypeError -> m TypeError
forall a b. (a -> b) -> a -> b
$ if AmbiguousQName -> Bool
isAmbiguous AmbiguousQName
ambD then Maybe Blocker
-> Arg (Type'' Term Term) -> Bool -> QName -> TypeError
CannotEliminateWithProjection Maybe Blocker
blk Arg (Type'' Term Term)
b Bool
True (QName -> TypeError) -> TCMT IO QName -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO QName
forall (m :: * -> *). MonadPretty m => QName -> m QName
dropTopLevelModule QName
d
                else TypeError -> TCM TypeError
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (TypeError -> TCM TypeError) -> TypeError -> TCM TypeError
forall a b. (a -> b) -> a -> b
$ Maybe Blocker
-> Arg (Type'' Term Term) -> Bool -> QName -> TypeError
CannotEliminateWithProjection Maybe Blocker
blk Arg (Type'' Term Term)
b Bool
False QName
d

    tryProj
      :: Bool                 -- Are we allowed to create new constraints?
      -> [Dom QName]          -- Fields of record type under consideration.
      -> QName                -- Name of record type we are eliminating.
      -> Args                 -- Parameters of record type we are eliminating.
      -> QName                -- Candidate projection.
      -> ExceptT TCErr TCM (QName, (Arg Type, ArgInfo, Maybe TCState))
           -- TCState contains possibly new constraints/meta solutions.
    tryProj :: Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> QName
-> ExceptT
     TCErr
     (TCMT IO)
     (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))
tryProj Bool
constraintsOk [Dom' Term QName]
fs QName
r [Arg Term]
vs QName
d0 = QName -> ExceptT TCErr (TCMT IO) (Maybe Projection)
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Maybe Projection)
isProjection QName
d0 ExceptT TCErr (TCMT IO) (Maybe Projection)
-> (Maybe Projection
    -> ExceptT
         TCErr
         (TCMT IO)
         (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState)))
-> ExceptT
     TCErr
     (TCMT IO)
     (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))
forall a b.
ExceptT TCErr (TCMT IO) a
-> (a -> ExceptT TCErr (TCMT IO) b) -> ExceptT TCErr (TCMT IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- Not a projection
      Maybe Projection
Nothing -> Maybe Blocker
-> QName
-> ExceptT
     TCErr
     (TCMT IO)
     (QName, (Arg (Type'' Term Term), ArgInfo, Maybe TCState))
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
Maybe Blocker -> QName -> m a
wrongProj Maybe Blocker
forall a. Maybe a
Nothing QName
d0
      Just Projection
proj -> do
        let d :: QName
d = Projection -> QName
projOrig Projection
proj

        -- Andreas, 2015-05-06 issue 1413 projProper=Nothing is not impossible
        qr <- ExceptT TCErr (TCMT IO) QName
-> (QName -> ExceptT TCErr (TCMT IO) QName)
-> Maybe QName
-> ExceptT TCErr (TCMT IO) QName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (Maybe Blocker -> QName -> ExceptT TCErr (TCMT IO) QName
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
Maybe Blocker -> QName -> m a
wrongProj Maybe Blocker
forall a. Maybe a
Nothing QName
d) QName -> ExceptT TCErr (TCMT IO) QName
forall a. a -> ExceptT TCErr (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe QName -> ExceptT TCErr (TCMT IO) QName)
-> Maybe QName -> ExceptT TCErr (TCMT IO) QName
forall a b. (a -> b) -> a -> b
$ Projection -> Maybe QName
projProper Projection
proj

        -- If projIndex==0, then the projection is already applied
        -- to the record value (like in @open R r@), and then it
        -- is no longer a projection but a record field.
        when (null $ projLams proj) $ wrongProj Nothing d
        reportSLn "tc.lhs.split" 90 "we are a projection pattern"
        -- If the target is not a record type, that's an error.
        -- It could be a meta, but since we cannot postpone lhs checking, we crash here.
        reportSDoc "tc.lhs.split" 20 $ sep
          [ text $ "proj                  d0 = " ++! prettyShow d0
          , text $ "original proj         d  = " ++! prettyShow d
          ]
        -- Get the field decoration.
        -- If the projection pattern name @d@ is not a field name,
        -- we have to try the next projection name.
        -- If this was not an ambiguous projection, that's an error.
        argd <- maybe (wrongProj Nothing d) return $ List.find ((d ==) . unDom) fs

        -- Issue4998: This used to use the hiding from the principal argument, but this is not
        -- relevant for the ArgInfo of the clause rhs. We return that separately so we can set the
        -- correct hiding for the projection pattern in splitRest above.
        let ai = Dom' Term QName -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom' Term QName
argd

        reportSDoc "tc.lhs.split" 20 $ vcat
          [ text $ "original proj relevance  = " ++! show (getRelevance argd)
          , text $ "original proj quantity   = " ++! show (getQuantity  argd)
          ]
        -- Andreas, 2016-12-31, issue #2374:
        -- We can also disambiguate by hiding info.
        -- Andreas, 2018-10-18, issue #3289: postfix projections have no hiding info.
        unless (caseMaybe h True $ sameHiding $ projArgInfo proj) $
          softTypeError $ WrongHidingInProjection d

        -- Andreas, 2016-12-31, issue #1976: Check parameters.
        let chk = QName -> QName -> [Arg Term] -> TCMT IO ()
forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> [Arg Term] -> tcm ()
checkParameters QName
qr QName
r [Arg Term]
vs
        mst <- suspendErrors $
          if constraintsOk then Just . snd <$> localTCStateSaving chk
          else Nothing <$ nonConstraining chk

        -- Get the type of projection d applied to "self"
        dType <- liftTCM $ defType <$> getConstInfo d  -- full type!
        reportSDoc "tc.lhs.split" 20 $ sep
          [ "we are being projected by dType = " <+> prettyTCM dType
          ]
        projType <- liftTCM $ dType `piApplyM` vs
        return (d0, (Arg ai projType, projArgInfo proj, mst))

-- | Disambiguate a constructor based on the data type it is supposed to be
--   constructing. Returns the unambiguous constructor name and its type.
--   Precondition: type should be a data/record type.
disambiguateConstructor
  :: AmbiguousQName    -- ^ The name of the constructor to be disambiguated.
  -> QName             -- ^ Name of the datatype.
  -> Args              -- ^ Parameters of the datatype
  -> TCM (ConHead, Type)
disambiguateConstructor :: AmbiguousQName
-> QName -> [Arg Term] -> TCM (ConHead, Type'' Term Term)
disambiguateConstructor AmbiguousQName
ambC QName
d [Arg Term]
pars = do
  d <- QName -> TCMT IO QName
forall (m :: * -> *). HasConstInfo m => QName -> m QName
canonicalName QName
d
  cons <- theDef <$> getConstInfo d >>= \case
    def :: Defn
def@Datatype{} -> [QName] -> TCMT IO [QName]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([QName] -> TCMT IO [QName]) -> [QName] -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ Defn -> [QName]
dataCons Defn
def
    def :: Defn
def@Record{}   -> [QName] -> TCMT IO [QName]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([QName] -> TCMT IO [QName]) -> [QName] -> TCMT IO [QName]
forall a b. (a -> b) -> a -> b
$ [ConHead -> QName
conName (ConHead -> QName) -> ConHead -> QName
forall a b. (a -> b) -> a -> b
$ Defn -> ConHead
recConHead Defn
def]
    Defn
_              -> TCMT IO [QName]
forall a. HasCallStack => a
__IMPOSSIBLE__

  -- First, try do disambiguate with nonConstraining,
  -- if that fails, try again allowing constraint/solution generation.
  tryDisambiguate False d cons $ \ ([TCErr],
 [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))])
_ ->
    Bool
-> QName
-> [QName]
-> (([TCErr],
     [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))])
    -> TCM (ConHead, Type'' Term Term))
-> TCM (ConHead, Type'' Term Term)
tryDisambiguate Bool
True QName
d [QName]
cons ((([TCErr],
   [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))])
  -> TCM (ConHead, Type'' Term Term))
 -> TCM (ConHead, Type'' Term Term))
-> (([TCErr],
     [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))])
    -> TCM (ConHead, Type'' Term Term))
-> TCM (ConHead, Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ \case
        ([]   , [] ) -> TCM (ConHead, Type'' Term Term)
forall a. HasCallStack => a
__IMPOSSIBLE__
        (TCErr
err:[TCErr]
_, [] ) -> TCErr -> TCM (ConHead, Type'' Term Term)
forall a. TCErr -> TCMT IO a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
        -- If all disambiguations point to the same original constructor
        -- meaning that only the parameters may differ,
        -- then throw more specific error.
        ([TCErr]
_    , [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))
_]) -> TypeError -> TCM (ConHead, Type'' Term Term)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM (ConHead, Type'' Term Term))
-> TypeError -> TCM (ConHead, Type'' Term Term)
forall a b. (a -> b) -> a -> b
$ QName -> NonEmpty QName -> TypeError
CantResolveOverloadedConstructorsTargetingSameDatatype QName
d NonEmpty QName
cs
        ([TCErr]
_    , (d0 :: List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))
d0@((QName
c,ConHead
_,(Type'' Term Term, Maybe TCState)
_) :| [(QName, ConHead, (Type'' Term Term, Maybe TCState))]
_) : List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))
d1 : [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))]
ds)) -> TypeError -> TCM (ConHead, Type'' Term Term)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM (ConHead, Type'' Term Term))
-> TypeError -> TCM (ConHead, Type'' Term Term)
forall a b. (a -> b) -> a -> b
$
          QName -> List2 QName -> TypeError
AmbiguousConstructor QName
c (List2 QName -> TypeError) -> List2 QName -> TypeError
forall a b. (a -> b) -> a -> b
$ ((QName, ConHead, (Type'' Term Term, Maybe TCState)) -> QName)
-> List2 (QName, ConHead, (Type'' Term Term, Maybe TCState))
-> List2 QName
forall a b. (a -> b) -> List2 a -> List2 b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (ConHead -> QName
conName (ConHead -> QName)
-> ((QName, ConHead, (Type'' Term Term, Maybe TCState)) -> ConHead)
-> (QName, ConHead, (Type'' Term Term, Maybe TCState))
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName, ConHead, (Type'' Term Term, Maybe TCState)) -> ConHead
forall a b c. (a, b, c) -> b
snd3) (List2 (QName, ConHead, (Type'' Term Term, Maybe TCState))
 -> List2 QName)
-> List2 (QName, ConHead, (Type'' Term Term, Maybe TCState))
-> List2 QName
forall a b. (a -> b) -> a -> b
$ List2 (List1 (QName, ConHead, (Type'' Term Term, Maybe TCState)))
-> List2 (QName, ConHead, (Type'' Term Term, Maybe TCState))
forall a. List2 (List1 a) -> List2 a
List2.concat21 (List2 (List1 (QName, ConHead, (Type'' Term Term, Maybe TCState)))
 -> List2 (QName, ConHead, (Type'' Term Term, Maybe TCState)))
-> List2
     (List1 (QName, ConHead, (Type'' Term Term, Maybe TCState)))
-> List2 (QName, ConHead, (Type'' Term Term, Maybe TCState))
forall a b. (a -> b) -> a -> b
$ List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))
-> List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))
-> [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))]
-> List2
     (List1 (QName, ConHead, (Type'' Term Term, Maybe TCState)))
forall a. a -> a -> [a] -> List2 a
List2 List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))
d0 List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))
d1 [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))]
ds

  where
    cs :: NonEmpty QName
cs = AmbiguousQName -> NonEmpty QName
getAmbiguous AmbiguousQName
ambC
    tryDisambiguate
      :: Bool     -- May we constrain/solve metas to arrive at unique disambiguation?
      -> QName    -- Data/record type.
      -> [QName]  -- Its constructor(s).
      -> ( ( [TCErr]
           , [List1 (QName, ConHead, (Type, Maybe TCState))]
           )
           -> TCM (ConHead, Type) )  -- Failure continuation, taking
                                     -- possible disambiguations
                                     -- grouped by the original
                                     -- constructor name in 'ConHead'.
      -> TCM (ConHead, Type)  -- Unique disambiguation and its type.
    tryDisambiguate :: Bool
-> QName
-> [QName]
-> (([TCErr],
     [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))])
    -> TCM (ConHead, Type'' Term Term))
-> TCM (ConHead, Type'' Term Term)
tryDisambiguate Bool
constraintsOk QName
d [QName]
cons ([TCErr],
 [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))])
-> TCM (ConHead, Type'' Term Term)
failure = do
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.disamb" Int
30 (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] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [[TCMT IO Doc]] -> [TCMT IO Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat ([[TCMT IO Doc]] -> [TCMT IO Doc])
-> [[TCMT IO Doc]] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$
        [ [ TCMT IO Doc
"tryDisambiguate" ]
        , if Bool
constraintsOk then [ TCMT IO Doc
"(allowing new constraints)" ] else [TCMT IO Doc]
forall a. Null a => a
empty
        , (QName -> TCMT IO Doc) -> [QName] -> [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)
-> (QName -> TCMT IO Doc) -> QName -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty) ([QName] -> [TCMT IO Doc]) -> [QName] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> [Item (NonEmpty QName)]
forall l. IsList l => l -> [Item l]
List1.toList NonEmpty QName
cs
        , [ TCMT IO Doc
"against" ]
        , (QName -> TCMT IO Doc) -> [QName] -> [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)
-> (QName -> TCMT IO Doc) -> QName -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty) [QName]
cons
        ]
      disambiguations <- (QName
 -> TCMT
      IO
      (Either TCErr (QName, ConHead, (Type'' Term Term, Maybe TCState))))
-> NonEmpty QName
-> TCMT
     IO
     (NonEmpty
        (Either TCErr (QName, ConHead, (Type'' Term Term, Maybe TCState))))
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) -> NonEmpty a -> m (NonEmpty b)
mapM (ExceptT
  TCErr (TCMT IO) (QName, ConHead, (Type'' Term Term, Maybe TCState))
-> TCMT
     IO
     (Either TCErr (QName, ConHead, (Type'' Term Term, Maybe TCState)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   TCErr (TCMT IO) (QName, ConHead, (Type'' Term Term, Maybe TCState))
 -> TCMT
      IO
      (Either TCErr (QName, ConHead, (Type'' Term Term, Maybe TCState))))
-> (QName
    -> ExceptT
         TCErr
         (TCMT IO)
         (QName, ConHead, (Type'' Term Term, Maybe TCState)))
-> QName
-> TCMT
     IO
     (Either TCErr (QName, ConHead, (Type'' Term Term, Maybe TCState)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [QName]
-> QName
-> [Arg Term]
-> QName
-> ExceptT
     TCErr (TCMT IO) (QName, ConHead, (Type'' Term Term, Maybe TCState))
tryCon Bool
constraintsOk [QName]
cons QName
d [Arg Term]
pars) NonEmpty QName
cs
      -- Q: can we be more lazy, like using the ListT monad?
      -- Andreas, 2020-06-17: Not really, since we need to make sure
      -- that only a single candidate remains, and if not,
      -- report all alternatives in the error message.
      let (errs, fits0) = List1.partitionEithers disambiguations
      reportSDoc "tc.lhs.disamb" 40 $ vcat $ do
        let hideSt (a
c0,b
c,(a
a,f b
mst)) = (a
c0, b
c, (a
a, ([Char]
"(state change)" :: String) [Char] -> f b -> f [Char]
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f b
mst))
        "remaining candidates: " : map' (nest 2 . prettyTCM . hideSt) fits0
      dedupCons fits0 >>= \case

        -- Single candidate remains.
        [ (QName
c0,ConHead
c,(Type'' Term Term
a,Maybe TCState
mst)) :| [] ] -> do
          [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.disamb" Int
30 (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] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
            [ TCMT IO Doc
"tryDisambiguate suceeds with"
            , QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty QName
c0
            , TCMT IO Doc
":"
            , Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
a
            ]
          -- Andreas, 2020-06-16, issue #4135
          -- If disambiguation succeeded with new constraints/solutions,
          -- put them into action.
          Maybe TCState -> (TCState -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe TCState
mst TCState -> TCMT IO ()
forall (m :: * -> *). MonadTCState m => TCState -> m ()
putTC
          -- If there are multiple candidates for the constructor pattern, exactly one of
          -- which type checks, remember our choice for highlighting info.
          Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
when (AmbiguousQName -> Bool
isAmbiguous AmbiguousQName
ambC) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO () -> TCMT IO ()
forall a. TCM a -> TCM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
            Induction -> QName -> TCMT IO ()
storeDisambiguatedConstructor (ConHead -> Induction
conInductive ConHead
c) QName
c0
          (ConHead, Type'' Term Term) -> TCM (ConHead, Type'' Term Term)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConHead
c,Type'' Term Term
a)

        -- Either no candidate constructor in 'cs' type checks, or multiple candidates
        -- type check.
        [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))]
groups -> ([TCErr],
 [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))])
-> TCM (ConHead, Type'' Term Term)
failure ([TCErr]
errs, [List1 (QName, ConHead, (Type'' Term Term, Maybe TCState))]
groups)

    abstractConstructor :: QName -> m a
abstractConstructor QName
c = TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m a) -> TypeError -> m a
forall a b. (a -> b) -> a -> b
$
      QName -> TypeError
AbstractConstructorNotInScope QName
c

    wrongDatatype :: QName -> QName -> m a
wrongDatatype QName
c QName
d = TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m a) -> TypeError -> m a
forall a b. (a -> b) -> a -> b
$
      QName -> QName -> TypeError
ConstructorPatternInWrongDatatype QName
c QName
d

    tryCon
      :: Bool        -- Are we allowed to constrain metas?
      -> [QName]     -- Constructors of data type under consideration.
      -> QName       -- Name of data/record type we are eliminating.
      -> Args        -- Parameters of data/record type we are eliminating.
      -> QName       -- Candidate constructor.
      -> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState))
           -- If this candidate succeeds, return its disambiguation
           -- its type, and maybe the state obtained after checking it
           -- (which may contain new constraints/solutions).
    tryCon :: Bool
-> [QName]
-> QName
-> [Arg Term]
-> QName
-> ExceptT
     TCErr (TCMT IO) (QName, ConHead, (Type'' Term Term, Maybe TCState))
tryCon Bool
constraintsOk [QName]
cons QName
d [Arg Term]
pars QName
c = QName -> ExceptT TCErr (TCMT IO) (Either SigError Definition)
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m (Either SigError Definition)
getConstInfo' QName
c ExceptT TCErr (TCMT IO) (Either SigError Definition)
-> (Either SigError Definition
    -> ExceptT
         TCErr
         (TCMT IO)
         (QName, ConHead, (Type'' Term Term, Maybe TCState)))
-> ExceptT
     TCErr (TCMT IO) (QName, ConHead, (Type'' Term Term, Maybe TCState))
forall a b.
ExceptT TCErr (TCMT IO) a
-> (a -> ExceptT TCErr (TCMT IO) b) -> ExceptT TCErr (TCMT IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left (SigUnknown [Char]
err)     -> [Char]
-> ExceptT
     TCErr (TCMT IO) (QName, ConHead, (Type'' Term Term, Maybe TCState))
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
[Char] -> m a
__IMPOSSIBLE_VERBOSE__ [Char]
err
      Left SigError
SigCubicalNotErasure -> ExceptT
  TCErr (TCMT IO) (QName, ConHead, (Type'' Term Term, Maybe TCState))
forall a. HasCallStack => a
__IMPOSSIBLE__
      Left SigError
SigAbstract          -> QName
-> ExceptT
     TCErr (TCMT IO) (QName, ConHead, (Type'' Term Term, Maybe TCState))
forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
QName -> m a
abstractConstructor QName
c
      Right Definition
def                 -> do
        let con :: ConHead
con = Defn -> ConHead
conSrcCon (Definition -> Defn
theDef Definition
def) ConHead -> QName -> ConHead
forall t u. (SetRange t, HasRange u) => t -> u -> t
`withRangeOf` QName
c
        Bool -> ExceptT TCErr (TCMT IO) () -> ExceptT TCErr (TCMT IO) ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (ConHead -> QName
conName ConHead
con QName -> [QName] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [QName]
cons) (ExceptT TCErr (TCMT IO) () -> ExceptT TCErr (TCMT IO) ())
-> ExceptT TCErr (TCMT IO) () -> ExceptT TCErr (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> ExceptT TCErr (TCMT IO) ()
forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
QName -> QName -> m a
wrongDatatype QName
c QName
d

        -- Andreas, 2013-03-22 fixing issue 279
        -- To resolve ambiguous constructors, Agda always looks up
        -- their original definition and reconstructs the parameters
        -- from the type @Def d vs@ we check against.
        -- However, the constructor could come from a module instantiation
        -- with some of the parameters already fixed.
        -- Agda did not make sure the two parameter lists coincide,
        -- so we add a check here.
        -- I guess this issue could be solved more systematically,
        -- but the extra check here is non-invasive to the existing code.
        -- Andreas, 2016-12-31 fixing issue #1975
        -- Do this also for constructors which were originally ambiguous.
        let chk :: TCMT IO ()
chk = QName -> QName -> [Arg Term] -> TCMT IO ()
forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> [Arg Term] -> tcm ()
checkConstructorParameters QName
c QName
d [Arg Term]
pars
        mst <- TCM (Maybe TCState) -> ExceptT TCErr (TCMT IO) (Maybe TCState)
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors (TCM (Maybe TCState) -> ExceptT TCErr (TCMT IO) (Maybe TCState))
-> TCM (Maybe TCState) -> ExceptT TCErr (TCMT IO) (Maybe TCState)
forall a b. (a -> b) -> a -> b
$
          if Bool
constraintsOk then TCState -> Maybe TCState
forall a. a -> Maybe a
Just (TCState -> Maybe TCState)
-> (((), TCState) -> TCState) -> ((), TCState) -> Maybe TCState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), TCState) -> TCState
forall a b. (a, b) -> b
snd (((), TCState) -> Maybe TCState)
-> TCMT IO ((), TCState) -> TCM (Maybe TCState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO () -> TCMT IO ((), TCState)
forall a. TCM a -> TCM (a, TCState)
localTCStateSaving TCMT IO ()
chk
          else Maybe TCState
forall a. Maybe a
Nothing Maybe TCState -> TCMT IO () -> TCM (Maybe TCState)
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(MonadConstraint m, MonadFresh ProblemId m, MonadWarning m) =>
m a -> m a
nonConstraining TCMT IO ()
chk

        -- Get the type from the original constructor.
        -- Andreas, 2020-06-17 TODO:
        -- Couldn't we return this type from checkConstructorParameters?
        cType <- (`piApply` pars) . defType <$> getConInfo con

        return (c, con, (cType, mst))

    -- This deduplication identifies different names of the same
    -- constructor, ensuring that the "ambiguous constructor" error
    -- does not fire for the case described in #4130.
    --
    -- Andreas, 2020-06-17, issue #4135:
    -- However, we need to distinguish different occurrences
    -- of the same original constructor if it is used
    -- with different data parameters, as recorded in the @Type@.
    dedupCons ::
      forall a.       [ (a, ConHead, (Type, Maybe TCState)) ]
         -> TCM [ List1 (a, ConHead, (Type, Maybe TCState)) ]
    dedupCons :: forall a.
[(a, ConHead, (Type'' Term Term, Maybe TCState))]
-> TCM [List1 (a, ConHead, (Type'' Term Term, Maybe TCState))]
dedupCons [(a, ConHead, (Type'' Term Term, Maybe TCState))]
cands = do
      -- Group candidates by original constructor name.
      let groups :: [NonEmpty (a, ConHead, (Type'' Term Term, Maybe TCState))]
groups = ((a, ConHead, (Type'' Term Term, Maybe TCState)) -> QName)
-> [(a, ConHead, (Type'' Term Term, Maybe TCState))]
-> [NonEmpty (a, ConHead, (Type'' Term Term, Maybe TCState))]
forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
List1.groupWith (ConHead -> QName
conName (ConHead -> QName)
-> ((a, ConHead, (Type'' Term Term, Maybe TCState)) -> ConHead)
-> (a, ConHead, (Type'' Term Term, Maybe TCState))
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (a, ConHead, (Type'' Term Term, Maybe TCState)) -> ConHead
forall a b c. (a, b, c) -> b
snd3) [(a, ConHead, (Type'' Term Term, Maybe TCState))]
cands
      -- Eliminate duplicates (same type) from groups.
      (NonEmpty (a, ConHead, (Type'' Term Term, Maybe TCState))
 -> TCMT
      IO (NonEmpty (a, ConHead, (Type'' Term Term, Maybe TCState))))
-> [NonEmpty (a, ConHead, (Type'' Term Term, Maybe TCState))]
-> TCMT
     IO [NonEmpty (a, ConHead, (Type'' Term Term, Maybe TCState))]
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 (((a, ConHead, (Type'' Term Term, Maybe TCState))
 -> (a, ConHead, (Type'' Term Term, Maybe TCState)) -> TCMT IO Bool)
-> NonEmpty (a, ConHead, (Type'' Term Term, Maybe TCState))
-> TCMT
     IO (NonEmpty (a, ConHead, (Type'' Term Term, Maybe TCState)))
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Bool) -> List1 a -> m (List1 a)
List1.nubM ((Type'' Term Term, Maybe TCState)
-> (Type'' Term Term, Maybe TCState) -> TCMT IO Bool
cmpM ((Type'' Term Term, Maybe TCState)
 -> (Type'' Term Term, Maybe TCState) -> TCMT IO Bool)
-> ((a, ConHead, (Type'' Term Term, Maybe TCState))
    -> (Type'' Term Term, Maybe TCState))
-> (a, ConHead, (Type'' Term Term, Maybe TCState))
-> (a, ConHead, (Type'' Term Term, Maybe TCState))
-> TCMT IO Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` (a, ConHead, (Type'' Term Term, Maybe TCState))
-> (Type'' Term Term, Maybe TCState)
forall a b c. (a, b, c) -> c
thd3)) [NonEmpty (a, ConHead, (Type'' Term Term, Maybe TCState))]
groups
      where
      -- The types come possibly with their own state.
      cmpM :: (Type'' Term Term, Maybe TCState)
-> (Type'' Term Term, Maybe TCState) -> TCMT IO Bool
cmpM (Type'' Term Term
a1, Maybe TCState
mst1) (Type'' Term Term
a2, Maybe TCState
mst2) = do
        let cmpTypes :: TCMT IO Bool
cmpTypes = TCMT IO () -> TCMT IO Bool
tryConversion (TCMT IO () -> TCMT IO Bool) -> TCMT IO () -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ Type'' Term Term -> Type'' Term Term -> TCMT IO ()
equalType Type'' Term Term
a1 Type'' Term Term
a2
        case (Maybe TCState
mst1, Maybe TCState
mst2) of
          (Maybe TCState
Nothing, Maybe TCState
Nothing) -> TCMT IO Bool
cmpTypes
          (Just TCState
st, Maybe TCState
Nothing) -> TCState -> TCMT IO Bool -> TCMT IO Bool
forall {a}. TCState -> TCMT IO a -> TCMT IO a
inState TCState
st TCMT IO Bool
cmpTypes
          (Maybe TCState
Nothing, Just TCState
st) -> TCState -> TCMT IO Bool -> TCMT IO Bool
forall {a}. TCState -> TCMT IO a -> TCMT IO a
inState TCState
st TCMT IO Bool
cmpTypes
          -- Andreas, 2020-06-17, issue #4135.
          -- If the state has diverged into two states we give up.
          -- For instance, one state may say `?0 := true`
          -- and the other `?0 := false`.
          -- The types may be both `D ?0`, which is the same
          -- but diverges in the different states.
          -- We do not check states for equality.
          --
          -- Of course, this is conservative and not maximally extensional.
          -- We might throw an ambiguity error too eagerly,
          -- but this can always be worked around.
          (Just{},  Just{})  -> Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
      inState :: TCState -> TCMT IO a -> TCMT IO a
inState TCState
st TCMT IO a
m = TCMT IO a -> TCMT IO a
forall a. TCM a -> TCM a
localTCState (TCMT IO a -> TCMT IO a) -> TCMT IO a -> TCMT IO a
forall a b. (a -> b) -> a -> b
$ do TCState -> TCMT IO ()
forall (m :: * -> *). MonadTCState m => TCState -> m ()
putTC TCState
st; TCMT IO a
m

-- | @checkConstructorParameters c d pars@ checks that the data/record type
--   behind @c@ is has initial parameters (coming e.g. from a module instantiation)
--   that coincide with an prefix of @pars@.
checkConstructorParameters :: MonadTCM tcm => QName -> QName -> Args -> tcm ()
checkConstructorParameters :: forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> [Arg Term] -> tcm ()
checkConstructorParameters QName
c QName
d [Arg Term]
pars = do
  dc <- TCMT IO QName -> tcm QName
forall a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO QName -> tcm QName) -> TCMT IO QName -> tcm QName
forall a b. (a -> b) -> a -> b
$ QName -> TCMT IO QName
forall (m :: * -> *).
(HasCallStack, HasConstInfo m) =>
QName -> m QName
getConstructorData QName
c
  checkParameters dc d pars

-- | Check that given parameters match the parameters of the inferred
--   constructor/projection.
checkParameters
  :: MonadTCM tcm
  => QName  -- ^ The record/data type name of the chosen constructor/projection.
  -> QName  -- ^ The record/data type name as supplied by the type signature.
  -> Args   -- ^ The parameters.
  -> tcm ()
checkParameters :: forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> [Arg Term] -> tcm ()
checkParameters QName
dc QName
d [Arg Term]
pars = 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
$ do
  a  <- Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (QName -> Elims -> Term
Def QName
dc [])
  case a of
    Def QName
d0 Elims
es -> do -- compare parameters
      let vs :: [Arg Term]
vs = Elims -> [Arg Term]
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims Elims
es
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" 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] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        [ TCMT IO Doc
"checkParameters"
        , 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
"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. Pretty a => a -> [Char]
prettyShow) QName
d
        , 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
"d0 (should be == 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. Pretty a => a -> [Char]
prettyShow) QName
d0
        , 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
"dc                  =" 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. Pretty a => a -> [Char]
prettyShow) QName
dc
        , 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
"vs                  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Arg Term] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Arg Term] -> m Doc
prettyTCM [Arg Term]
vs
        , 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
"pars                =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Arg Term] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Arg Term] -> m Doc
prettyTCM [Arg Term]
pars
        ]
      -- when (d0 /= d) __IMPOSSIBLE__ -- d could have extra qualification
      t <- QName -> TCMT IO (Type'' Term Term)
forall (m :: * -> *).
(HasConstInfo m, ReadTCState m) =>
QName -> m (Type'' Term Term)
typeOfConst QName
d
      compareArgs [] [] t (Def d []) vs (take' (length vs) pars)
    Term
_ -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__

checkSortOfSplitVar :: (MonadTCM m, PureTCM m, MonadError TCErr m,
                        LensSort a, PrettyTCM a, LensSort ty, PrettyTCM ty)
                    => DataOrRecord -> a -> Telescope -> Maybe ty -> m ()
checkSortOfSplitVar :: forall (m :: * -> *) a ty.
(MonadTCM m, PureTCM m, MonadError TCErr m, LensSort a,
 PrettyTCM a, LensSort ty, PrettyTCM ty) =>
DataOrRecord
-> a -> Tele (Dom (Type'' Term Term)) -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr a
a Tele (Dom (Type'' Term Term))
tel Maybe ty
mtarget = do
  let s :: Sort' Term
s = a -> Sort' Term
forall a. LensSort a => a -> Sort' Term
getSort a
a
  sa <- TCM (Sort' Term) -> m (Sort' Term)
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Sort' Term) -> m (Sort' Term))
-> TCM (Sort' Term) -> m (Sort' Term)
forall a b. (a -> b) -> a -> b
$ Sort' Term -> TCM (Sort' Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Sort' Term
s
  case sortUniv sa of
    Just UType{} -> m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
forall (m :: * -> *). HasOptions m => m Bool
isTwoLevelEnabled m ()
checkFibrantSplit
    Just UProp{} -> m ()
checkPropSplit
    Just USSet{} -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Maybe Univ
Nothing      -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m ()) -> m TypeError -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM TypeError -> m TypeError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> m TypeError) -> TCM TypeError -> m TypeError
forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> TypeError
SortOfSplitVarError (Maybe Blocker -> Doc -> TypeError)
-> TCMT IO (Maybe Blocker) -> TCMT IO (Doc -> TypeError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> TCMT IO (Maybe Blocker)
forall t (m :: * -> *).
(Reduce t, IsMeta t, MonadReduce m) =>
t -> m (Maybe Blocker)
isBlocked Sort' Term
sa TCMT IO (Doc -> TypeError) -> TCMT IO Doc -> TCM TypeError
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ TCMT IO Doc
"Cannot split on datatype in sort" , 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
s]

  where
    checkPropSplit :: m ()
checkPropSplit
      | IsRecord InductionAndEta { recordInduction :: InductionAndEta -> Maybe Induction
recordInduction=Maybe Induction
Nothing } <- DataOrRecord
dr = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Just ty
target <- Maybe ty
mtarget = do
        [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target prop:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ty -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ty -> m Doc
prettyTCM ty
target
        ty -> m ()
checkIsProp ty
target
      | Bool
otherwise              = do
          [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"no target prop"
          DataOrRecord -> m ()
forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
DataOrRecord -> m a
splitOnPropError DataOrRecord
dr

    checkIsProp :: ty -> m ()
checkIsProp ty
t = BlockT m Bool -> m (Either Blocker Bool)
forall (m :: * -> *) a. BlockT m a -> m (Either Blocker a)
runBlocked (ty -> BlockT m Bool
forall a (m :: * -> *).
(LensSort a, PrettyTCM a, PureTCM m, MonadBlock m) =>
a -> m Bool
isPropM ty
t) m (Either Blocker Bool) -> (Either Blocker Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Blocker
b      -> DataOrRecord -> m ()
forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
DataOrRecord -> m a
splitOnPropError DataOrRecord
dr -- TODO
      Right Bool
False -> DataOrRecord -> m ()
forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
DataOrRecord -> m a
splitOnPropError DataOrRecord
dr
      Right Bool
True  -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    checkFibrantSplit :: m ()
checkFibrantSplit
      | IsRecord InductionAndEta
_ <- DataOrRecord
dr       = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Just ty
target <- Maybe ty
mtarget = do
        [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
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
<+> ty -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ty -> m Doc
prettyTCM ty
target
        ty -> m ()
checkIsFibrant ty
target
        let
          loop :: Tele (Dom (Type'' Term Term)) -> m ()
loop Tele (Dom (Type'' Term Term))
EmptyTel = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          loop (ExtendTel Dom (Type'' Term Term)
a Abs (Tele (Dom (Type'' Term Term)))
tel) = do
            Type'' Term Term -> m ()
checkIsCoFibrant (Dom (Type'' Term Term) -> Type'' Term Term
forall t e. Dom' t e -> e
unDom Dom (Type'' Term Term)
a)
            Dom (Type'' Term Term)
-> Abs (Tele (Dom (Type'' Term Term)))
-> (Tele (Dom (Type'' Term Term)) -> m ())
-> m ()
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Dom (Type'' Term Term) -> Abs a -> (a -> m b) -> m b
underAbstractionAbs Dom (Type'' Term Term)
a Abs (Tele (Dom (Type'' Term Term)))
tel Tele (Dom (Type'' Term Term)) -> m ()
loop
        Tele (Dom (Type'' Term Term)) -> m ()
loop Tele (Dom (Type'' Term Term))
tel
      | Bool
otherwise              = do
          [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"no target"
          Maybe Blocker -> m ()
splitOnFibrantError Maybe Blocker
forall a. Maybe a
Nothing

    -- Cofibrant types are those that could be the domain of a fibrant
    -- pi type. (Notion by C. Sattler).
    checkIsCoFibrant :: Type'' Term Term -> m ()
checkIsCoFibrant Type'' Term Term
t = Type'' Term Term -> m (Either Blocker Bool)
forall a (m :: * -> *).
(LensSort a, PureTCM m) =>
a -> m (Either Blocker Bool)
isCoFibrantSort Type'' Term Term
t m (Either Blocker Bool) -> (Either Blocker Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Blocker
b      -> Type'' Term Term -> Maybe Blocker -> m ()
splitOnFibrantError' Type'' Term Term
t (Maybe Blocker -> m ()) -> Maybe Blocker -> m ()
forall a b. (a -> b) -> a -> b
$ Blocker -> Maybe Blocker
forall a. a -> Maybe a
Just Blocker
b
      Right Bool
False -> m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (Type'' Term Term -> m Bool
forall (m :: * -> *). MonadTCM m => Type'' Term Term -> m Bool
isInterval Type'' Term Term
t) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                       Type'' Term Term -> Maybe Blocker -> m ()
splitOnFibrantError' Type'' Term Term
t (Maybe Blocker -> m ()) -> Maybe Blocker -> m ()
forall a b. (a -> b) -> a -> b
$ Maybe Blocker
forall a. Maybe a
Nothing
      Right Bool
True  -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    checkIsFibrant :: ty -> m ()
checkIsFibrant ty
t = ty -> m (Either Blocker Bool)
forall a (m :: * -> *).
(LensSort a, PureTCM m) =>
a -> m (Either Blocker Bool)
isFibrant' ty
t m (Either Blocker Bool) -> (Either Blocker Bool -> m ()) -> m ()
forall a b. m a -> (a -> m b) -> m b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left Blocker
b      -> Maybe Blocker -> m ()
splitOnFibrantError (Maybe Blocker -> m ()) -> Maybe Blocker -> m ()
forall a b. (a -> b) -> a -> b
$ Blocker -> Maybe Blocker
forall a. a -> Maybe a
Just Blocker
b
      Right Bool
False -> Maybe Blocker -> m ()
splitOnFibrantError Maybe Blocker
forall a. Maybe a
Nothing
      Right Bool
True  -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    splitOnPropError :: DataOrRecord -> m a
splitOnPropError DataOrRecord
dr = TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m a) -> TypeError -> m a
forall a b. (a -> b) -> a -> b
$ DataOrRecord -> TypeError
SplitInProp DataOrRecord
dr

    splitOnFibrantError' :: Type'' Term Term -> Maybe Blocker -> m ()
splitOnFibrantError' Type'' Term Term
t Maybe Blocker
mb = TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m ()) -> m TypeError -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM TypeError -> m TypeError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> m TypeError) -> TCM TypeError -> m TypeError
forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> TypeError
SortOfSplitVarError Maybe Blocker
mb (Doc -> TypeError) -> TCMT IO Doc -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep
        [ TCMT IO Doc
"Cannot eliminate fibrant type" , a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
a
        , TCMT IO Doc
"unless context type", Type'' Term Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type'' Term Term -> m Doc
prettyTCM Type'' Term Term
t, TCMT IO Doc
"is also fibrant."
        ]

    splitOnFibrantError :: Maybe Blocker -> m ()
splitOnFibrantError Maybe Blocker
mb = TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m ()) -> m TypeError -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM TypeError -> m TypeError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> m TypeError) -> TCM TypeError -> m TypeError
forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> TypeError
SortOfSplitVarError Maybe Blocker
mb (Doc -> TypeError) -> TCMT IO Doc -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep
        [ TCMT IO Doc
"Cannot eliminate fibrant type" , a -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => a -> m Doc
prettyTCM a
a
        , TCMT IO Doc
"unless target type is also fibrant"
        ]