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

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

import Prelude hiding ( null )

import Data.Function (on)
import Data.Maybe
import Data.Text.Short (ShortText)

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

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

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

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

import Mikan.TypeChecking.Monad

import Mikan.TypeChecking.Monad.Benchmark qualified as Bench
import Mikan.TypeChecking.Conversion
import Mikan.TypeChecking.Constraints
import Mikan.TypeChecking.CheckInternal (checkInternal)
import Mikan.TypeChecking.Datatypes hiding (isDataOrRecordType)
import Mikan.TypeChecking.Errors.Deferred
import Mikan.TypeChecking.Errors (dropTopLevelModule)
import Mikan.TypeChecking.Coverage.Errors
import Mikan.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 #-} Mikan.TypeChecking.Empty (ensureEmptyType)
import Mikan.TypeChecking.Patterns.Abstract
import Mikan.TypeChecking.Pretty
import Mikan.TypeChecking.Records hiding (getRecordConstructor)
import Mikan.TypeChecking.Reduce
import Mikan.TypeChecking.Sort
import Mikan.TypeChecking.Substitute
import Mikan.TypeChecking.Telescope
import Mikan.TypeChecking.Telescope.Path
import Mikan.TypeChecking.Primitive hiding (Nat)
import Mikan.TypeChecking.Warnings (warning)
import Mikan.TypeChecking.Implicit
import Mikan.TypeChecking.MetaVars

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

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

import Mikan.Utils.Impossible
import Mikan.TypeChecking.Free (freeIn)
import Mikan.Utils.Permutation (idP)

-- | 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
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 -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern
p = do
    String -> Int -> TCMT IO Doc -> MaybeT m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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 -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
p
    String -> Int -> TCMT IO Doc -> MaybeT m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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
<+> (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (String -> TCMT IO Doc)
-> (Pattern -> String) -> Pattern -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> String
forall a. Show a => a -> String
show (Pattern -> String) -> (Pattern -> Pattern) -> Pattern -> String
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> Pattern
forall a. ExprLike a => a -> a
deepUnscope) Pattern
p
    case Pattern
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
p -> Pattern -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
HasConstInfo m =>
Pattern -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern
p
      A.ConP ConPatInfo
_ AmbiguousQName
cs [NamedArg Pattern]
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-}
            ([NamedArg Pattern] -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
HasConstInfo m =>
[NamedArg Pattern] -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [NamedArg Pattern]
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
_ -> 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
      I.MaskP{}   -> MaybeT m FlexibleVarKind
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | 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)
tel     = LHSState a
st LHSState a
-> Getting (Tele (Dom Type)) (LHSState a) (Tele (Dom Type))
-> Tele (Dom Type)
forall s a. s -> Getting a s a -> a
^. Getting (Tele (Dom Type)) (LHSState a) (Tele (Dom Type))
forall a (f :: * -> *).
Functor f =>
(Tele (Dom Type) -> f (Tele (Dom Type)))
-> 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' <- LHSState a -> TCM [ProblemEq] -> TCM [ProblemEq]
forall b a. LHSState b -> TCM a -> TCM a
inLHSContext LHSState a
st (TCM [ProblemEq] -> TCM [ProblemEq])
-> TCM [ProblemEq] -> TCM [ProblemEq]
forall a b. (a -> b) -> a -> b
$ [ProblemEq] -> TCM [ProblemEq]
updateProblemEqs ([ProblemEq] -> TCM [ProblemEq]) -> [ProblemEq] -> TCM [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] -> TCM [ProblemEq]
updateProblemEqs [ProblemEq]
eqs = do
  String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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] -> TCM [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] -> TCM [ProblemEq]
updates = [[ProblemEq]] -> [ProblemEq]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ProblemEq]] -> [ProblemEq])
-> ([ProblemEq] -> TCMT IO [[ProblemEq]])
-> [ProblemEq]
-> TCM [ProblemEq]
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> (ProblemEq -> TCM [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 -> TCM [ProblemEq]
update

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

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

        let bs = Tele (Dom Type) -> [Term] -> [Dom Type]
instTel Tele (Dom Type)
ctel ((Arg Term -> Term) -> Args -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg Args
vs)

        p <- expandLitPattern p
        case p of
          A.AsP{} -> TCM [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
          A.ConP ConPatInfo
cpi AmbiguousQName
ambC [NamedArg Pattern]
ps -> do
            (c',_) <- Int -> AmbiguousQName -> QName -> Args -> TCM (ConHead, Type)
disambiguateConstructor Int
0 AmbiguousQName
ambC QName
d Args
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 (NamedArg Pattern
p : [NamedArg Pattern]
ps) (Arg Term
v : Args
vs) Int
nExpected Int
nActual
                  | NamedArg Pattern -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding NamedArg Pattern
p Hiding -> Hiding -> Bool
forall a. Eq a => a -> a -> Bool
== Arg Term -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg Term
v = [NamedArg Pattern] -> Args -> Int -> Int -> TCMT IO ()
checkArgs [NamedArg Pattern]
ps Args
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                  = NamedArg Pattern -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Pattern
p (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Hiding -> TypeError
WrongHidingInLHS (Hiding -> TypeError) -> Hiding -> TypeError
forall a b. (a -> b) -> a -> b
$ Arg Term -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg Term
v
                checkArgs [] Args
vs Int
nExpected Int
nActual = TypeError -> TCMT IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> 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
+ Args -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Args
vs) Int
nActual
                checkArgs (NamedArg Pattern
p : [NamedArg Pattern]
ps) [] Int
nExpected Int
nActual = NamedArg Pattern -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Pattern
p (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> 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
+ ([NamedArg Pattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [NamedArg Pattern]
ps))

            checkArgs ps vs 0 0

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

          A.RecP KwRange
_ ConPatInfo
_ [FieldAssignment' Pattern]
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 -> Term -> Dom Type -> ProblemEq)
-> [Pattern] -> [Term] -> [Dom Type] -> [ProblemEq]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq ((NamedArg Pattern -> Pattern) -> [NamedArg Pattern] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map' NamedArg Pattern -> Pattern
forall a. NamedArg a -> a
namedArg [NamedArg Pattern]
ps) ((Arg Term -> Term) -> Args -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map' Arg Term -> Term
forall e. Arg e -> e
unArg Args
vs) [Dom Type]
bs
            updates eqs

          Pattern
_ -> [ProblemEq] -> TCM [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
p , Literal
l Literal -> Literal -> Bool
forall a. Eq a => a -> a -> Bool
== Literal
l' -> [ProblemEq] -> TCM [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []

      Term
_ | A.EqualP{} <- Pattern
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] -> TCM [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] -> [Dom Type]
instTel Tele (Dom Type)
EmptyTel [Term]
_                   = []
    instTel (ExtendTel Dom Type
arg Abs (Tele (Dom Type))
tel) (Term
u : [Term]
us) = Dom Type
arg Dom Type -> [Dom Type] -> [Dom Type]
forall a. a -> [a] -> [a]
: Tele (Dom Type) -> [Term] -> [Dom Type]
instTel (Abs (Tele (Dom Type))
-> SubstArg (Tele (Dom Type)) -> Tele (Dom Type)
forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs (Tele (Dom Type))
tel Term
SubstArg (Tele (Dom Type))
u) [Term]
us
    instTel ExtendTel{} []               = [Dom Type]
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 = [NamedArg Pattern] -> Bool
forall a. Null a => a -> Bool
null (Problem a
problem Problem a
-> Getting [NamedArg Pattern] (Problem a) [NamedArg Pattern]
-> [NamedArg Pattern]
forall s a. s -> Getting a s a -> a
^. Getting [NamedArg Pattern] (Problem a) [NamedArg Pattern]
forall a (f :: * -> *).
Functor f =>
([NamedArg Pattern] -> f [NamedArg Pattern])
-> 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 -> Bool) -> [Pattern] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all Pattern -> Bool
forall {e}. Pattern' e -> Bool
isSolved ([Pattern] -> Bool) -> [Pattern] -> Bool
forall a b. (a -> b) -> a -> b
$
      (NamedArg Pattern -> Pattern) -> [NamedArg Pattern] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map' NamedArg Pattern -> Pattern
forall a. NamedArg a -> a
namedArg (Problem a
problem Problem a
-> Getting [NamedArg Pattern] (Problem a) [NamedArg Pattern]
-> [NamedArg Pattern]
forall s a. s -> Getting a s a -> a
^. Getting [NamedArg Pattern] (Problem a) [NamedArg Pattern]
forall a (f :: * -> *).
Functor f =>
([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
problemRestPats) [Pattern] -> [Pattern] -> [Pattern]
forall a. [a] -> [a] -> [a]
++! Problem a -> [Pattern]
forall a. Problem a -> [Pattern]
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
p Term
_ dom :: Dom Type
dom@(Dom Type -> Type
forall t e. Dom' t e -> e
unDom -> El Sort' Term
_ Term
a)) = do
  let info :: ArgInfo
info = Dom Type
dom Dom Type -> Getting ArgInfo (Dom Type) ArgInfo -> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom Type) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo
  case Pattern
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
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
    String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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
      [ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (String -> TCMT IO Doc) -> String -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ String
"checking whether pattern variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++! Name -> String
forall a. Pretty a => a -> String
prettyShow Name
x String -> String -> String
forall a. [a] -> [a] -> [a]
++! String
" 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
<+> (String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (String -> TCMT IO Doc)
-> (Range -> String) -> Range -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> String
forall a. Show a => a -> String
show) (Name -> Range
forall a. HasRange a => a -> Range
getRange Name
x)
      ]
    String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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 TCM 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 TCM 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 TCM Term)
-> TCMT IO Term -> MaybeT TCM 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 :: * -> *) e.
(HasCallStack, MonadWarning m, Diagnostic e) =>
e -> 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
dom@(Dom Type -> Type
forall t e. Dom' t e -> e
unDom -> Type
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
  String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
a
        ]
  u <- Expr -> Type -> TCMT IO Term
checkExpr Expr
e Type
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
r Type
a) = Range -> Type -> TCMT IO ()
ensureEmptyType Range
r Type
a

checkAnnotationPattern :: AnnotationPattern -> TCM ()
checkAnnotationPattern :: AnnotationPattern -> TCMT IO ()
checkAnnotationPattern (Ann Expr
t Type
a) = do
  String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
a
        ]
  b <- Expr -> TCMT IO Type
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 :: [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transferOrigins [NamedArg Pattern]
ps [NamedArg DeBruijnPattern]
qs = do
  String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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
<+> [NamedArg Pattern] -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA [NamedArg Pattern]
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
      ]
    ]
  [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [NamedArg Pattern]
ps [NamedArg DeBruijnPattern]
qs

  where
    transfers :: [NamedArg A.Pattern]
              -> [NamedArg DeBruijnPattern]
              -> TCM [NamedArg DeBruijnPattern]
    transfers :: [NamedArg Pattern]
-> [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 (NamedArg Pattern
p : [NamedArg Pattern]
ps) [] = TCM [NamedArg DeBruijnPattern]
forall a. HasCallStack => a
__IMPOSSIBLE__
    transfers (NamedArg Pattern
p : [NamedArg Pattern]
ps) (NamedArg DeBruijnPattern
q : [NamedArg DeBruijnPattern]
qs)
      | NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
matchingArgs NamedArg Pattern
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
$ NamedArg Pattern -> Maybe (NameOf (NamedArg Pattern))
forall a. LensNamed a => a -> Maybe (NameOf a)
getNameOf NamedArg Pattern
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 (NamedArg Pattern -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Pattern
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 -> DeBruijnPattern -> TCMT IO DeBruijnPattern
transfer (Pattern -> DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> Pattern -> DeBruijnPattern -> TCMT IO DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ NamedArg Pattern -> Pattern
forall a. NamedArg a -> a
namedArg NamedArg Pattern
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
<$> [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers (NamedArg Pattern
p NamedArg Pattern -> [NamedArg Pattern] -> [NamedArg Pattern]
forall a. a -> [a] -> [a]
: [NamedArg Pattern]
ps) [NamedArg DeBruijnPattern]
qs

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

      (([Name]
asB , A.ConP ConPatInfo
pi AmbiguousQName
_ [NamedArg Pattern]
ps) , ConP ConHead
c (ConPatternInfo PatternInfo
i Bool
r Bool
ft Maybe (Arg Type)
mb Bool
l) [NamedArg DeBruijnPattern]
qs) -> do
        let cpi :: ConPatternInfo
cpi = PatternInfo
-> Bool -> Bool -> Maybe (Arg Type) -> Bool -> ConPatternInfo
ConPatternInfo (PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatOCon [Name]
asB) Bool
r Bool
ft Maybe (Arg Type)
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
<$> [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [NamedArg Pattern]
ps [NamedArg DeBruijnPattern]
qs

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

      (([Name]
asB , Pattern
p) , ConP ConHead
c (ConPatternInfo PatternInfo
i Bool
r Bool
ft Maybe (Arg Type)
mb Bool
l) [NamedArg DeBruijnPattern]
qs) -> do
        let cpi :: ConPatternInfo
cpi = PatternInfo
-> Bool -> Bool -> Maybe (Arg Type) -> Bool -> ConPatternInfo
ConPatternInfo (PatOrigin -> [Name] -> PatternInfo
PatternInfo (Pattern -> PatOrigin
patOrig Pattern
p) [Name]
asB) Bool
r Bool
ft Maybe (Arg Type)
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
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 -> PatOrigin
patOrig Pattern
p) [Name]
asB) DBPatVar
x

      (([Name]
asB , Pattern
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 -> PatOrigin
patOrig Pattern
p) [Name]
asB) Term
u

      (([Name]
asB , Pattern
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 -> PatOrigin
patOrig Pattern
p) [Name]
asB) Literal
l

      (([Name], Pattern), 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 -> 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 :: NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
matchingArgs NamedArg Pattern
p NamedArg DeBruijnPattern
q
      -- The arguments match if
      -- 1. they are both projections,
      | Maybe (ProjOrigin, AmbiguousQName) -> Bool
forall a. Maybe a -> Bool
isJust (NamedArg Pattern -> Maybe (ProjOrigin, AmbiguousQName)
forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
A.isProjP NamedArg Pattern
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,
      | NamedArg Pattern -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Pattern
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,
      | NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding NamedArg Pattern
p NamedArg DeBruijnPattern
q Bool -> Bool -> Bool
&& Maybe NamedName -> Bool
forall a. Maybe a -> Bool
isNothing (NamedArg Pattern -> Maybe (NameOf (NamedArg Pattern))
forall a. LensNamed a => a -> Maybe (NameOf a)
getNameOf NamedArg Pattern
p) = Bool
True
      -- 4. or they have the same hiding and the same name.
      | NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding NamedArg Pattern
p NamedArg DeBruijnPattern
q Bool -> Bool -> Bool
&& NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
forall a b.
(LensNamed a, LensNamed b, NameOf a ~ NamedName,
 NameOf b ~ NamedName) =>
a -> b -> Bool
namedSame NamedArg Pattern
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] -> TCM [ProblemEq]
checkPatternLinearity [ProblemEq]
eqs = do
  String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> [ProblemEq] -> TCM [ProblemEq]
check Map BindName (Term, Type)
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) -> [ProblemEq] -> TCM [ProblemEq]
check Map BindName (Term, Type)
_ [] = [ProblemEq] -> TCM [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    check Map BindName (Term, Type)
vars (eq :: ProblemEq
eq@(ProblemEq Pattern
p Term
u Dom Type
a) : [ProblemEq]
eqs) = do
      String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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 -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Dom Type -> m Doc
prettyTCM Dom Type
a
        ]
      case Pattern
p of
        A.VarP BindName
x -> do
          let y :: Name
y = BindName -> Name
A.unBind BindName
x
          String -> Int -> String -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> String -> m ()
reportSLn String
"tc.lhs.linear" Int
60 (String -> TCMT IO ()) -> String -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
            String
"pattern variable " String -> String -> String
forall a. [a] -> [a] -> [a]
++! Name -> String
forall a. Pretty a => a -> String
prettyShow (Name -> Name
A.nameConcrete Name
y) String -> String -> String
forall a. [a] -> [a] -> [a]
++! String
" with id " String -> String -> String
forall a. [a] -> [a] -> [a]
++! NameId -> String
forall a. Show a => a -> String
show (Name -> NameId
forall a. HasNameId a => a -> NameId
A.nameId Name
y)
          case BindName -> Map BindName (Term, Type) -> Maybe (Term, Type)
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BindName
x Map BindName (Term, Type)
vars of
            Just (Term
v , Type
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, MonadFresh ProblemId m) =>
m a -> m a
noConstraints (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> TCMT IO ()
equalType (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
a) Type
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, 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 -> TCMT IO ()
equalTerm (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
a) Term
u Term
v
              Map BindName (Term, Type) -> [ProblemEq] -> TCM [ProblemEq]
check Map BindName (Term, Type)
vars [ProblemEq]
eqs
            Maybe (Term, Type)
Nothing -> (ProblemEq
eqProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq]) -> TCM [ProblemEq] -> TCM [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              Map BindName (Term, Type) -> [ProblemEq] -> TCM [ProblemEq]
check (BindName
-> (Term, Type)
-> Map BindName (Term, Type)
-> Map BindName (Term, Type)
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BindName
x (Term
u,Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
a) Map BindName (Term, Type)
vars) [ProblemEq]
eqs
        A.AsP PatInfo
_ BindName
x Pattern
p ->
          Map BindName (Term, Type) -> [ProblemEq] -> TCM [ProblemEq]
check Map BindName (Term, Type)
vars ([ProblemEq] -> TCM [ProblemEq]) -> [ProblemEq] -> TCM [ProblemEq]
forall a b. (a -> b) -> a -> b
$ [Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (BindName -> Pattern
forall e. BindName -> Pattern' e
A.VarP BindName
x) Term
u Dom Type
a, Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq Pattern
p Term
u Dom Type
a] [ProblemEq] -> [ProblemEq] -> [ProblemEq]
forall a. [a] -> [a] -> [a]
++! [ProblemEq]
eqs
        A.WildP{}       -> TCM [ProblemEq]
continue
        A.DotP{}        -> TCM [ProblemEq]
continue
        A.AbsurdP{}     -> TCM [ProblemEq]
continue
        A.ConP{}        -> TCM [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.ProjP{}       -> TCM [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.DefP{}        -> TCM [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.LitP{}        -> TCM [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.PatternSynP{} -> TCM [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.RecP{}        -> TCM [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.EqualP{}      -> TCM [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.WithP{}       -> TCM [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__

      where continue :: TCM [ProblemEq]
continue = (ProblemEq
eqProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq]) -> TCM [ProblemEq] -> TCM [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map BindName (Term, Type) -> [ProblemEq] -> TCM [ProblemEq]
check Map BindName (Term, Type)
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) -> TCM Context
computeLHSContext = Context -> [Name] -> [Maybe Name] -> Tele (Dom Type) -> TCM Context
forall {m :: * -> *}.
(MonadDebug m, MonadFresh NameId m) =>
Context -> [Name] -> [Maybe Name] -> Tele (Dom Type) -> m Context
go Context
CxEmpty []
  where
    go :: Context -> [Name] -> [Maybe Name] -> Tele (Dom Type) -> m Context
go Context
cxt [Name]
_ []        tel :: Tele (Dom Type)
tel@ExtendTel{} = do
      String -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
tel
      m Context
forall a. HasCallStack => a
__IMPOSSIBLE__
    go Context
cxt [Name]
_ (Maybe Name
_ : [Maybe Name]
_)   Tele (Dom Type)
EmptyTel = m Context
forall a. HasCallStack => a
__IMPOSSIBLE__
    go Context
cxt [Name]
_ []        Tele (Dom Type)
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)
tel0@(ExtendTel Dom Type
a Abs (Tele (Dom Type))
tel) = do
        name <- m Name -> (Name -> m Name) -> Maybe Name -> m Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Name] -> ShortText -> m Name
forall {m :: * -> *} {p}.
MonadFresh NameId m =>
p -> ShortText -> m Name
dummyName [Name]
taken (ShortText -> m Name) -> ShortText -> m Name
forall a b. (a -> b) -> a -> b
$ Abs (Tele (Dom Type)) -> ShortText
forall a. Abs a -> ShortText
absName Abs (Tele (Dom Type))
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 -> ShortText -> m Name
dummyName p
taken ShortText
s =
      if ShortText -> Bool
forall a. Underscore a => a -> Bool
isUnderscore ShortText
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
<$> ShortText -> m Name
forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
forall (m :: * -> *). MonadFresh NameId m => ShortText -> m Name
freshName_ (ShortText -> ShortText
argNameToString ShortText
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
a : [AsBinding]
asb) TCM a
ret = do
  String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Dom Type -> m Doc
prettyTCM Dom Type
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 -> TCM a -> TCM a
forall a.
IsAxiom
-> Origin -> Name -> Term -> Dom Type -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadAddContext m =>
IsAxiom -> Origin -> Name -> Term -> Dom Type -> m a -> m a
addLetBinding' IsAxiom
NoAxiom Origin
Inserted Name
x Term
v Dom Type
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
p Term
v Dom Type
a)
  | A.WildP{} <- Pattern
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 -> Type
forall t e. Dom' t e -> e
unDom Dom Type
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 :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
IllTypedPatternAfterWithAbstraction Pattern
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)
lhsVarTele      :: Telescope
    -- ^ Δ : The types of the pattern variables, in internal dependency order.
    -- Corresponds to 'clauseTel'.
  , 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 -> Type
lhsBodyType     :: Type
    -- ^ The type of the body. Is @bσ@ if @Γ@ is defined.
  , 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)
tel [NamedArg DeBruijnPattern]
ps Bool
abs Type
t Substitution
sub [AsBinding]
as IntSet
psplit Bool
ixsplit) = Int
-> Tele (Dom Type)
-> [NamedArg DeBruijnPattern]
-> Bool
-> Type
-> Substitution
-> [AsBinding]
-> IntSet
-> Bool
-> LHSResult
LHSResult Int
n
    (Tele (Dom Type)
 -> [NamedArg DeBruijnPattern]
 -> Bool
 -> Type
 -> Substitution
 -> [AsBinding]
 -> IntSet
 -> Bool
 -> LHSResult)
-> ReduceM (Tele (Dom Type))
-> ReduceM
     ([NamedArg DeBruijnPattern]
      -> Bool
      -> Type
      -> Substitution
      -> [AsBinding]
      -> IntSet
      -> Bool
      -> LHSResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Tele (Dom Type) -> ReduceM (Tele (Dom Type))
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Tele (Dom Type)
tel
    ReduceM
  ([NamedArg DeBruijnPattern]
   -> Bool
   -> Type
   -> Substitution
   -> [AsBinding]
   -> IntSet
   -> Bool
   -> LHSResult)
-> ReduceM [NamedArg DeBruijnPattern]
-> ReduceM
     (Bool
      -> Type
      -> 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
   -> Type
   -> Substitution
   -> [AsBinding]
   -> IntSet
   -> Bool
   -> LHSResult)
-> ReduceM Bool
-> ReduceM
     (Type
      -> 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
  (Type
   -> Substitution -> [AsBinding] -> IntSet -> Bool -> LHSResult)
-> ReduceM Type
-> 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
<*> Type -> ReduceM Type
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Type
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

-- | Building substitutions from out patterns needs to handle with-functions
--   specially.
data LHSSubstitutionCase = NormalFunSubst | WithFunSubst Int Substitution

lhsSubstitutionCase :: Int -> Maybe Substitution -> LHSSubstitutionCase
lhsSubstitutionCase :: Int -> Maybe Substitution -> LHSSubstitutionCase
lhsSubstitutionCase Int
arity Maybe Substitution
Nothing        = LHSSubstitutionCase
NormalFunSubst
lhsSubstitutionCase Int
arity (Just Substitution
withSub) = Int -> Substitution -> LHSSubstitutionCase
WithFunSubst Int
arity Substitution
withSub

-- | 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)
--
--      Δ   ⊢ patSub  : Ψ Θ
--      Ψ Θ ⊢ weakSub : Ψ
--      Ψ   ⊢ withSub : Γ
--      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.
--
--      NOTE: withSub is not actually well-typed! There is in general
--      no way to get from the abstracted context back into the parent context.
--      When using withSub, one should thus be extra careful that the result is
--      well-typed (see agda#8698).
buildLHSSubstitutions :: Context -> NAPs -> LHSSubstitutionCase
  -> (Substitution, Substitution)
buildLHSSubstitutions :: Context
-> [NamedArg DeBruijnPattern]
-> LHSSubstitutionCase
-> (Substitution, Substitution)
buildLHSSubstitutions Context
cxt [NamedArg DeBruijnPattern]
ps LHSSubstitutionCase
isWithFun = do
  let notProj :: Pattern' x -> Bool
notProj ProjP{} = Bool
False
      notProj Pattern' x
_       = Bool
True
      numPats :: Int
numPats = [NamedArg DeBruijnPattern] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ([NamedArg DeBruijnPattern] -> Int)
-> [NamedArg DeBruijnPattern] -> Int
forall a b. (a -> b) -> a -> b
$ (NamedArg DeBruijnPattern -> Bool)
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. (a -> Bool) -> [a] -> [a]
takeWhile (DeBruijnPattern -> Bool
forall {x}. Pattern' x -> Bool
notProj (DeBruijnPattern -> Bool)
-> (NamedArg DeBruijnPattern -> DeBruijnPattern)
-> NamedArg DeBruijnPattern
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg DeBruijnPattern -> DeBruijnPattern
forall a. NamedArg a -> a
namedArg) [NamedArg DeBruijnPattern]
ps
      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] -> [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ Int -> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. Int -> [a] -> [a]
take' Int
numPats [NamedArg DeBruijnPattern]
ps) [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 LHSSubstitutionCase
isWithFun of
        LHSSubstitutionCase
NormalFunSubst             ->
          (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)
        WithFunSubst 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@.
  -> Maybe 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.
  -> TCM a
checkLeftHandSide :: forall a.
Call
-> Range
-> LetOrClause
-> [NamedArg Pattern]
-> Type
-> Maybe Substitution
-> [ProblemEq]
-> (LHSResult -> TCM a)
-> TCM a
checkLeftHandSide Call
call Range
lhsRng LetOrClause
f [NamedArg Pattern]
ps Type
a Maybe Substitution
withSub' [ProblemEq]
strippedPats =
 Account (BenchPhase TCM)
-> ((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 TCM
Phase
Bench.Typing, BenchPhase TCM
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)
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 NamedName Pattern -> NamedArg Pattern
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Pattern -> Named NamedName Pattern
forall a name. a -> Named name a
unnamed (BindName -> Pattern
forall e. BindName -> Pattern' e
A.VarP (BindName -> Pattern) -> BindName -> Pattern
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 -> Term -> Dom Type -> ProblemEq)
-> [Pattern] -> [Term] -> [Dom Type] -> [ProblemEq]
forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq ((NamedArg Pattern -> Pattern) -> [NamedArg Pattern] -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map' NamedArg Pattern -> Pattern
forall a. NamedArg a -> a
namedArg [NamedArg Pattern]
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) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel) (Tele (Dom Type) -> [Dom Type]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel Tele (Dom Type)
tel)

  arity_a <- arityPiPath 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 finalChecks :: LHSState a -> TCM a
      finalChecks (LHSState Tele (Dom Type)
delta [NamedArg DeBruijnPattern]
qs0 (Problem [ProblemEq]
eqs [NamedArg Pattern]
rps LHSState a -> TCMT IO a
_) Type
b [Maybe Int]
psplit Bool
ixsplit Substitution
rho) = do

        String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
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) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta ([NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList [NamedArg DeBruijnPattern]
qs0)
          , 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
"rho =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta (Substitution -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Substitution -> m Doc
prettyTCM Substitution
rho)
          ]

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

        Tele (Dom Type) -> 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) -> m a -> m a
addContext Tele (Dom Type)
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

        let (Substitution
patSub, Substitution
paramSub) = Context
-> [NamedArg DeBruijnPattern]
-> LHSSubstitutionCase
-> (Substitution, Substitution)
buildLHSSubstitutions Context
cxt [NamedArg DeBruijnPattern]
qs0 (LHSSubstitutionCase -> (Substitution, Substitution))
-> LHSSubstitutionCase -> (Substitution, Substitution)
forall a b. (a -> b) -> a -> b
$
              Int -> Maybe Substitution -> LHSSubstitutionCase
lhsSubstitutionCase Int
arity_a Maybe Substitution
withSub'

        eqs <- Tele (Dom Type) -> TCM [ProblemEq] -> TCM [ProblemEq]
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta (TCM [ProblemEq] -> TCM [ProblemEq])
-> TCM [ProblemEq] -> TCM [ProblemEq]
forall a b. (a -> b) -> a -> b
$ [ProblemEq] -> TCM [ProblemEq]
checkPatternLinearity [ProblemEq]
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
$ ShortText -> Int -> DeBruijnPattern
forall a. DeBruijn a => ShortText -> Int -> a
deBruijnNamedVar (ShortText -> Int -> DeBruijnPattern)
-> (Name -> ShortText) -> Name -> Int -> DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> ShortText
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)
-> [NamedArg DeBruijnPattern]
-> Bool
-> Type
-> 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)
delta [NamedArg DeBruijnPattern]
qs Bool
hasAbsurd Type
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 = Substitution -> Maybe Substitution -> Substitution
forall a. a -> Maybe a -> a
fromMaybe Substitution
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe Substitution
withSub'
  withEqs <- updateProblemEqs $ applySubst withSub strippedPats
  -- Jesper, 2017-05-13: re-check the stripped patterns here!
  inTopContext $ addContext (st0 ^. lhsTel) $
    forM_ withEqs recheckStrippedWithPattern

  -- initLHSState computes a substitution for lifting from the clause
  -- telescope to the top-level. This is correct if we're checking a
  -- top-level function, but if we're checking a with function, it is
  -- incorrect, because the nearest checkpoint is the right-hand side of
  -- the parent clause.
  let
    st1 = 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
    st = case Maybe Substitution
withSub' of
      Just Substitution
sub -> LHSState a
st1{ _lhsParamSub = sub }
      Maybe Substitution
Nothing  -> LHSState a
st1

  -- doing the splits:
  let initLHSContext = LHSContext { lhsRange :: Range
lhsRange = Range
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

-- | 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
p Term
v Dom Type
a) = case Pattern
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
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)

-- | Compute a 'Context' assuming that the given 'Telescope' is a prefix
-- of that in the 'LHSState', taking names from the patterns.
lhsContext
  :: LHSState a   -- ^ The state to take names from
  -> Telescope    -- ^ The telescope to move to
  -> TCM Context
lhsContext :: forall a. LHSState a -> Tele (Dom Type) -> TCM Context
lhsContext LHSState{_lhsTel :: forall a. LHSState a -> Tele (Dom Type)
_lhsTel = Tele (Dom Type)
tel, _lhsProblem :: forall a. LHSState a -> Problem a
_lhsProblem = Problem a
problem} Tele (Dom Type)
delta1 = do
  names <- Tele (Dom Type) -> TCMT IO [Maybe Name] -> TCMT IO [Maybe Name]
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (TCMT IO [Maybe Name] -> TCMT IO [Maybe Name])
-> TCMT IO [Maybe Name] -> TCMT IO [Maybe Name]
forall a b. (a -> b) -> a -> b
$ do
    LeftoverPatterns{patternVariables = vars} <- [ProblemEq] -> TCMT IO LeftoverPatterns
forall (m :: * -> *).
(PureTCM m, MonadFresh NameId m) =>
[ProblemEq] -> m LeftoverPatterns
getLeftoverPatterns ([ProblemEq] -> TCMT IO LeftoverPatterns)
-> [ProblemEq] -> TCMT IO LeftoverPatterns
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
    return $! take' (size delta1) $ fst $ getUserVariableNames tel vars
  computeLHSContext names delta1

-- | Call the continuation in a context extended by the telescope of the
-- 'LHSState', /with/ proper substitutions to the nearest checkpoint.
inLHSContext :: LHSState b -> TCM a -> TCM a
inLHSContext :: forall b a. LHSState b -> TCM a -> TCM a
inLHSContext LHSState b
state TCM a
cont = String -> Int -> String -> TCM a -> TCM a
forall a. String -> Int -> String -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadDebug m =>
String -> Int -> String -> m a -> m a
verboseBracket String
"tc.lhs.checkpoint" Int
20 String
"inLHSContext" do

  -- Since the LHSState-managing functions already keep track of the
  -- substitution we need, this function is just gluing things together
  -- and debugging output.
  let LHSState{_lhsTel :: forall a. LHSState a -> Tele (Dom Type)
_lhsTel = Tele (Dom Type)
tel, _lhsOutPat :: forall a. LHSState a -> [NamedArg DeBruijnPattern]
_lhsOutPat = [NamedArg DeBruijnPattern]
ip, _lhsParamSub :: forall a. LHSState a -> Substitution
_lhsParamSub = Substitution
sigma} = LHSState b
state
  ctx <- LHSState b -> Tele (Dom Type) -> TCM Context
forall a. LHSState a -> Tele (Dom Type) -> TCM Context
lhsContext LHSState b
state Tele (Dom Type)
tel

  -- TODO: splitPartial implements a worse version of this function that
  -- only works for direct weakenings. The problem is that there we have
  --
  --   lhsTel = Δ₁ (p : Partial φ R) Δ₂
  --   lhsTel ⊢ σ : modCtx
  --
  -- and we need to return *terms* from Δ₁, i.e. we would need to decide
  -- whether we can decompose σ into
  --
  --   Δ₁ ⊢ σ' : modCtx
  --   lhsTel ⊢ σ = wk (p.Δ₂) σ'
  --                   ??????

  reportSDoc "tc.lhs.checkpoint" 30 $ vcat
    [ "adjusting context for precise checkpoints:"
    , nest 2 $ "ip      =" <+> pretty ip
    , nest 2 $ "tel     =" <+> prettyTCM tel
    , nest 2 $ "ctx     =" <+> prettyTCM tel
    , nest 2 $ "mod ctx =" <+> (prettyTCM =<< lookupSection =<< currentModule)
    , nest 2 $ "sigma   =" <+> prettyTCM sigma
    ]

  updateContext sigma (const ctx) do
    reportSDoc "tc.lhs.checkpoint" 30 $ vcat
      [ "survived adjusting context"
      , nest 2 $ "sigma   =" <+> prettyTCM sigma
      , nest 2 $ "mod app =" <+> (prettyTCM =<< moduleParamsToApply =<< currentModule)
      ]
    cont

-- | 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_ TCM) a
checkLHS_ where

 checkLHS_ :: LHSState a -> ReaderT LHSContext (WriterT Blocked_ TCM) a
checkLHS_ st :: LHSState a
st@(LHSState Tele (Dom Type)
tel [NamedArg DeBruijnPattern]
ip Problem a
problem Type
target [Maybe Int]
psplit Bool
ixsplit Substitution
sigma) = do
  String
-> Int
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.lhs.top.enter" Int
40 (TCMT IO Doc -> ReaderT LHSContext (WriterT Blocked_ TCM) ())
-> TCMT IO Doc -> ReaderT LHSContext (WriterT Blocked_ TCM) ()
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
"enter checkLHS_"
    , 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) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
tel
    , 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
"ip     =" 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
    , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
tel (Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
target)
    , 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
"sigma  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Substitution
sigma
    ]
  if Problem a -> Bool
forall a. Problem a -> Bool
isSolvedProblem Problem a
problem then
    TCM a -> ReaderT LHSContext (WriterT Blocked_ TCM) a
forall a. TCM a -> ReaderT LHSContext (WriterT Blocked_ TCM) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM a -> ReaderT LHSContext (WriterT Blocked_ TCM) a)
-> TCM a -> ReaderT LHSContext (WriterT Blocked_ TCM) 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

    String
-> Int
-> TCMT IO Doc
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.lhs.top" Int
30 (TCMT IO Doc -> ReaderT LHSContext (WriterT Blocked_ TCM) ())
-> TCMT IO Doc -> ReaderT LHSContext (WriterT Blocked_ TCM) ()
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_ TCM) Bool
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optPatternMatching (PragmaOptions -> Bool)
-> ReaderT LHSContext (WriterT Blocked_ TCM) PragmaOptions
-> ReaderT LHSContext (WriterT Blocked_ TCM) Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCState -> PragmaOptions)
-> ReaderT LHSContext (WriterT Blocked_ TCM) PragmaOptions
forall (m :: * -> *) a. ReadTCState m => (TCState -> a) -> m a
getsTC TCState -> PragmaOptions
forall a. LensPragmaOptions a => a -> PragmaOptions
getPragmaOptions) (ReaderT LHSContext (WriterT Blocked_ TCM) ()
 -> ReaderT LHSContext (WriterT Blocked_ TCM) ())
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
forall a b. (a -> b) -> a -> b
$
      Bool
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
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_ TCM) ()
 -> ReaderT LHSContext (WriterT Blocked_ TCM) ())
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
-> ReaderT LHSContext (WriterT Blocked_ TCM) ()
forall a b. (a -> b) -> a -> b
$
        TypeError -> ReaderT LHSContext (WriterT Blocked_ TCM) ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> 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_ TCM) (Either [TCErr] (LHSState a))
 -> ReaderT
      LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a)))
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
-> [ProblemEq]
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (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_ TCM) (Either [TCErr] (LHSState a))
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
trySplit ReaderT
  LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
trySplitRest [ProblemEq]
splitsToTry ReaderT
  LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
-> (Either [TCErr] (LHSState a)
    -> ReaderT LHSContext (WriterT Blocked_ TCM) a)
-> ReaderT LHSContext (WriterT Blocked_ TCM) a
forall a b.
ReaderT LHSContext (WriterT Blocked_ TCM) a
-> (a -> ReaderT LHSContext (WriterT Blocked_ TCM) b)
-> ReaderT LHSContext (WriterT Blocked_ TCM) 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_ TCM) 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_ TCM) a
forall a. TCErr -> ReaderT LHSContext (WriterT Blocked_ TCM) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
      Left []      -> ReaderT LHSContext (WriterT Blocked_ TCM) 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_ TCM) (Either [TCErr] (LHSState a))
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
trySplit ProblemEq
eq ReaderT
  LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
tryNextSplit = ExceptT TCErr CheckLHSM (LHSState a)
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (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_ TCM) (Either TCErr (LHSState a))
-> (Either TCErr (LHSState a)
    -> ReaderT
         LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a)))
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
forall a b.
ReaderT LHSContext (WriterT Blocked_ TCM) a
-> (a -> ReaderT LHSContext (WriterT Blocked_ TCM) b)
-> ReaderT LHSContext (WriterT Blocked_ TCM) 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_ TCM) (Either [TCErr] (LHSState a))
forall a. a -> ReaderT LHSContext (WriterT Blocked_ TCM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TCErr] (LHSState a)
 -> ReaderT
      LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a)))
-> Either [TCErr] (LHSState a)
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (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_ TCM) (Either [TCErr] (LHSState a))
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ReaderT
  LHSContext (WriterT Blocked_ TCM) (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_ TCM) (Either [TCErr] (LHSState a))
trySplitRest = case Problem a
problem Problem a
-> Getting [NamedArg Pattern] (Problem a) [NamedArg Pattern]
-> [NamedArg Pattern]
forall s a. s -> Getting a s a -> a
^. Getting [NamedArg Pattern] (Problem a) [NamedArg Pattern]
forall a (f :: * -> *).
Functor f =>
([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
problemRestPats of
      []    -> Either [TCErr] (LHSState a)
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
forall a. a -> ReaderT LHSContext (WriterT Blocked_ TCM) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TCErr] (LHSState a)
 -> ReaderT
      LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a)))
-> Either [TCErr] (LHSState a)
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (Either [TCErr] (LHSState a))
forall a b. (a -> b) -> a -> b
$ [TCErr] -> Either [TCErr] (LHSState a)
forall a b. a -> Either a b
Left []
      (NamedArg Pattern
p:[NamedArg Pattern]
_) -> (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_ TCM) (Either TCErr (LHSState a))
-> ReaderT
     LHSContext (WriterT Blocked_ TCM) (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_ TCM) (Either TCErr (LHSState a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (NamedArg Pattern -> ExceptT TCErr CheckLHSM (LHSState a)
splitRest NamedArg Pattern
p)

    splitArg :: ProblemEq -> ExceptT TCErr CheckLHSM (LHSState a)
    -- Split on constructor/literal pattern
    splitArg :: ProblemEq -> ExceptT TCErr CheckLHSM (LHSState a)
splitArg (ProblemEq Pattern
p Term
v (Dom Type -> Type
forall t e. Dom' t e -> e
unDom -> Type
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 -> Tele (Dom Type) -> Type -> Call
CheckPattern Pattern
p Tele (Dom Type)
tel Type
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

      String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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 -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
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) -> 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) -> m a -> m a
addContext Tele (Dom Type)
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 -> TCMT IO (Maybe Int)
forall (m :: * -> *). PureTCM m => Term -> Type -> m (Maybe Int)
isEtaVar Term
v Type
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
$
             SplitError -> TCM Int
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (SplitError -> TCM Int) -> SplitError -> TCM Int
forall a b. (a -> b) -> a -> b
$ Term -> Type -> SplitError
SplitOnNonVariable Term
v Type
a

      let pos = Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel Int -> Int -> Int
forall a. Num a => a -> a -> a
- (Int
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 :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> 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)
-> Dom Type
-> Abs (Tele (Dom Type))
-> Literal
-> ExceptT TCErr CheckLHSM (LHSState a)
splitLit Tele (Dom Type)
delta1 Dom Type
dom Abs (Tele (Dom Type))
adelta2 Literal
l
            p :: Pattern
p@A.RecP{}        -> Tele (Dom Type)
-> Dom Type
-> Abs (Tele (Dom Type))
-> Pattern
-> Maybe AmbiguousQName
-> ExceptT TCErr CheckLHSM (LHSState a)
splitCon Tele (Dom Type)
delta1 Dom Type
dom Abs (Tele (Dom Type))
adelta2 Pattern
p Maybe AmbiguousQName
forall a. Maybe a
Nothing
            p :: Pattern
p@(A.ConP ConPatInfo
_ AmbiguousQName
c [NamedArg Pattern]
ps) -> Tele (Dom Type)
-> Dom Type
-> Abs (Tele (Dom Type))
-> Pattern
-> Maybe AmbiguousQName
-> ExceptT TCErr CheckLHSM (LHSState a)
splitCon Tele (Dom Type)
delta1 Dom Type
dom Abs (Tele (Dom Type))
adelta2 Pattern
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
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)
-> Dom Type
-> Abs (Tele (Dom Type))
-> List1 (Expr, Expr)
-> ExceptT TCErr CheckLHSM (LHSState a)
splitPartial Tele (Dom Type)
delta1 Dom Type
dom Abs (Tele (Dom Type))
adelta2 List1 (Expr, Expr)
ts
            A.AsP PatInfo
_ BindName
_ Pattern
p       -> Pattern -> ExceptT TCErr CheckLHSM (LHSState a)
splitOnPat Pattern
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 :: NamedArg Pattern -> ExceptT TCErr CheckLHSM (LHSState a)
splitRest NamedArg Pattern
p = NamedArg Pattern
-> ExceptT TCErr CheckLHSM (LHSState a)
-> ExceptT TCErr CheckLHSM (LHSState a)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Pattern
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
      String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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
<+> NamedArg Pattern -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA NamedArg Pattern
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
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
target
        ]
      String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text (String -> TCMT IO Doc) -> String -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ String
"projection pattern (raw) = " String -> String -> String
forall a. [a] -> [a] -> [a]
++! NamedArg Pattern -> String
forall a. Show a => a -> String
show NamedArg Pattern
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 (NamedArg Pattern -> Maybe (ProjOrigin, AmbiguousQName)
forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
A.isProjP NamedArg Pattern
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)
-> 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) -> m a -> m a
addContext Tele (Dom Type)
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 <- Type -> ExceptT TCErr CheckLHSM (Maybe Blocker)
forall t (m :: * -> *).
(Reduce t, IsMeta t, MonadReduce m) =>
t -> m (Maybe Blocker)
isBlocked Type
target
        softTypeError $ CannotEliminateWithPattern block p 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
$ NamedArg Pattern -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding NamedArg Pattern
p
        inLHSContext st $ 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' <- unArg projType `piApplyM` self

      -- 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) [NamedArg Pattern] [NamedArg Pattern]
-> ([NamedArg Pattern] -> [NamedArg Pattern])
-> Problem a
-> Problem a
forall s t a b. ASetter s t a b -> (a -> b) -> s -> t
over ASetter
  (Problem a) (Problem a) [NamedArg Pattern] [NamedArg Pattern]
forall a (f :: * -> *).
Functor f =>
([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
problemRestPats (Int -> [NamedArg Pattern] -> [NamedArg Pattern]
forall a. Int -> [a] -> [a]
drop Int
1) Problem a
problem
      liftTCM $ updateLHSState (LHSState tel ip' problem' target' psplit ixsplit sigma)


    -- 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)
-> Dom Type
-> Abs (Tele (Dom Type))
-> List1 (Expr, Expr)
-> ExceptT TCErr CheckLHSM (LHSState a)
splitPartial Tele (Dom Type)
delta1 Dom Type
dom Abs (Tele (Dom Type))
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 -> Bool
forall t e. Dom' t e -> Bool
domIsFinite Dom Type
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) -> 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) -> m a -> m a
addContext Tele (Dom Type)
delta1 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        SplitError -> TCMT IO ()
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (SplitError -> TCMT IO ()) -> SplitError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Dom Type -> SplitError
SplitOnPartial Dom Type
dom

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

      -- 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.
      newContext <- liftTCM (lhsContext st delta1)
      reportSDoc "tc.lhs.split.partial" 10 $ "lhsCxtSize =" <+> prettyTCM lhsCxtSize
      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
                 String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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)
                 String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.lhs.split.partial" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ String -> TCMT IO Doc
forall (m :: * -> *). Applicative m => String -> m Doc
text String
"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 -> TCMT IO Term
checkExpr Expr
lhs Type
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 :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> 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), 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) -> (Tele (Dom Type), Substitution))
-> TCMT IO (Tele (Dom Type)) -> TCM (Tele (Dom Type), Substitution)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO (Tele (Dom Type))
forall (m :: * -> *). MonadTCEnv m => m (Tele (Dom Type))
getContextTelescope)
         case refined of
           [(Tele (Dom Type)
gamma,Substitution
sigma)] -> (Tele (Dom Type), Substitution)
-> TCM (Tele (Dom Type), Substitution)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Tele (Dom Type)
gamma,Substitution
sigma)
           []              -> TypeError -> TCM (Tele (Dom Type), Substitution)
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError TypeError
FaceConstraintUnsatisfiable
           [(Tele (Dom Type), Substitution)]
_               -> TypeError -> TCM (Tele (Dom Type), Substitution)
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> 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)) -> Int
forall a. Sized a => a -> Int
size Abs (Tele (Dom Type))
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))
-> SubstArg (Tele (Dom Type)) -> Tele (Dom Type)
forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs (Tele (Dom Type))
adelta2 Term
SubstArg (Tele (Dom Type))
itisone
          delta2 = Substitution' (SubstArg (Tele (Dom Type)))
-> Tele (Dom Type) -> Tele (Dom Type)
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg (Tele (Dom Type)))
sigma Tele (Dom Type)
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 (ShortText -> Int -> DBPatVar
DBPatVar ShortText
"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) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
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) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
gamma Tele (Dom Type)
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 -> Type -> Type
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Type
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 (applyPatSubst rho sigma))


    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)
-> Dom Type
-> Abs (Tele (Dom Type))
-> Literal
-> ExceptT TCErr CheckLHSM (LHSState a)
splitLit Tele (Dom Type)
delta1 dom :: Dom Type
dom@(Dom Type -> Type
forall t e. Dom' t e -> e
unDom -> Type
a) Abs (Tele (Dom Type))
adelta2 Literal
lit = do
      let info :: ArgInfo
info = Dom Type
dom Dom Type -> Getting ArgInfo (Dom Type) ArgInfo -> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom Type) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo
      let delta2 :: Tele (Dom Type)
delta2 = Abs (Tele (Dom Type))
-> SubstArg (Tele (Dom Type)) -> Tele (Dom Type)
forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs (Tele (Dom Type))
adelta2 (Literal -> Term
Lit Literal
lit)
          delta' :: Tele (Dom Type)
delta' = Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
abstract Tele (Dom Type)
delta1 Tele (Dom Type)
delta2
          rho :: Substitution' DeBruijnPattern
rho    = Int -> DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. DeBruijn a => Int -> a -> Substitution' a
singletonS (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
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' :: Type
target'  = Substitution' DeBruijnPattern -> Type -> Type
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Type
target

      -- 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) -> 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) -> m a -> m a
addContext Tele (Dom Type)
delta1 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> TCMT IO ()
equalType Type
a (Type -> TCMT IO ()) -> TCMT IO Type -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Literal -> TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
Literal -> m Type
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)
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Type
-> [Maybe Int]
-> Bool
-> Substitution
-> LHSState a
forall a.
Tele (Dom Type)
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Type
-> [Maybe Int]
-> Bool
-> Substitution
-> LHSState a
LHSState Tele (Dom Type)
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Type
target' [Maybe Int]
psplit Bool
ixsplit (Substitution' DeBruijnPattern -> Substitution -> Substitution
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Substitution
sigma))


    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)
-> Dom Type
-> Abs (Tele (Dom Type))
-> Pattern
-> Maybe AmbiguousQName
-> ExceptT TCErr CheckLHSM (LHSState a)
splitCon Tele (Dom Type)
delta1 dom :: Dom Type
dom@(Dom Type -> Type
forall t e. Dom' t e -> e
unDom -> Type
a) Abs (Tele (Dom Type))
adelta2 Pattern
focusPat Maybe AmbiguousQName
ambC = do
      let info :: ArgInfo
info = Dom Type
dom Dom Type -> Getting ArgInfo (Dom Type) ArgInfo -> ArgInfo
forall s a. s -> Getting a s a -> a
^. Getting ArgInfo (Dom Type) ArgInfo
forall t e (f :: * -> *).
Functor f =>
(ArgInfo -> f ArgInfo) -> Dom' t e -> f (Dom' t e)
dInfo
      let delta2 :: Tele (Dom Type)
delta2 = Abs (Tele (Dom Type)) -> Tele (Dom Type)
forall a. Subst a => Abs a -> a
absBody Abs (Tele (Dom Type))
adelta2

      String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
tel
        ]

      String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
delta1
          , TCMT IO Doc
"a      = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta1 (Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
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) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta1
                              ((ShortText, Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
(ShortText, Dom Type) -> m a -> m a
addContext (ShortText
"x" :: ShortText, Dom Type
dom) (Tele (Dom Type) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
delta2))
          ]
        ]

      -- We should be at a data/record type
      (dr, d, s, pars, ixs) <- Tele (Dom Type)
-> ExceptT
     TCErr CheckLHSM (DataOrRecord, QName, Sort' Term, Args, Args)
-> ExceptT
     TCErr CheckLHSM (DataOrRecord, QName, Sort' Term, Args, Args)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta1 (ExceptT
   TCErr CheckLHSM (DataOrRecord, QName, Sort' Term, Args, Args)
 -> ExceptT
      TCErr CheckLHSM (DataOrRecord, QName, Sort' Term, Args, Args))
-> ExceptT
     TCErr CheckLHSM (DataOrRecord, QName, Sort' Term, Args, Args)
-> ExceptT
     TCErr CheckLHSM (DataOrRecord, QName, Sort' Term, Args, Args)
forall a b. (a -> b) -> a -> b
$ Type
-> ExceptT
     TCErr CheckLHSM (DataOrRecord, QName, Sort' Term, Args, Args)
forall (m :: * -> *).
(MonadTCM m, PureTCM m) =>
Type
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
isDataOrRecordType Type
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 Type (Sort' Term) (Sort' Term)
-> Sort' Term -> Type -> Type
forall s t a b. ASetter s t a b -> b -> s -> t
set ASetter Type Type (Sort' Term) (Sort' Term)
forall a. LensSort a => Lens' a (Sort' Term)
Lens' Type (Sort' Term)
lensSort Sort' Term
s Type
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 $ inLHSContext st case ambC of
        Just AmbiguousQName
ambC ->
          -- note context fiddling: disambiguateConstructor needs to
          -- return a type that lives in Δ₁, but we only have
          -- checkpoints for Δ₁Δ₂, so it takes the offset by which the
          -- parameters should be raised before they can be compared
          -- with the instantiated constructor type.
          Int -> AmbiguousQName -> QName -> Args -> TCM (ConHead, Type)
disambiguateConstructor (Int
1 Int -> Int -> Int
forall a. Num a => a -> a -> a
+ Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
delta2) AmbiguousQName
ambC QName
d Args
pars
        Maybe AmbiguousQName
Nothing   ->
          -- getRecordConstructor is insensitive to checkpoints.
          QName -> Args -> Type -> TCM (ConHead, Type)
getRecordConstructor QName
d Args
pars Type
a

      -- Don't split on lazy (non-eta) constructor
      case focusPat of
        A.ConP ConPatInfo
cpi AmbiguousQName
_ [NamedArg Pattern]
_ | 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 :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (TypeError -> ExceptT TCErr CheckLHSM ())
-> TypeError -> ExceptT TCErr CheckLHSM ()
forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
ForcedConstructorNotInstantiated Pattern
focusPat
        Pattern
_ -> () -> 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 -> Args -> Args
forall a. Int -> [a] -> [a]
drop (Args -> Int
forall a. Sized a => a -> Int
size Args
pars) (Args -> Args) -> Args -> Args
forall a b. (a -> b) -> a -> b
$ Elims -> Args
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
_ [NamedArg Pattern]
ps -> do
          ps <- ExpandHidden
-> [NamedArg Pattern]
-> Tele (Dom Type)
-> TCMT IO [NamedArg Pattern]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
 MonadTrace m) =>
ExpandHidden
-> [NamedArg Pattern] -> Tele (Dom Type) -> m [NamedArg Pattern]
insertImplicitPatterns ExpandHidden
ExpandLast [NamedArg Pattern]
ps Tele (Dom Type)
gamma
          return $ useNamesFromPattern ps gamma
        A.RecP KwRange
_ ConPatInfo
_ [FieldAssignment' Pattern]
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
_ -> TCMT IO (Tele (Dom Type))
forall a. HasCallStack => a
__IMPOSSIBLE__

      -- 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)
delta1 Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
`abstract` Tele (Dom Type)
gamma
          da'  = Int -> Type -> Type
forall a. Subst a => Int -> a -> a
raise (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
gamma) Type
da
          ixs' = Int -> Args -> Args
forall a. Subst a => Int -> a -> a
raise (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
gamma) Args
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) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
delta1) IsForced
NotForced [IsForced] -> [IsForced] -> [IsForced]
forall a. [a] -> [a] -> [a]
++! [IsForced]
cforced

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

      -- Unify constructor target and given type (in Δ₁Γ)
      -- Given: Δ₁  ⊢ D pars : Φ → Typeᵢ
      --        Δ₁  ⊢ 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)Δ₂

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

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

        -- Mismatch.  Report and abort.
        NoUnify NegativeUnification
neg -> TypeError -> ExceptT TCErr CheckLHSM (LHSState a)
forall (m :: * -> *) e a.
(HasCallStack, MonadTCM m, Diagnostic e) =>
e -> 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 RetryNormalised
_ (Tele (Dom Type)
delta1',Substitution' DeBruijnPattern
rho0,[NamedArg DeBruijnPattern]
es) -> do

          String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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"
          String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
delta1'
            , TCMT IO Doc
"rho0    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (Dom Type) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
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) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta1' ([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) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
gamma) Substitution' DeBruijnPattern
rho0

          String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta1' (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ 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
a' = Substitution' DeBruijnPattern -> Type -> Type
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho1 Type
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)
conPType   = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (Arg Type -> Maybe (Arg Type)) -> Arg Type -> Maybe (Arg Type)
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Type -> Arg Type
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info Type
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) -> Boundary -> [NamedArg DeBruijnPattern]
forall a.
DeBruijn a =>
Tele (Dom Type) -> Boundary -> [NamedArg (Pattern' a)]
telePatterns Tele (Dom Type)
gamma Boundary
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)
delta2' = Substitution' DeBruijnPattern -> Tele (Dom Type) -> Tele (Dom Type)
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho3 Tele (Dom Type)
delta2
              delta' :: Tele (Dom Type)
delta'  = Tele (Dom Type)
delta1' Tele (Dom Type) -> Tele (Dom Type) -> Tele (Dom Type)
forall t. Abstract t => Tele (Dom Type) -> t -> t
`abstract` Tele (Dom Type)
delta2'
              rho :: Substitution' DeBruijnPattern
rho     = Int
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. Int -> Substitution' a -> Substitution' a
liftS (Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
delta2) Substitution' DeBruijnPattern
rho3

          String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta1' (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ 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) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
delta2'
            ]
          String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
delta1' (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ 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) -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Tele (Dom Type)
delta2'
            ]

          String -> Int -> TCMT IO Doc -> ExceptT TCErr CheckLHSM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (Dom Type) -> m Doc
prettyTCM Tele (Dom Type)
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) -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Tele (Dom Type) -> m a -> m a
addContext Tele (Dom Type)
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' :: Type
target'  = Substitution' DeBruijnPattern -> Type -> Type
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Type
target
              sigma' :: Substitution
sigma'   = Substitution' DeBruijnPattern -> Substitution -> Substitution
forall a. TermSubst a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho Substitution
sigma

          -- 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

          -- if rest type reduces,
          -- extend the split problem by previously not considered patterns
          st' <- 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 (LHSState a -> TCM (LHSState a)) -> LHSState a -> TCM (LHSState a)
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type)
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Type
-> [Maybe Int]
-> Bool
-> Substitution
-> LHSState a
forall a.
Tele (Dom Type)
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Type
-> [Maybe Int]
-> Bool
-> Substitution
-> LHSState a
LHSState Tele (Dom Type)
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Type
target' [Maybe Int]
psplit (Bool
ixsplit Bool -> Bool -> Bool
|| Bool -> Bool
not (Args -> Bool
forall a. Null a => a -> Bool
null Args
ixs)) Substitution
sigma'

          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, MonadTCM 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, MonadTCM 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 -> SplitError -> m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError SplitError
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 -> SplitError -> m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (SplitError -> m ()) -> SplitError -> m ()
forall a b. (a -> b) -> a -> b
$ QName -> SplitError
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 :: * -> *) e a.
(HasCallStack, MonadTCM m, Diagnostic e) =>
e -> m a
hardTypeError TypeError
ShouldBeRecordPattern
    ClauseLHS{} -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
isDataOrRecordType Type
a0 = Type
-> (Blocker
    -> Type
    -> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args))
-> (NotBlocked
    -> Type
    -> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args))
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked Type
a0 Blocker
-> Type
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
blocked ((NotBlocked
  -> Type
  -> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args))
 -> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args))
-> (NotBlocked
    -> Type
    -> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args))
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall a b. (a -> b) -> a -> b
$ \case
  NotBlocked
ReallyNotBlocked -> \ Type
a -> case Type -> Term
forall t a. Type'' t a -> a
unEl Type
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, Args, Args))
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
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 -> ExceptT TCErr m Bool
forall (m :: * -> *). MonadTCM m => Type -> m Bool
isInterval Type
a) (ExceptT TCErr m () -> ExceptT TCErr m ())
-> ExceptT TCErr m () -> ExceptT TCErr m ()
forall a b. (a -> b) -> a -> b
$ SplitError -> ExceptT TCErr m ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCM m, Diagnostic e) =>
e -> m a
hardTypeError (SplitError -> ExceptT TCErr m ())
-> ExceptT TCErr m SplitError -> ExceptT TCErr m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m SplitError
notData

        let (Args
pars, Args
ixs) = Int -> Args -> (Args, Args)
forall a. Int -> [a] -> ([a], [a])
splitAt' Int
np (Args -> (Args, Args)) -> Args -> (Args, Args)
forall a b. (a -> b) -> a -> b
$ Elims -> Args
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims Elims
es
        (DataOrRecord, QName, Sort' Term, Args, Args)
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
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, Args
pars, Args
ixs)

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

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

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

      -- Can't match before we have the definition
      DataOrRecSig{} -> SplitError
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall (m :: * -> *) e a.
(HasCallStack, MonadTCM m, Diagnostic e) =>
e -> m a
hardTypeError (SplitError
 -> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args))
-> SplitError
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall a b. (a -> b) -> a -> b
$ QName -> SplitError
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{}    -> SplitError
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall (m :: * -> *) e a.
(HasCallStack, MonadTCM m, Diagnostic e) =>
e -> m a
hardTypeError (SplitError
 -> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args))
-> ExceptT TCErr m SplitError
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m SplitError
notData

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

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

      PrimitiveSort{} -> SplitError
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall (m :: * -> *) e a.
(HasCallStack, MonadTCM m, Diagnostic e) =>
e -> m a
hardTypeError (SplitError
 -> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args))
-> ExceptT TCErr m SplitError
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m SplitError
notData

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

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

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

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

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

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

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

  where
  notData :: ExceptT TCErr m SplitError
notData      = TCM SplitError -> ExceptT TCErr m SplitError
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM SplitError -> ExceptT TCErr m SplitError)
-> TCM SplitError -> ExceptT TCErr m SplitError
forall a b. (a -> b) -> a -> b
$ Closure Type -> SplitError
NotADatatype (Closure Type -> SplitError)
-> TCMT IO (Closure Type) -> TCM SplitError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> TCMT IO (Closure Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Type
a0
  blocked :: Blocker
-> Type
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
blocked Blocker
b Type
_a = SplitError
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (SplitError
 -> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args))
-> ExceptT TCErr m SplitError
-> ExceptT TCErr m (DataOrRecord, QName, Sort' Term, Args, Args)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do TCM SplitError -> ExceptT TCErr m SplitError
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM SplitError -> ExceptT TCErr m SplitError)
-> TCM SplitError -> ExceptT TCErr m SplitError
forall a b. (a -> b) -> a -> b
$ Blocker -> Closure Type -> SplitError
BlockedType Blocker
b (Closure Type -> SplitError)
-> TCMT IO (Closure Type) -> TCM SplitError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Type -> TCMT IO (Closure Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Type
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 -> Args -> Type -> TCM (ConHead, Type)
getRecordConstructor QName
d Args
pars Type
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 :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCMT IO ConHead) -> TypeError -> TCMT IO ConHead
forall a b. (a -> b) -> a -> b
$ Type -> TypeError
ShouldBeRecordType Type
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.
  -> 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
-> Type
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
disambiguateProjection Maybe Hiding
h AmbiguousQName
ambD Type
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) (QName, Args, RecordData))
-> (Blocked Type -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> ((QName, Args, RecordData)
    -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, 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) (QName, Args, RecordData))
-> TCMT IO (Either (Blocked Type) (QName, Args, RecordData))
forall a. TCM a -> TCM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (Either (Blocked Type) (QName, Args, RecordData))
 -> TCMT IO (Either (Blocked Type) (QName, Args, RecordData)))
-> TCMT IO (Either (Blocked Type) (QName, Args, RecordData))
-> TCMT IO (Either (Blocked Type) (QName, Args, RecordData))
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO (Either (Blocked Type) (QName, Args, RecordData))
forall (m :: * -> *).
(HasCallStack, PureTCM m) =>
Type -> m (Either (Blocked Type) (QName, Args, RecordData))
tryRecordType Type
b) Blocked Type -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
notRecord
    \ (QName
r, Args
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
      String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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
<> Args -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Args -> m Doc
prettyTCM Args
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
-> Args
-> Bool
-> (([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
tryDisambiguate Bool
False [Dom' Term QName]
fs QName
r Args
vs Bool
comatching ((([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
  -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
 -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> (([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a b. (a -> b) -> a -> b
$ \ ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
_ ->
          -- If this fails, we try again with constraints, but we require
          -- the solution to be unique.
          Bool
-> [Dom' Term QName]
-> QName
-> Args
-> Bool
-> (([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
tryDisambiguate Bool
True [Dom' Term QName]
fs QName
r Args
vs Bool
comatching ((([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
  -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
 -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> (([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a b. (a -> b) -> a -> b
$ \case
            (TCErr
err:[TCErr]
_, [] ) -> TCErr -> TCM (QName, Bool, QName, Arg Type, 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, ArgInfo)
forall a. HasCallStack => a
__IMPOSSIBLE__
            ([TCErr]
_    , [(QName, (Arg Type, ArgInfo, Maybe TCState))
_]) -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a. HasCallStack => a
__IMPOSSIBLE__
            ([TCErr]
_    , (QName
d,(Arg Type, ArgInfo, Maybe TCState)
_) : (QName
d1,(Arg Type, ArgInfo, Maybe TCState)
_) : [(QName, (Arg Type, ArgInfo, Maybe TCState))]
disambs) ->
              TypeError -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TypeError -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a b. (a -> b) -> a -> b
$ QName -> List1 QName -> TypeError
AmbiguousProjection QName
d (List1 QName -> TypeError) -> List1 QName -> TypeError
forall a b. (a -> b) -> a -> b
$ QName
d1 QName -> [QName] -> List1 QName
forall a. a -> [a] -> NonEmpty a
:| ((QName, (Arg Type, ArgInfo, Maybe TCState)) -> QName)
-> [(QName, (Arg Type, ArgInfo, Maybe TCState))] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map' (QName, (Arg Type, ArgInfo, Maybe TCState)) -> QName
forall a b. (a, b) -> a
fst [(QName, (Arg Type, ArgInfo, Maybe TCState))]
disambs
  where
    ds :: List1 QName
ds = AmbiguousQName -> List1 QName
getAmbiguous AmbiguousQName
ambD
    tryDisambiguate :: Bool
-> [Dom' Term QName]
-> QName
-> Args
-> Bool
-> (([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
    -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
tryDisambiguate Bool
constraintsOk [Dom' Term QName]
fs QName
r Args
vs Bool
comatching ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
-> TCM (QName, Bool, QName, Arg Type, 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, ArgInfo, Maybe TCState))))
-> List1 QName
-> TCM
     (List1 (Either TCErr (QName, (Arg Type, 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 TCM (QName, (Arg Type, ArgInfo, Maybe TCState))
-> TCM (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TCErr TCM (QName, (Arg Type, ArgInfo, Maybe TCState))
 -> TCM (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState))))
-> (QName
    -> ExceptT TCErr TCM (QName, (Arg Type, ArgInfo, Maybe TCState)))
-> QName
-> TCM (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [Dom' Term QName]
-> QName
-> Args
-> QName
-> ExceptT TCErr TCM (QName, (Arg Type, ArgInfo, Maybe TCState))
tryProj Bool
constraintsOk [Dom' Term QName]
fs QName
r Args
vs) List1 QName
ds
      case List1.partitionEithers disambiguations of
        ([TCErr]
_ , (QName
d, (Arg Type
a, ArgInfo
ai, Maybe TCState
mst)) : [(QName, (Arg Type, ArgInfo, Maybe TCState))]
disambs) | Bool
constraintsOk Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
<= [(QName, (Arg Type, ArgInfo, Maybe TCState))] -> Bool
forall a. Null a => a -> Bool
null [(QName, (Arg Type, 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, ArgInfo)
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
d, Bool
comatching, QName
r, Arg Type
a, ArgInfo
ai)
        ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
other -> ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
failure ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
other

    notRecord :: Blocked Type -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
notRecord Blocked Type
blk = SplitError -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (SplitError -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM SplitError -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCM SplitError -> TCM SplitError
forall a. TCM a -> TCM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM do
      -- If the type is a NotBlocked function type which returns a
      -- record type, suggest that the user may have forgotten some
      -- arguments to the left of this split.
      hint <- MaybeT TCM Doc -> TCMT IO (Maybe Doc)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
        NotBlocked _ ty <- Blocked Type -> MaybeT TCM (Blocked Type)
forall a. a -> MaybeT TCM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Blocked Type
blk
        TelV tel ret <- telView ty
        addContext tel $ isRecordType ret >>= \case
          Just{} | Tele (Dom Type) -> Int
forall a. Sized a => a -> Int
size Tele (Dom Type)
tel Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
>= Int
1 -> Doc -> MaybeT TCM Doc
forall a. a -> MaybeT TCM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (Doc -> MaybeT TCM Doc) -> Doc -> MaybeT TCM Doc
forall a b. (a -> b) -> a -> b
$ Doc
"(Did you forget to apply some arguments?)"
          Maybe (QName, Args, RecordData)
_                      -> MaybeT TCM Doc
forall a. MaybeT TCM a
forall (m :: * -> *) a. MonadPlus m => m a
mzero

      nm <- wrongName $ List1.head ds
      pure $ CannotEliminateWithProjection
        { cantSplitBlocker  = Just (getBlocker blk)
        , cantSplitProjWhy  = BecauseNotRecord hint
        , cantSplitProjName = nm
        , cantSplitType     = b
        }

    wrongName :: QName -> TCM WrongProjectionName
    wrongName :: QName -> TCM WrongProjectionName
wrongName QName
d
      | AmbiguousQName -> Bool
isAmbiguous AmbiguousQName
ambD = QName -> WrongProjectionName
AmbWrongProj (QName -> WrongProjectionName)
-> TCMT IO QName -> TCM WrongProjectionName
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
      | Bool
otherwise        = WrongProjectionName -> TCM WrongProjectionName
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WrongProjectionName -> TCM WrongProjectionName)
-> WrongProjectionName -> TCM WrongProjectionName
forall a b. (a -> b) -> a -> b
$ QName -> WrongProjectionName
UnambWrongProj QName
d

    wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => Maybe Blocker -> WhyWrongProj -> QName -> m a
    wrongProj :: forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
Maybe Blocker -> WhyWrongProj -> QName -> m a
wrongProj Maybe Blocker
blk WhyWrongProj
why QName
d = SplitError -> m a
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (SplitError -> m a) -> m SplitError -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCM SplitError -> m SplitError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM do
      Maybe Blocker
-> Type -> WhyWrongProj -> WrongProjectionName -> SplitError
CannotEliminateWithProjection Maybe Blocker
blk Type
b WhyWrongProj
why (WrongProjectionName -> SplitError)
-> TCM WrongProjectionName -> TCM SplitError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCM WrongProjectionName
wrongName QName
d

    -- Throw a CannotEliminateWithProjection with the right WhyWrongProj
    -- depending on whether the definition was copied from a projection
    -- or not.
    -- This is necessary because applying a Projection Function with a
    -- list of arguments that's not (Var 0 []) at the projIndex results
    -- in 'Left MaybeProjectionLike', rather than a 'Right Projection{}'
    -- with no projLams.
    notProj :: Definition -> ExceptT TCErr TCM a
    notProj :: forall a. Definition -> ExceptT TCErr TCM a
notProj Definition
def0 = do
      let
        loop :: Definition -> ExceptT TCErr TCM WhyWrongProj
loop Defn{defCopy :: Definition -> Maybe QName
defCopy = Just QName
p} = do
          def <- Definition -> ExceptT TCErr TCM Definition
forall (m :: * -> *).
(HasConstInfo m, ReadTCState m) =>
Definition -> m Definition
instantiateDef (Definition -> ExceptT TCErr TCM Definition)
-> ExceptT TCErr TCM Definition -> ExceptT TCErr TCM Definition
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> ExceptT TCErr TCM Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
p
          case isProjectionDefinition def of
            Just{}  -> WhyWrongProj -> ExceptT TCErr TCM WhyWrongProj
forall a. a -> ExceptT TCErr TCM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure (WhyWrongProj -> ExceptT TCErr TCM WhyWrongProj)
-> WhyWrongProj -> ExceptT TCErr TCM WhyWrongProj
forall a b. (a -> b) -> a -> b
$ Type -> WhyWrongProj
BecauseAlreadyApplied (Definition -> Type
defType Definition
def0)
            Maybe Projection
Nothing -> Definition -> ExceptT TCErr TCM WhyWrongProj
loop Definition
def
        loop Definition
_ = WhyWrongProj -> ExceptT TCErr TCM WhyWrongProj
forall a. a -> ExceptT TCErr TCM a
forall (f :: * -> *) a. Applicative f => a -> f a
pure WhyWrongProj
BecauseNotProj
      r <- Definition -> ExceptT TCErr TCM WhyWrongProj
loop Definition
def0
      softTypeError =<< CannotEliminateWithProjection Nothing b r <$> liftTCM (wrongName (defName def0))

    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
-> Args
-> QName
-> ExceptT TCErr TCM (QName, (Arg Type, ArgInfo, Maybe TCState))
tryProj Bool
constraintsOk [Dom' Term QName]
fs QName
r Args
vs QName
d0 = {-# SCC "tryProj" #-} do
      def <- Definition -> ExceptT TCErr TCM Definition
forall (m :: * -> *).
(HasConstInfo m, ReadTCState m) =>
Definition -> m Definition
instantiateDef (Definition -> ExceptT TCErr TCM Definition)
-> ExceptT TCErr TCM Definition -> ExceptT TCErr TCM Definition
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> ExceptT TCErr TCM Definition
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m Definition
getConstInfo QName
d0
      proj <- maybe (notProj def) pure $ isProjectionDefinition def
      let d = Projection -> QName
projOrig Projection
proj

      -- Andreas, 2015-05-06 issue 1413 projProper=Nothing is not impossible
      qr <- maybe (wrongProj Nothing BecauseNotProj d) return $ projProper 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 (BecauseAlreadyApplied (defType def)) 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
        [ "proj                  d0 = " <> pretty d0
        , "original proj         d  = " <> pretty d
        , if d0 == d then "--> will skip checkParameters" else "--> must check parameters"
        ]
      -- 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 (BecauseNotField fs) 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

      -- 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.
      whenJust h \Hiding
h -> Bool -> ExceptT TCErr TCM () -> ExceptT TCErr TCM ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (Hiding -> ArgInfo -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding Hiding
h (ArgInfo -> Bool) -> ArgInfo -> Bool
forall a b. (a -> b) -> a -> b
$ Projection -> ArgInfo
projArgInfo Projection
proj) (ExceptT TCErr TCM () -> ExceptT TCErr TCM ())
-> ExceptT TCErr TCM () -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$
        TypeError -> ExceptT TCErr TCM ()
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (TypeError -> ExceptT TCErr TCM ())
-> TypeError -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$ Hiding -> Hiding -> QName -> TypeError
WrongHidingInProjection Hiding
h (ArgInfo -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding (ArgInfo -> Hiding) -> ArgInfo -> Hiding
forall a b. (a -> b) -> a -> b
$ Projection -> ArgInfo
projArgInfo Projection
proj) QName
d

      -- Andreas, 2016-12-31, issue #1976: Check parameters.
      let chk = Maybe Projection -> Definition -> QName -> Args -> TCMT IO ()
forall (tcm :: * -> *).
MonadTCM tcm =>
Maybe Projection -> Definition -> QName -> Args -> tcm ()
checkParameters (Projection -> Maybe Projection
forall a. a -> Maybe a
Just Projection
proj) Definition
def QName
r Args
vs
      mst <- suspendErrors $ if
        | d == d0       -> pure Nothing
        | constraintsOk -> Just . snd <$> localTCStateSaving chk
        | otherwise     -> 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.
disambiguateConstructor
  :: Nat
  -- ^ How many extra variables do we need to insert to get from the
  -- current context to one for which we have a precise checkpoint?
  -> AmbiguousQName    -- ^ The name of the constructor to be disambiguated.
  -> QName             -- ^ Name of the datatype.
  -> Args              -- ^ Parameters of the datatype
  -> TCM (ConHead, Type)
disambiguateConstructor :: Int -> AmbiguousQName -> QName -> Args -> TCM (ConHead, Type)
disambiguateConstructor Int
delta2 AmbiguousQName
ambC QName
d Args
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, Maybe TCState))])
_ ->
    Bool
-> QName
-> [QName]
-> (([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
    -> TCM (ConHead, Type))
-> TCM (ConHead, Type)
tryDisambiguate Bool
True QName
d [QName]
cons ((([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
  -> TCM (ConHead, Type))
 -> TCM (ConHead, Type))
-> (([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
    -> TCM (ConHead, Type))
-> TCM (ConHead, Type)
forall a b. (a -> b) -> a -> b
$ \case
        ([]   , [] ) -> TCM (ConHead, Type)
forall a. HasCallStack => a
__IMPOSSIBLE__
        (TCErr
err:[TCErr]
_, [] ) -> TCErr -> TCM (ConHead, Type)
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, Maybe TCState))
_]) -> TypeError -> TCM (ConHead, Type)
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM (ConHead, Type))
-> TypeError -> TCM (ConHead, Type)
forall a b. (a -> b) -> a -> b
$ QName -> List1 QName -> TypeError
CantResolveOverloadedConstructorsTargetingSameDatatype QName
d List1 QName
cs
        ([TCErr]
_    , (d0 :: List1 (QName, ConHead, (Type, Maybe TCState))
d0@((QName
c,ConHead
_,(Type, Maybe TCState)
_) :| [(QName, ConHead, (Type, Maybe TCState))]
_) : List1 (QName, ConHead, (Type, Maybe TCState))
d1 : [List1 (QName, ConHead, (Type, Maybe TCState))]
ds)) -> TypeError -> TCM (ConHead, Type)
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (TypeError -> TCM (ConHead, Type))
-> TypeError -> TCM (ConHead, Type)
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, Maybe TCState)) -> QName)
-> List2 (QName, ConHead, (Type, 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, Maybe TCState)) -> ConHead)
-> (QName, ConHead, (Type, Maybe TCState))
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ConHead (QName, ConHead, (Type, Maybe TCState)) ConHead
-> (QName, ConHead, (Type, Maybe TCState)) -> ConHead
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ConHead (QName, ConHead, (Type, Maybe TCState)) ConHead
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (QName, ConHead, (Type, Maybe TCState))
  (QName, ConHead, (Type, Maybe TCState))
  ConHead
  ConHead
_2) (List2 (QName, ConHead, (Type, Maybe TCState)) -> List2 QName)
-> List2 (QName, ConHead, (Type, Maybe TCState)) -> List2 QName
forall a b. (a -> b) -> a -> b
$ List2 (List1 (QName, ConHead, (Type, Maybe TCState)))
-> List2 (QName, ConHead, (Type, Maybe TCState))
forall a. List2 (List1 a) -> List2 a
List2.concat21 (List2 (List1 (QName, ConHead, (Type, Maybe TCState)))
 -> List2 (QName, ConHead, (Type, Maybe TCState)))
-> List2 (List1 (QName, ConHead, (Type, Maybe TCState)))
-> List2 (QName, ConHead, (Type, Maybe TCState))
forall a b. (a -> b) -> a -> b
$ List1 (QName, ConHead, (Type, Maybe TCState))
-> List1 (QName, ConHead, (Type, Maybe TCState))
-> [List1 (QName, ConHead, (Type, Maybe TCState))]
-> List2 (List1 (QName, ConHead, (Type, Maybe TCState)))
forall a. a -> a -> [a] -> List2 a
List2 List1 (QName, ConHead, (Type, Maybe TCState))
d0 List1 (QName, ConHead, (Type, Maybe TCState))
d1 [List1 (QName, ConHead, (Type, Maybe TCState))]
ds

  where
    cs :: List1 QName
cs = AmbiguousQName -> List1 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, Maybe TCState))])
    -> TCM (ConHead, Type))
-> TCM (ConHead, Type)
tryDisambiguate Bool
constraintsOk QName
d [QName]
cons ([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
-> TCM (ConHead, Type)
failure = do
      String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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
$ List1 QName -> [Item (List1 QName)]
forall l. IsList l => l -> [Item l]
List1.toList List1 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, Maybe TCState))))
-> List1 QName
-> TCMT
     IO
     (NonEmpty (Either TCErr (QName, ConHead, (Type, 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 TCM (QName, ConHead, (Type, Maybe TCState))
-> TCMT IO (Either TCErr (QName, ConHead, (Type, Maybe TCState)))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState))
 -> TCMT IO (Either TCErr (QName, ConHead, (Type, Maybe TCState))))
-> (QName
    -> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState)))
-> QName
-> TCMT IO (Either TCErr (QName, ConHead, (Type, Maybe TCState)))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [QName]
-> QName
-> Args
-> QName
-> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState))
tryCon Bool
constraintsOk [QName]
cons QName
d Args
pars) List1 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, (String
"(state change)" :: String) String -> f b -> f String
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
a,Maybe TCState
mst)) :| [] ] -> do
          String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
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) -> TCM (ConHead, Type)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConHead
c,Type
a)

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

    abstractConstructor :: QName -> m a
abstractConstructor QName
c = TypeError -> m a
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> 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 :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> 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
-> Args
-> QName
-> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState))
tryCon Bool
constraintsOk [QName]
cons QName
d Args
pars QName
c = QName -> ExceptT TCErr TCM (Either SigError Definition)
forall (m :: * -> *).
(HasConstInfo m, HasCallStack) =>
QName -> m (Either SigError Definition)
getConstInfo' QName
c ExceptT TCErr TCM (Either SigError Definition)
-> (Either SigError Definition
    -> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState)))
-> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState))
forall a b.
ExceptT TCErr TCM a
-> (a -> ExceptT TCErr TCM b) -> ExceptT TCErr TCM b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left (SigUnknown String
err)     -> String -> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState))
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
String -> m a
__IMPOSSIBLE_VERBOSE__ String
err
      Left SigError
SigAbstract          -> QName -> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState))
forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
QName -> m a
abstractConstructor QName
c
      Right Definition
def                 -> {-# SCC "tryCon" #-} 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 TCM () -> ExceptT TCErr TCM ()
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 TCM () -> ExceptT TCErr TCM ())
-> ExceptT TCErr TCM () -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> ExceptT TCErr TCM ()
forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
QName -> QName -> m a
wrongDatatype QName
c QName
d

        String -> Int -> TCMT IO Doc -> ExceptT TCErr TCM ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.lhs.split" Int
40 (TCMT IO Doc -> ExceptT TCErr TCM ())
-> TCMT IO Doc -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"type of constructor:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Definition -> Type
defType Definition
def)

        -- 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.
        def <- Definition -> ExceptT TCErr TCM Definition
forall (m :: * -> *).
(HasConstInfo m, ReadTCState m) =>
Definition -> m Definition
instantiateDef Definition
def
        let chk = Maybe Projection -> Definition -> QName -> Args -> TCMT IO ()
forall (tcm :: * -> *).
MonadTCM tcm =>
Maybe Projection -> Definition -> QName -> Args -> tcm ()
checkParameters Maybe Projection
forall a. Maybe a
Nothing Definition
def QName
d (Int -> Args -> Args
forall a. Subst a => Int -> a -> a
raise Int
delta2 Args
pars)
        mst <- suspendErrors if
          | conName con == defName def -> pure Nothing
          | constraintsOk              -> Just . snd <$> localTCStateSaving chk
          | otherwise                  -> Nothing <$ nonConstraining 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, Maybe TCState))]
-> TCM [List1 (a, ConHead, (Type, Maybe TCState))]
dedupCons [(a, ConHead, (Type, Maybe TCState))]
cands = do
      -- Group candidates by original constructor name.
      let groups :: [NonEmpty (a, ConHead, (Type, Maybe TCState))]
groups = ((a, ConHead, (Type, Maybe TCState)) -> QName)
-> [(a, ConHead, (Type, Maybe TCState))]
-> [NonEmpty (a, ConHead, (Type, 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, Maybe TCState)) -> ConHead)
-> (a, ConHead, (Type, Maybe TCState))
-> QName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Getting ConHead (a, ConHead, (Type, Maybe TCState)) ConHead
-> (a, ConHead, (Type, Maybe TCState)) -> ConHead
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting ConHead (a, ConHead, (Type, Maybe TCState)) ConHead
forall s t a b. Field2 s t a b => Lens s t a b
Lens
  (a, ConHead, (Type, Maybe TCState))
  (a, ConHead, (Type, Maybe TCState))
  ConHead
  ConHead
_2) [(a, ConHead, (Type, Maybe TCState))]
cands
      -- Eliminate duplicates (same type) from groups.
      (NonEmpty (a, ConHead, (Type, Maybe TCState))
 -> TCMT IO (NonEmpty (a, ConHead, (Type, Maybe TCState))))
-> [NonEmpty (a, ConHead, (Type, Maybe TCState))]
-> TCMT IO [NonEmpty (a, ConHead, (Type, 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, Maybe TCState))
 -> (a, ConHead, (Type, Maybe TCState)) -> TCMT IO Bool)
-> NonEmpty (a, ConHead, (Type, Maybe TCState))
-> TCMT IO (NonEmpty (a, ConHead, (Type, Maybe TCState)))
forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Bool) -> List1 a -> m (List1 a)
List1.nubM ((Type, Maybe TCState) -> (Type, Maybe TCState) -> TCMT IO Bool
cmpM ((Type, Maybe TCState) -> (Type, Maybe TCState) -> TCMT IO Bool)
-> ((a, ConHead, (Type, Maybe TCState)) -> (Type, Maybe TCState))
-> (a, ConHead, (Type, Maybe TCState))
-> (a, ConHead, (Type, Maybe TCState))
-> TCMT IO Bool
forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` Getting
  (Type, Maybe TCState)
  (a, ConHead, (Type, Maybe TCState))
  (Type, Maybe TCState)
-> (a, ConHead, (Type, Maybe TCState)) -> (Type, Maybe TCState)
forall s (m :: * -> *) a. MonadReader s m => Getting a s a -> m a
view Getting
  (Type, Maybe TCState)
  (a, ConHead, (Type, Maybe TCState))
  (Type, Maybe TCState)
forall s t a b. Field3 s t a b => Lens s t a b
Lens
  (a, ConHead, (Type, Maybe TCState))
  (a, ConHead, (Type, Maybe TCState))
  (Type, Maybe TCState)
  (Type, Maybe TCState)
_3)) [NonEmpty (a, ConHead, (Type, Maybe TCState))]
groups
      where
      -- The types come possibly with their own state.
      cmpM :: (Type, Maybe TCState) -> (Type, Maybe TCState) -> TCMT IO Bool
cmpM (Type
a1, Maybe TCState
mst1) (Type
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 -> Type -> TCMT IO ()
equalType Type
a1 Type
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

-- | @checkParameters proj c d pars@ checks that the given
-- constructor-or-projection 'Definition' can be used to (co)pattern
-- match against an application of @d@ to @pars@.
--
-- The definition @c@ must be the *copied* definition of the
-- constructor, as the user wrote it. This function must be called with
-- accurate checkpoints, see 'inLHSContext'.
checkParameters
  :: MonadTCM tcm
  => Maybe Projection -- ^ Are we checking for a projection?
  -> Definition       -- ^ The definition of the constructor as the user wrote it.
  -> QName            -- ^ The name of the original data type this constructor should target.
  -> Args             -- ^ The parameters from the type signature.
  -> tcm ()
checkParameters :: forall (tcm :: * -> *).
MonadTCM tcm =>
Maybe Projection -> Definition -> QName -> Args -> tcm ()
checkParameters Maybe Projection
proj Definition
cdef QName
d Args
pars' = {-# SCC checkParameters #-} TCMT IO () -> tcm ()
forall a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM do
  String -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"tc.lhs.split.params" 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
"checkParameters for" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Definition -> QName
defName Definition
cdef)
    , 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
"defType  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Definition -> Type
defType Definition
cdef)
    , 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
"wanted   =" 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 (QName -> Elims -> Term
Def QName
d (Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Arg Term -> Elim) -> Args -> Elims
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Args
pars'))
    ]

  let
    -- Like implicitNamedArgs, but creates plain unification metas.  In
    -- the general, happy case (non-constraining), these metas will
    -- either be solved by unifying against the given data/record type,
    -- or they will be left dangling and get closed by
    -- 'nonConstraining'. Regardless, we must skip running tactics to
    -- support @TacticModuleParamCoinductiveRecord@.
    --
    -- The case of metas left dangling comes up when (e.g.) the
    -- constructor is used in pattern-matching through a module that has
    -- more parameters than the original, and such that these parameters
    -- are not determined by unifying the instantiated type of the
    -- constructor with the type of the pattern:
    --
    --    module M1              (A : Type) (x : A) where data D : Type where c : D
    --    module M2 (ign : Type) (A : Type) (x : A) where open M1 A x public renaming (D to D' ; c to c')
    --    open M2
    --    -- c' : {ign : Type} {A : Type} {x : A} → M1.D A x
    --    -- conPars c' = 3
    --
    --    foo : ∀ {A x} → M1.D A x → Type
    --    foo M2.c' = ⊤
    --
    -- Checking that the constructor M2.c' can be used to match on M1.D
    -- succeeds, but leaves a dangling meta standing for the
    -- {ign : Type} parameter around in the TC state. This meta should
    -- not be reported as unsolved, but it also does not appear anywhere
    -- in the definition.
    insert :: Int -> Type -> TCM (Args, Type)
    insert :: Int -> Type -> TCM (Args, Type)
insert Int
0 Type
t = (Args, Type) -> TCM (Args, Type)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Type
t)
    insert Int
n Type
t = do
      t0' <- Type -> TCMT IO Type
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Type
t
      case unEl t0' of
        Pi dom :: Dom Type
dom@(Dom Type -> Type
forall t e. Dom' t e -> e
unDom -> Type
a) Abs Type
b | let x :: ShortText
x = ShortText -> Dom Type -> ShortText
forall a.
(LensNamed a, NameOf a ~ NamedName) =>
ShortText -> a -> ShortText
bareNameWithDefault ShortText
"_" Dom Type
dom, Hiding -> Bool
forall a. LensHiding a => a -> Bool
notVisible (Dom Type -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Dom Type
dom) -> do
          (_, v) <- MetaKind -> ShortText -> Comparison -> Type -> TCM (MetaId, Term)
newMetaArg MetaKind
A.UnificationMeta ShortText
x Comparison
CmpLeq Type
a
          first (Arg (dom ^. dInfo) v :) <$> insert (n-1) (b `absApp` v)
        Term
_ -> (Args, Type) -> TCM (Args, Type)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ([], Type
t0')

    -- Calls the continuation with the number of parameters in the type
    -- (for debugging), with a function to raise the parameters with
    -- necessary, and with the reduced form of the expected record type.
    --
    -- The parameter part of the constructor/projection *telescope* is
    -- instantiated with new metas so that those can vary, e.g., so that
    -- you can use a non-copied constructor of a parametrised type to
    -- match on an instance of the family: if we treated the parameters
    -- as rigid, then the constructors would never be useful, because
    -- the fresh variables would not match the actual parameters of the
    -- family.
    check :: (Int -> (Args -> Args) -> Term -> TCM ()) -> TCM ()
    check :: (Int -> (Args -> Args) -> Term -> TCMT IO ()) -> TCMT IO ()
check Int -> (Args -> Args) -> Term -> TCMT IO ()
cont = case Maybe Projection
proj of
      -- It's a projection: insert until projIndex; must have another pi
      -- type; return that domain.
      Just Projection
proj -> do
        Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (Projection -> Int
projIndex Projection
proj Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
0) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ SplitError -> TCMT IO ()
forall (m :: * -> *) e a.
(HasCallStack, MonadTCError m, Diagnostic e) =>
e -> m a
typeError (SplitError -> TCMT IO ()) -> SplitError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ CannotEliminateWithProjection
          { cantSplitBlocker :: Maybe Blocker
cantSplitBlocker  = Maybe Blocker
forall a. Maybe a
Nothing
          , cantSplitType :: Type
cantSplitType     = Sort' Term -> Term -> Type
forall t a. Sort' t -> a -> Type'' t a
El Sort' Term
HasCallStack => Sort' Term
__DUMMY_SORT__ (QName -> Elims -> Term
Def QName
d (Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Arg Term -> Elim) -> Args -> Elims
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Args
pars'))
          , cantSplitProjWhy :: WhyWrongProj
cantSplitProjWhy  = WhyWrongProj
BecauseNotProj
          , cantSplitProjName :: WrongProjectionName
cantSplitProjName = QName -> WrongProjectionName
UnambWrongProj (Definition -> QName
defName Definition
cdef)
          }

        let pars :: Int
pars = Projection -> Int
projIndex Projection
proj Int -> Int -> Int
forall a. Num a => a -> a -> a
- Int
1
        (_, projT) <- Int -> Type -> TCM (Args, Type)
insert Int
pars (Definition -> Type
defType Definition
cdef)
        (dom, _) <- shouldBePi projT
        cont 0 id =<< reduce (unEl (unDom dom))
      Maybe Projection
Nothing -> do
        -- It's a datatype: insert the declared parameters; drop any
        -- constructor arguments; return the constructor return type.
        let pars :: Int
pars = Defn -> Int
conPars (Definition -> Defn
theDef Definition
cdef)
        (_, conT) <- Int -> Type -> TCM (Args, Type)
insert Int
pars (Definition -> Type
defType Definition
cdef)
        TelV tel conT <- telViewUpToPath (-1) conT
        addContext tel $
          cont pars (raise (length tel)) =<< reduce (unEl conT)

  -- The common case: look up the type of the data-or-record so it can
  -- be fed to compareArgs, then construct an application to the longest
  -- common prefix of vs and pars, and compare them.
  (Int -> (Args -> Args) -> Term -> TCMT IO ()) -> TCMT IO ()
check \Int
n_params Args -> Args
raise Term
conT -> case Term
conT of
    Def QName
conD Elims
es -> do
      let
        pars :: Args
pars = Args -> Args
raise Args
pars'
        vs :: Args
vs   = Elims -> Args
forall a. [Elim' a] -> [Arg a]
mustAllApplyElims Elims
es
        !len :: Int
len = Int -> Int -> Int
forall a. Ord a => a -> a -> a
min (Args -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Args
pars) (Args -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Args
vs)
      t <- Definition -> Type
defType (Definition -> Type) -> TCMT IO Definition -> TCMT IO Type
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
conD
      reportSDoc "tc.lhs.split.params" 40 $ vcat
        [ nest 2 $ "parameters:" <+> pretty n_params
        , nest 2 $ " len =" <+> pretty len
        , nest 2 $ "conD =" <+> pretty conD
        , nest 2 $ "   D =" <+> pretty d
        , nest 2 $ "conT =" <+> pretty (Def conD (Apply <$> take len vs))
        , nest 2 $ "   T =" <+> pretty (Def d (Apply <$> take len pars))
        , nest 2 $ "   t =" <+> prettyTCM t
        ]
      unless (d == conD) $ __IMPOSSIBLE_VERBOSE__ "checkConstructorParameters conD /= d"
      compareArgs [] [] t (Def conD []) (take len vs) (take len 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) -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr a
a Tele (Dom Type)
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 ()
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      -> SplitError -> m ()
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (SplitError -> m ()) -> m SplitError -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM SplitError -> m SplitError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM SplitError -> m SplitError) -> TCM SplitError -> m SplitError
forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> SplitError
SortOfSplitVarError (Maybe Blocker -> Doc -> SplitError)
-> TCMT IO (Maybe Blocker) -> TCMT IO (Doc -> SplitError)
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 -> SplitError) -> TCMT IO Doc -> TCM SplitError
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
        String -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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
          String -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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
        String -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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) -> m ()
loop Tele (Dom Type)
EmptyTel = () -> m ()
forall a. a -> m a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
          loop (ExtendTel Dom Type
a Abs (Tele (Dom Type))
tel) = do
            Type -> m ()
checkIsCoFibrant (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
a)
            Dom Type
-> Abs (Tele (Dom Type)) -> (Tele (Dom Type) -> m ()) -> m ()
forall a (m :: * -> *) b.
(Subst a, MonadAddContext m) =>
Dom Type -> Abs a -> (a -> m b) -> m b
underAbstractionAbs Dom Type
a Abs (Tele (Dom Type))
tel Tele (Dom Type) -> m ()
loop
        Tele (Dom Type) -> m ()
loop Tele (Dom Type)
tel
      | Bool
otherwise              = do
          String -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
String -> Int -> TCMT IO Doc -> m ()
reportSDoc String
"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 -> m ()
checkIsCoFibrant Type
t = Type -> m (Either Blocker Bool)
forall a (m :: * -> *).
(LensSort a, PureTCM m) =>
a -> m (Either Blocker Bool)
isCoFibrantSort Type
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 -> Maybe Blocker -> m ()
splitOnFibrantError' Type
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 -> m Bool
forall (m :: * -> *). MonadTCM m => Type -> m Bool
isInterval Type
t) (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$
                       Type -> Maybe Blocker -> m ()
splitOnFibrantError' Type
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 = SplitError -> m a
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (SplitError -> m a) -> SplitError -> m a
forall a b. (a -> b) -> a -> b
$ DataOrRecord -> SplitError
SplitInProp DataOrRecord
dr

    splitOnFibrantError' :: Type -> Maybe Blocker -> m ()
splitOnFibrantError' Type
t Maybe Blocker
mb = SplitError -> m ()
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (SplitError -> m ()) -> m SplitError -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM SplitError -> m SplitError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM SplitError -> m SplitError) -> TCM SplitError -> m SplitError
forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> SplitError
SortOfSplitVarError Maybe Blocker
mb (Doc -> SplitError) -> TCMT IO Doc -> TCM SplitError
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 -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t, TCMT IO Doc
"is also fibrant."
        ]

    splitOnFibrantError :: Maybe Blocker -> m ()
splitOnFibrantError Maybe Blocker
mb = SplitError -> m ()
forall (m :: * -> *) e a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m,
 Diagnostic e) =>
e -> m a
softTypeError (SplitError -> m ()) -> m SplitError -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM SplitError -> m SplitError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM SplitError -> m SplitError) -> TCM SplitError -> m SplitError
forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> SplitError
SortOfSplitVarError Maybe Blocker
mb (Doc -> SplitError) -> TCMT IO Doc -> TCM SplitError
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"
        ]