{-# LANGUAGE NondecreasingIndentation #-}

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

import Prelude hiding ( null )

import Data.Function (on)
import Data.Maybe

import Control.Arrow (left, second)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Writer       ( MonadWriter(..), runWriterT )
import Control.Monad.Trans.Maybe

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

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

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

import Agda.TypeChecking.Monad

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

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

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

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

--UNUSED Liang-Ting Chen 2019-07-16
---- | Compute the set of flexible patterns in a list of patterns. The result is
----   the deBruijn indices of the flexible patterns.
--flexiblePatterns :: [NamedArg A.Pattern] -> TCM FlexibleVars
--flexiblePatterns nps = do
--  forMaybeM (zip (downFrom $ length nps) nps) $ \ (i, Arg ai p) -> do
--    runMaybeT $ (\ f -> FlexibleVar (getHiding ai) (getOrigin ai) f (Just i) i) <$> maybeFlexiblePattern p

-- | 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, MonadDebug m) => a -> MaybeT m FlexibleVarKind

  isFlexiblePattern :: (HasConstInfo m, MonadDebug 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, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
(HasConstInfo m, MonadDebug 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, MonadDebug m) =>
Pattern -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern
p = do
    [Char] -> Int -> TCMT IO Doc -> MaybeT m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.flex" Int
30 (TCMT IO Doc -> MaybeT m ()) -> TCMT IO Doc -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"maybeFlexiblePattern" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Pattern -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
p
    [Char] -> Int -> TCMT IO Doc -> MaybeT m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.flex" Int
60 (TCMT IO Doc -> MaybeT m ()) -> TCMT IO Doc -> MaybeT m ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"maybeFlexiblePattern (raw) " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc)
-> (Pattern -> [Char]) -> Pattern -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> [Char]
forall a. Show a => a -> [Char]
show (Pattern -> [Char]) -> (Pattern -> Pattern) -> Pattern -> [Char]
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, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
(HasConstInfo m, MonadDebug 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, Defn) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (QName, Defn) -> Bool)
-> MaybeT m (Maybe (QName, Defn)) -> MaybeT m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> MaybeT m (Maybe (QName, Defn))
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Maybe (QName, Defn))
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, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
(HasConstInfo m, MonadDebug 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
      A.AnnP PatInfo
_ Expr
_ Pattern
p -> Pattern -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
(HasConstInfo m, MonadDebug m) =>
Pattern -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern
p
      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, MonadDebug 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, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
(HasConstInfo m, MonadDebug m) =>
[NamedArg (Pattern' a)] -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [NamedArg (Pattern' a)]
ps
        | Bool
otherwise -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.VarP{}  -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.LitP{}  -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.ProjP{} -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.IApplyP{} -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.DefP{} -> MaybeT m FlexibleVarKind
forall a. MaybeT m a
forall (m :: * -> *) a. MonadPlus m => m a
mzero -- TODO Andrea check semantics

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

instance IsFlexiblePattern a => IsFlexiblePattern (Arg a) where
  maybeFlexiblePattern :: forall (m :: * -> *).
(HasConstInfo m, MonadDebug m) =>
Arg a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern = a -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
(HasConstInfo m, MonadDebug 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, MonadDebug m) =>
Named name a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern = a -> MaybeT m FlexibleVarKind
forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
forall (m :: * -> *).
(HasConstInfo m, MonadDebug 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 :: Telescope
tel     = LHSState a
st LHSState a -> Lens' Telescope (LHSState a) -> Telescope
forall o i. o -> Lens' i o -> i
^. (Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
Lens' Telescope (LHSState a)
lhsTel
      problem :: Problem a
problem = LHSState a
st LHSState a -> Lens' (Problem a) (LHSState a) -> Problem a
forall o i. o -> Lens' i o -> i
^. (Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
Lens' (Problem a) (LHSState a)
lhsProblem
  [ProblemEq]
eqs' <- Telescope -> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
tel (TCMT IO [ProblemEq] -> TCMT IO [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ [ProblemEq] -> TCMT IO [ProblemEq]
updateProblemEqs ([ProblemEq] -> TCMT IO [ProblemEq])
-> [ProblemEq] -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a -> Lens' [ProblemEq] (Problem a) -> [ProblemEq]
forall o i. o -> Lens' i o -> i
^. ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs
  Telescope
tel' <- [ProblemEq] -> Telescope -> TCMT IO Telescope
forall (m :: * -> *).
PureTCM m =>
[ProblemEq] -> Telescope -> m Telescope
useNamesFromProblemEqs [ProblemEq]
eqs' Telescope
tel
  LHSState a -> TCM (LHSState a)
forall (m :: * -> *) a.
(PureTCM m, MonadError TCErr m, MonadTrace m,
 MonadFresh NameId m) =>
LHSState a -> m (LHSState a)
updateProblemRest (LHSState a -> TCM (LHSState a)) -> LHSState a -> TCM (LHSState a)
forall a b. (a -> b) -> a -> b
$ Lens' Telescope (LHSState a) -> LensSet Telescope (LHSState a)
forall i o. Lens' i o -> LensSet i o
set (Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
Lens' Telescope (LHSState a)
lhsTel Telescope
tel' (LHSState a -> LHSState a) -> LHSState a -> LHSState a
forall a b. (a -> b) -> a -> b
$ Lens' [ProblemEq] (LHSState a) -> LensSet [ProblemEq] (LHSState a)
forall i o. Lens' i o -> LensSet i o
set ((Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
lhsProblem ((Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a))
-> (([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a))
-> ([ProblemEq] -> f [ProblemEq])
-> LHSState a
-> f (LHSState a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs) [ProblemEq]
eqs' LHSState a
st

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

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

  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"updateProblem: new equations"
    , 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'
    ]

  [ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq]
eqs'

  where

    updates :: [ProblemEq] -> TCM [ProblemEq]
    updates :: [ProblemEq] -> TCMT IO [ProblemEq]
updates = [[ProblemEq]] -> [ProblemEq]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat ([[ProblemEq]] -> [ProblemEq])
-> ([ProblemEq] -> TCMT IO [[ProblemEq]])
-> [ProblemEq]
-> TCMT IO [ProblemEq]
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> (ProblemEq -> TCMT IO [ProblemEq])
-> [ProblemEq] -> TCMT IO [[ProblemEq]]
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> [a] -> f [b]
traverse ProblemEq -> TCMT IO [ProblemEq]
update

    update :: ProblemEq -> TCM [ProblemEq]
    update :: ProblemEq -> TCMT IO [ProblemEq]
update eq :: ProblemEq
eq@(ProblemEq A.WildP{} Term
_ Dom Type
_) = [ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []
    update eq :: ProblemEq
eq@(ProblemEq p :: Pattern
p@A.ProjP{} Term
_ Dom Type
_) = TypeError -> TCMT IO [ProblemEq]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO [ProblemEq])
-> TypeError -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
IllformedProjectionPattern 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])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProblemEq -> TCMT IO [ProblemEq]
update (Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq Pattern
p' Term
v Dom Type
a)

    update eq :: ProblemEq
eq@(ProblemEq p :: Pattern
p@(A.AnnP PatInfo
_ Expr
_ A.WildP{}) Term
v Dom Type
a) = [ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]
    update eq :: ProblemEq
eq@(ProblemEq p :: Pattern
p@(A.AnnP PatInfo
info Expr
ty Pattern
p') Term
v Dom Type
a) =
      (Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (PatInfo -> Expr -> Pattern -> Pattern
forall e. PatInfo -> e -> Pattern' e -> Pattern' e
A.AnnP PatInfo
info Expr
ty (PatInfo -> Pattern
forall e. PatInfo -> Pattern' e
A.WildP PatInfo
patNoRange)) Term
v Dom Type
a ProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProblemEq -> TCMT IO [ProblemEq]
update (Pattern -> 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 -> TCMT IO [ProblemEq]) -> TCMT IO [ProblemEq]
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Con ConHead
c ConInfo
ci Elims
es -> do
        let vs :: Args
vs = Args -> Maybe Args -> Args
forall a. a -> Maybe a -> a
fromMaybe Args
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Args -> Args) -> Maybe Args -> Args
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
        -- we should only simplify equations between fully applied constructors
        Maybe ((QName, Type, Args), Type)
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)
        Maybe ((QName, Type, Args), Type)
-> TCMT IO [ProblemEq]
-> (((QName, Type, Args), Type) -> TCMT IO [ProblemEq])
-> TCMT IO [ProblemEq]
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe ((QName, Type, Args), Type)
contype ([ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]) ((((QName, Type, Args), Type) -> TCMT IO [ProblemEq])
 -> TCMT IO [ProblemEq])
-> (((QName, Type, Args), Type) -> TCMT IO [ProblemEq])
-> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ \((QName
d,Type
_,Args
pars),Type
b) -> do
        TelV Telescope
ctel Type
_ <- Type -> TCMT IO (TelV Type)
forall (m :: * -> *). PureTCM m => Type -> m (TelV Type)
telViewPath Type
b

        -- Andrea 15/10/2020: propagate modality to constructor arguments
        let updMod :: Modality -> Modality
updMod = Modality -> Modality -> Modality
composeModality (Dom Type -> Modality
forall a. LensModality a => a -> Modality
getModality Dom Type
a)
        Telescope
ctel <- Telescope -> TCMT IO Telescope
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope -> TCMT IO Telescope) -> Telescope -> TCMT IO Telescope
forall a b. (a -> b) -> a -> b
$ (Modality -> Modality) -> Dom Type -> Dom Type
forall a. LensModality a => (Modality -> Modality) -> a -> a
mapModality Modality -> Modality
updMod (Dom Type -> Dom Type) -> Telescope -> Telescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope
ctel

        let bs :: [Dom Type]
bs = Telescope -> [Term] -> [Dom Type]
instTel Telescope
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)

        Pattern
p <- Pattern -> TCMT IO Pattern
forall (m :: * -> *).
(MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasBuiltins m) =>
Pattern -> m Pattern
expandLitPattern Pattern
p
        case Pattern
p of
          A.AsP{} -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
          A.AnnP{} -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
          A.ConP ConPatInfo
cpi AmbiguousQName
ambC [NamedArg Pattern]
ps -> do
            (ConHead
c',Type
_) <- AmbiguousQName -> QName -> Args -> TCM (ConHead, Type)
disambiguateConstructor 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 ConHead -> QName
conName ConHead
c QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
/= ConHead -> QName
conName ConHead
c' then [ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq] else do

            -- Insert implicit patterns
            [NamedArg Pattern]
ps <- ExpandHidden
-> [NamedArg Pattern] -> Telescope -> TCMT IO [NamedArg Pattern]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
 MonadTrace m) =>
ExpandHidden
-> [NamedArg Pattern] -> Telescope -> m [NamedArg Pattern]
insertImplicitPatterns ExpandHidden
ExpandLast [NamedArg Pattern]
ps Telescope
ctel
            [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.imp" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
              TCMT IO Doc
"insertImplicitPatternsT returned" 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
fsep ((NamedArg Pattern -> TCMT IO Doc)
-> [NamedArg Pattern] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA [NamedArg Pattern]
ps)

            -- Check argument count and hiding (not just count: #3074)
            let checkArgs :: [NamedArg Pattern] -> Args -> TCMT IO ()
checkArgs [] [] = () -> 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)
                  | 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 -> TCMT IO ()
checkArgs [NamedArg Pattern]
ps Args
vs
                  | 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
$ Doc -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Doc -> m a
genericDocError (Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                      [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> [TCMT IO Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords ([Char]
"Expected an " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Hiding -> [Char]
forall {a}. IsString a => Hiding -> a
which (Arg Term -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding Arg Term
v) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" argument " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++
                                     [Char]
"instead of "  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Hiding -> [Char]
forall {a}. IsString a => Hiding -> a
which (NamedArg Pattern -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding NamedArg Pattern
p) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" argument") [TCMT IO Doc] -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. [a] -> [a] -> [a]
++
                             [ NamedArg Pattern -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA NamedArg Pattern
p ]
                  where which :: Hiding -> a
which Hiding
NotHidden  = a
"explicit"
                        which Hiding
Hidden     = a
"implicit"
                        which Instance{} = a
"instance"
                checkArgs [] Args
vs = Doc -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Doc -> m a
genericDocError (Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> [TCMT IO Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords [Char]
"Too few arguments to constructor" [TCMT IO Doc] -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. [a] -> [a] -> [a]
++ [ConHead -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ConHead -> m Doc
prettyTCM ConHead
c TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> TCMT IO Doc
","] [TCMT IO Doc] -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. [a] -> [a] -> [a]
++
                           [Char] -> [TCMT IO Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords ([Char]
"expected " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Int -> [Char]
forall a. Show a => a -> [Char]
show Int
n [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" more explicit "  [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
arguments)
                  where n :: Int
n = Args -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length ((Arg Term -> Bool) -> Args -> Args
forall a. (a -> Bool) -> [a] -> [a]
filter Arg Term -> Bool
forall a. LensHiding a => a -> Bool
visible Args
vs)
                        arguments :: [Char]
arguments | Int
n Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1    = [Char]
"argument"
                                  | Bool
otherwise = [Char]
"arguments"
                checkArgs (NamedArg Pattern
p : [NamedArg Pattern]
_) [] = 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
$ Doc -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
Doc -> m a
genericDocError (Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                  [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> [TCMT IO Doc]
forall (m :: * -> *). Applicative m => [Char] -> [m Doc]
pwords [Char]
"Too many arguments to constructor" [TCMT IO Doc] -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. [a] -> [a] -> [a]
++ [ConHead -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ConHead -> m Doc
prettyTCM ConHead
c]
            [NamedArg Pattern] -> Args -> TCMT IO ()
checkArgs [NamedArg Pattern]
ps Args
vs

            [ProblemEq] -> TCMT IO [ProblemEq]
updates ([ProblemEq] -> TCMT IO [ProblemEq])
-> [ProblemEq] -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ (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

          A.RecP PatInfo
pi [FieldAssignment' Pattern]
fs -> do
            [Arg QName]
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 => 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.
            [Name] -> [QName] -> TCMT IO ()
disambiguateRecordFields ((FieldAssignment' Pattern -> Name)
-> [FieldAssignment' Pattern] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map FieldAssignment' Pattern -> Name
forall a. FieldAssignment' a -> Name
_nameFieldA [FieldAssignment' Pattern]
fs) ((Arg QName -> QName) -> [Arg QName] -> [QName]
forall a b. (a -> b) -> [a] -> [b]
map Arg QName -> QName
forall e. Arg e -> e
unArg [Arg QName]
axs)

            let cxs :: [Arg Name]
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.
            [NamedArg Pattern]
ps <- QName
-> (Name -> Pattern)
-> [FieldAssignment' Pattern]
-> [Arg Name]
-> TCMT IO [NamedArg Pattern]
forall a.
HasRange a =>
QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFieldsFail 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
patNoRange) [FieldAssignment' Pattern]
fs [Arg Name]
cxs

            -- We also need to insert missing implicit or instance fields.
            [NamedArg Pattern]
ps <- ExpandHidden
-> [NamedArg Pattern] -> Telescope -> TCMT IO [NamedArg Pattern]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
 MonadTrace m) =>
ExpandHidden
-> [NamedArg Pattern] -> Telescope -> m [NamedArg Pattern]
insertImplicitPatterns ExpandHidden
ExpandLast [NamedArg Pattern]
ps Telescope
ctel

            let eqs :: [ProblemEq]
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
            [ProblemEq] -> TCMT IO [ProblemEq]
updates [ProblemEq]
eqs

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

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

      Term
_ | A.EqualP{} <- Pattern
p -> do
        Term
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
        TCMT IO Bool
-> TCMT IO [ProblemEq]
-> TCMT IO [ProblemEq]
-> TCMT IO [ProblemEq]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (TCMT IO () -> TCMT IO Bool
forall (m :: * -> *).
(MonadConstraint m, MonadWarning m, MonadError TCErr m,
 MonadFresh ProblemId m) =>
m () -> m Bool
tryConversion (TCMT IO () -> TCMT IO Bool) -> TCMT IO () -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ Type -> Term -> Term -> TCMT IO ()
forall (m :: * -> *).
MonadConversion m =>
Type -> Term -> Term -> m ()
equalTerm (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
a) Term
v Term
itisone) ([ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return []) ([ProblemEq] -> TCMT IO [ProblemEq]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq])

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

    instTel :: Telescope -> [Term] -> [Dom Type]
    instTel :: Telescope -> [Term] -> [Dom Type]
instTel Telescope
EmptyTel [Term]
_                   = []
    instTel (ExtendTel Dom Type
arg Abs Telescope
tel) (Term
u : [Term]
us) = Dom Type
arg Dom Type -> [Dom Type] -> [Dom Type]
forall a. a -> [a] -> [a]
: Telescope -> [Term] -> [Dom Type]
instTel (Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs Telescope
tel Term
SubstArg Telescope
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
-> Lens' [NamedArg Pattern] (Problem a) -> [NamedArg Pattern]
forall o i. o -> Lens' i o -> i
^. ([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
Lens' [NamedArg Pattern] (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
-> Lens' [NamedArg Pattern] (Problem a) -> [NamedArg Pattern]
forall o i. o -> Lens' i o -> i
^. ([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
Lens' [NamedArg Pattern] (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
    isSolved (A.AnnP PatInfo
_ e
_ 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{domInfo :: forall t e. Dom' t e -> ArgInfo
domInfo = ArgInfo
info, unDom :: forall t e. Dom' t e -> e
unDom = El Sort' Term
_ Term
a})) =
  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 :: Pattern
problemInPat = Pattern
p }
   A.AnnP PatInfo
_ Expr
_ Pattern
p     -> ProblemEq -> TCMT IO ()
noShadowingOfConstructors (ProblemEq -> TCMT IO ()) -> ProblemEq -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ ProblemEq
problem { problemInPat :: Pattern
problemInPat = Pattern
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 (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ArgInfo -> Origin
forall a. LensOrigin a => a -> Origin
getOrigin ArgInfo
info Origin -> Origin -> Bool
forall a. Eq a => a -> a -> Bool
== Origin
UserWritten) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.shadow" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"checking whether pattern variable " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Name
x [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" shadows a constructor"
      , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"type of variable =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
a
      , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"position of variable =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc)
-> (Range' SrcFile -> [Char]) -> Range' SrcFile -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range' SrcFile -> [Char]
forall a. Show a => a -> [Char]
show) (Name -> Range' SrcFile
forall a. HasRange a => a -> Range' SrcFile
getRange Name
x)
      ]
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.shadow" Int
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"a =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
a
    Term
a <- Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
a
    case Term
a of
      Def QName
t Elims
_ -> do
        Defn
d <- 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 => QName -> m Definition
getConstInfo QName
t
        case Defn
d of
          Datatype { dataCons :: Defn -> [QName]
dataCons = [QName]
cs } -> do
            case (QName -> Bool) -> [QName] -> [QName]
forall a. (a -> Bool) -> [a] -> [a]
filter ((Name -> Name
A.nameConcrete Name
x Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
==) (Name -> Bool) -> (QName -> Name) -> QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
A.nameConcrete (Name -> Name) -> (QName -> Name) -> QName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
A.qnameName) [QName]
cs of
              []      -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              (QName
c : [QName]
_) -> 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
$
                TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Name -> QName -> TypeError
PatternShadowsConstructor (Name -> Name
nameConcrete Name
x) QName
c
          AbstractDefn{} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            -- 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.
          Axiom       {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          DataOrRecSig{} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Function    {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Record      {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Constructor {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
          GeneralizableVar{} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
          -- TODO: in the future some stuck primitives might allow constructors
          Primitive   {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          PrimitiveSort{} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Var   {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Pi    {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Sort  {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      MetaV {} -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      -- 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.
      Lam   {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      Lit   {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      Level {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      Con   {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      DontCare{} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      Dummy [Char]
s Elims
_  -> [Char] -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
[Char] -> m a
__IMPOSSIBLE_VERBOSE__ [Char]
s

-- | Check that a dot pattern matches it's instantiation.
checkDotPattern :: DotPattern -> TCM ()
checkDotPattern :: DotPattern -> TCMT IO ()
checkDotPattern (Dot Expr
e Term
v (Dom{domInfo :: forall t e. Dom' t e -> ArgInfo
domInfo = ArgInfo
info, unDom :: 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
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.dot" Int
15 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"checking dot pattern"
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Expr
e
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"=" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
":" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
a
        ]
  ArgInfo -> TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) m a.
(MonadTCEnv tcm, LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext ArgInfo
info (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
    Term
u <- Expr -> Type -> TCMT IO Term
checkExpr Expr
e Type
a
    [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.dot" Int
50 (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
"equalTerm"
          , 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
$ Type -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type
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
$ Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
u
          , 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
$ Term -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v
          ]
    Type -> Term -> Term -> TCMT IO ()
forall (m :: * -> *).
MonadConversion m =>
Type -> Term -> Term -> m ()
equalTerm Type
a Term
u Term
v

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

checkAnnotationPattern :: AnnotationPattern -> TCM ()
checkAnnotationPattern :: AnnotationPattern -> TCMT IO ()
checkAnnotationPattern (Ann Expr
t Type
a) = do
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.ann" Int
15 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"checking type annotation in pattern"
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Expr
t
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"=" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
a
        ]
  Type
b <- Expr -> TCMT IO Type
isType_ Expr
t
  Type -> Type -> TCMT IO ()
forall (m :: * -> *). MonadConversion m => Type -> Type -> m ()
equalType Type
a Type
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
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.origin" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"transferOrigins"
    , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ TCMT IO Doc
"ps  =   " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [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
          NamedArg DeBruijnPattern
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
          (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]
ps [NamedArg DeBruijnPattern]
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], [Expr], Pattern)
asView Pattern
p , DeBruijnPattern
q) of

      (([Name]
asB , [Expr]
anns , 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 , [Expr]
anns , A.RecP PatInfo
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 = (Arg QName -> Name) -> [Arg QName] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name
nameConcrete (Name -> Name) -> (Arg QName -> Name) -> Arg QName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName (QName -> Name) -> (Arg QName -> QName) -> Arg QName -> Name
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg QName -> QName
forall e. Arg e -> e
unArg) (ConHead -> [Arg QName]
conFields ConHead
c) [Name] -> [NamedArg DeBruijnPattern] -> [Arg Name]
forall a b. [a] -> [Arg b] -> [Arg a]
`withArgsFrom` [NamedArg DeBruijnPattern]
qs
            cpi :: ConPatternInfo
cpi = PatternInfo
-> Bool -> Bool -> Maybe (Arg Type) -> Bool -> ConPatternInfo
ConPatternInfo (PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatORec [Name]
asB) Bool
r Bool
ft Maybe (Arg Type)
mb Bool
l
        [NamedArg Pattern]
ps <- QName
-> (Name -> Pattern)
-> [FieldAssignment' Pattern]
-> [Arg Name]
-> TCMT IO [NamedArg Pattern]
forall a.
HasRange a =>
QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFieldsFail 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
patNoRange) [FieldAssignment' Pattern]
fs [Arg Name]
axs
        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 , [Expr]
anns , 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 , [Expr]
anns , 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 , [Expr]
anns , 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 , [Expr]
anns , 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], [Expr], 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__
    patOrig A.AnnP{}        = 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] -> TCMT IO [ProblemEq]
checkPatternLinearity [ProblemEq]
eqs = do
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.linear" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Checking linearity of pattern variables"
  Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [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] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type)
_ [] = [ProblemEq] -> TCMT IO [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
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.linear" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ TCMT IO Doc
"linearity: checking pattern "
        , Pattern -> 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
          [Char] -> Int -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.lhs.linear" Int
60 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
            [Char]
"pattern variable " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Name -> Name
A.nameConcrete Name
y) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
" with id " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NameId -> [Char]
forall a. Show a => a -> [Char]
show (Name -> NameId
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, MonadWarning m, MonadError TCErr 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 ()
forall (m :: * -> *). MonadConversion m => Type -> Type -> m ()
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, MonadWarning m, MonadError TCErr 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 ()
forall (m :: * -> *).
MonadConversion m =>
Type -> Term -> Term -> m ()
equalTerm (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
a) Term
u Term
v
              Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type)
vars [ProblemEq]
eqs
            Maybe (Term, Type)
Nothing -> (ProblemEq
eqProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [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] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type)
vars ([ProblemEq] -> TCMT IO [ProblemEq])
-> [ProblemEq] -> TCMT IO [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.AnnP PatInfo
_ Expr
_ A.WildP{} -> TCMT IO [ProblemEq]
continue
        A.AnnP PatInfo
r Expr
t Pattern
p -> (Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (PatInfo -> Expr -> Pattern -> Pattern
forall e. PatInfo -> e -> Pattern' e -> Pattern' e
A.AnnP PatInfo
r Expr
t (PatInfo -> Pattern
forall e. PatInfo -> Pattern' e
A.WildP PatInfo
patNoRange)) Term
u Dom Type
aProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
          Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type)
vars (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{}       -> TCMT IO [ProblemEq]
continue
        A.DotP{}        -> TCMT IO [ProblemEq]
continue
        A.AbsurdP{}     -> TCMT IO [ProblemEq]
continue
        A.ConP{}        -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.ProjP{}       -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.DefP{}        -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.LitP{}        -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.PatternSynP{} -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.RecP{}        -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.EqualP{}      -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__
        A.WithP{}       -> TCMT IO [ProblemEq]
forall a. HasCallStack => a
__IMPOSSIBLE__

      where continue :: TCMT IO [ProblemEq]
continue = (ProblemEq
eqProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [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] -> Telescope -> TCM Context
computeLHSContext = Context -> [Name] -> [Maybe Name] -> Telescope -> TCM Context
forall {m :: * -> *} {f :: * -> *} {a}.
(MonadDebug m, PrettyTCM (Tele (f a)), MonadFresh NameId m,
 Subst (f a), Functor f) =>
[f (Name, a)]
-> [Name] -> [Maybe Name] -> Tele (f a) -> m [f (Name, a)]
go [] []
  where
    go :: [f (Name, a)]
-> [Name] -> [Maybe Name] -> Tele (f a) -> m [f (Name, a)]
go [f (Name, a)]
cxt [Name]
_ []        tel :: Tele (f a)
tel@ExtendTel{} = do
      [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"impossible" Int
10 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"computeLHSContext: no patterns left, but tel =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Tele (f a) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Tele (f a) -> m Doc
prettyTCM Tele (f a)
tel
      m [f (Name, a)]
forall a. HasCallStack => a
__IMPOSSIBLE__
    go [f (Name, a)]
cxt [Name]
_ (Maybe Name
_ : [Maybe Name]
_)   Tele (f a)
EmptyTel = m [f (Name, a)]
forall a. HasCallStack => a
__IMPOSSIBLE__
    go [f (Name, a)]
cxt [Name]
_ []        Tele (f a)
EmptyTel = [f (Name, a)] -> m [f (Name, a)]
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return [f (Name, a)]
cxt
    go [f (Name, a)]
cxt [Name]
taken (Maybe Name
x : [Maybe Name]
xs) tel0 :: Tele (f a)
tel0@(ExtendTel f a
a Abs (Tele (f a))
tel) = do
        Name
name <- m Name -> (Name -> m Name) -> Maybe Name -> m Name
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([Name] -> [Char] -> m Name
forall {m :: * -> *} {p}.
MonadFresh NameId m =>
p -> [Char] -> m Name
dummyName [Name]
taken ([Char] -> m Name) -> [Char] -> m Name
forall a b. (a -> b) -> a -> b
$ Abs (Tele (f a)) -> [Char]
forall a. Abs a -> [Char]
absName Abs (Tele (f a))
tel) Name -> m Name
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
x
        let e :: f (Name, a)
e = (Name
name,) (a -> (Name, a)) -> f a -> f (Name, a)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
a
        [f (Name, a)]
-> [Name] -> [Maybe Name] -> Tele (f a) -> m [f (Name, a)]
go (f (Name, a)
e f (Name, a) -> [f (Name, a)] -> [f (Name, a)]
forall a. a -> [a] -> [a]
: [f (Name, a)]
cxt) (Name
name Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
taken) [Maybe Name]
xs (Abs (Tele (f a)) -> Tele (f a)
forall a. Subst a => Abs a -> a
absBody Abs (Tele (f a))
tel)

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

-- | Bind as patterns
bindAsPatterns :: [AsBinding] -> TCM a -> TCM a
bindAsPatterns :: forall a. [AsBinding] -> TCM a -> TCM a
bindAsPatterns []                TCM a
ret = TCM a
ret
bindAsPatterns (AsB Name
x Term
v Type
a Modality
m : [AsBinding]
asb) TCM a
ret = do
  [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.as" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"as pattern" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Name -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Name -> m Doc
prettyTCM Name
x TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
":" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> 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
"=" 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
        ]
  ArgInfo -> Name -> Term -> Type -> TCM a -> TCM a
forall (m :: * -> *) a.
MonadAddContext m =>
ArgInfo -> Name -> Term -> Type -> m a -> m a
addLetBinding (Modality -> ArgInfo -> ArgInfo
forall a. LensModality a => Modality -> a -> a
setModality Modality
m ArgInfo
defaultArgInfo) Name
x Term
v 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) = Term -> Comparison -> Type -> TCMT IO ()
forall (m :: * -> *).
MonadCheckInternal m =>
Term -> Comparison -> Type -> m ()
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 :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ())
-> (Doc -> TypeError) -> Doc -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"Ill-typed pattern after with abstraction: " 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
    , TCMT IO Doc
"(perhaps you can replace it by `_`?)"
    ]

-- | 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 -> Telescope
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 -> Arg Type
lhsBodyType     :: Arg Type
    -- ^ The type of the body. Is @bσ@ if @Γ@ is defined.
    -- 'Irrelevant' to indicate the rhs must be checked in irrelevant mode.
  , LHSResult -> Substitution
lhsPatSubst     :: Substitution
    -- ^ Substitution version of @lhsPatterns@, only up to the first projection
    -- pattern. @Δ |- lhsPatSubst : Γ@. Where @Γ@ is the argument telescope of
    -- the function. This is used to update inherited dot patterns in
    -- with-function clauses.
  , LHSResult -> [AsBinding]
lhsAsBindings   :: [AsBinding]
    -- ^ As-bindings from the left-hand side. Return instead of bound since we
    -- want them in where's and right-hand sides, but not in with-clauses
    -- (Issue 2303).
  , LHSResult -> IntSet
lhsPartialSplit :: IntSet
    -- ^ have we done a partial split?
  , LHSResult -> Bool
lhsIndexedSplit :: Bool
    -- ^ have we split on an indexed type?
  }

instance InstantiateFull LHSResult where
  instantiateFull' :: LHSResult -> ReduceM LHSResult
instantiateFull' (LHSResult Int
n Telescope
tel [NamedArg DeBruijnPattern]
ps Bool
abs Arg Type
t Substitution
sub [AsBinding]
as IntSet
psplit Bool
ixsplit) = Int
-> Telescope
-> [NamedArg DeBruijnPattern]
-> Bool
-> Arg Type
-> Substitution
-> [AsBinding]
-> IntSet
-> Bool
-> LHSResult
LHSResult Int
n
    (Telescope
 -> [NamedArg DeBruijnPattern]
 -> Bool
 -> Arg Type
 -> Substitution
 -> [AsBinding]
 -> IntSet
 -> Bool
 -> LHSResult)
-> ReduceM Telescope
-> ReduceM
     ([NamedArg DeBruijnPattern]
      -> Bool
      -> Arg Type
      -> Substitution
      -> [AsBinding]
      -> IntSet
      -> Bool
      -> LHSResult)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope -> ReduceM Telescope
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Telescope
tel
    ReduceM
  ([NamedArg DeBruijnPattern]
   -> Bool
   -> Arg Type
   -> Substitution
   -> [AsBinding]
   -> IntSet
   -> Bool
   -> LHSResult)
-> ReduceM [NamedArg DeBruijnPattern]
-> ReduceM
     (Bool
      -> Arg 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
   -> Arg Type
   -> Substitution
   -> [AsBinding]
   -> IntSet
   -> Bool
   -> LHSResult)
-> ReduceM Bool
-> ReduceM
     (Arg 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
  (Arg Type
   -> Substitution -> [AsBinding] -> IntSet -> Bool -> LHSResult)
-> ReduceM (Arg 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
<*> Arg Type -> ReduceM (Arg Type)
forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Arg 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

-- | 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'.
  -> Maybe QName
     -- ^ The name of the definition we are checking.
  -> [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
-> Maybe QName
-> [NamedArg Pattern]
-> Type
-> Maybe Substitution
-> [ProblemEq]
-> (LHSResult -> TCM a)
-> TCM a
checkLeftHandSide Call
call Maybe QName
f [NamedArg Pattern]
ps Type
a Maybe Substitution
withSub' [ProblemEq]
strippedPats =
 Account (BenchPhase (TCMT IO))
-> ((LHSResult -> TCMT IO a) -> TCMT IO a)
-> (LHSResult -> TCMT IO a)
-> TCMT IO a
forall (m :: * -> *) b c.
MonadBench m =>
Account (BenchPhase m) -> ((b -> m c) -> m c) -> (b -> m c) -> m c
Bench.billToCPS [BenchPhase (TCMT IO)
Phase
Bench.Typing, BenchPhase (TCMT IO)
Phase
Bench.CheckLHS] (((LHSResult -> TCMT IO a) -> TCMT IO a)
 -> (LHSResult -> TCMT IO a) -> TCMT IO a)
-> ((LHSResult -> TCMT IO a) -> TCMT IO a)
-> (LHSResult -> TCMT IO a)
-> TCMT IO a
forall a b. (a -> b) -> a -> b
$
 Call
-> ((LHSResult -> TCMT IO a) -> TCMT IO a)
-> (LHSResult -> TCMT IO a)
-> TCMT IO a
forall a b.
Call
-> ((a -> TCMT IO b) -> TCMT IO b) -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b.
MonadTrace m =>
Call -> ((a -> m b) -> m b) -> (a -> m b) -> m b
traceCallCPS Call
call (((LHSResult -> TCMT IO a) -> TCMT IO a)
 -> (LHSResult -> TCMT IO a) -> TCMT IO a)
-> ((LHSResult -> TCMT IO a) -> TCMT IO a)
-> (LHSResult -> TCMT IO a)
-> TCMT IO a
forall a b. (a -> b) -> a -> b
$ \ LHSResult -> TCMT IO a
ret -> do

  -- To allow module parameters to be refined by matching, we're adding the
  -- context arguments as wildcard patterns and extending the type with the
  -- context telescope.
  Context
cxt <- (ContextEntry -> ContextEntry) -> Context -> Context
forall a b. (a -> b) -> [a] -> [b]
map (Origin -> ContextEntry -> ContextEntry
forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted) (Context -> Context) -> (Context -> Context) -> Context -> Context
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Context -> Context
forall a. [a] -> [a]
reverse (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 :: Telescope
tel = (Name -> [Char]) -> Context -> Telescope
forall a. (a -> [Char]) -> ListTel' a -> Telescope
telFromList' Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow Context
cxt
      cps :: [NamedArg Pattern]
cps = [ Pattern -> Named NamedName Pattern
forall a name. a -> Named name a
unnamed (Pattern -> Named NamedName Pattern)
-> ((Name, Type) -> Pattern)
-> (Name, Type)
-> Named NamedName Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BindName -> Pattern
forall e. BindName -> Pattern' e
A.VarP (BindName -> Pattern)
-> ((Name, Type) -> BindName) -> (Name, Type) -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> BindName
A.mkBindName (Name -> BindName)
-> ((Name, Type) -> Name) -> (Name, Type) -> BindName
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, Type) -> Name
forall a b. (a, b) -> a
fst ((Name, Type) -> Named NamedName Pattern)
-> Arg (Name, Type) -> NamedArg Pattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ContextEntry -> Arg (Name, Type)
forall t a. Dom' t a -> Arg a
argFromDom ContextEntry
d
            | ContextEntry
d <- Context
cxt ]
      eqs0 :: [ProblemEq]
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
$ Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
tel) (Telescope -> [Dom Type]
forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel Telescope
tel)

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

        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"lhs: final checks with remaining equations"
          , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
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 Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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
          , TCMT IO Doc
"qs0 =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta ([NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList [NamedArg DeBruijnPattern]
qs0)
          ]

        Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([NamedArg Pattern] -> Bool
forall a. Null a => a -> Bool
null [NamedArg Pattern]
rps) TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__

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

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

        Int
arity_a <- Type -> TCM Int
arityPiPath Type
a
        -- Compute substitution from the out patterns @qs0@
        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]
qs0

            -- We have two slightly different cases here: normal function and
            -- with-function. In both cases the goal is to build a substitution
            -- from the context Γ of the previous checkpoint to the current lhs
            -- context Δ:
            --
            --    Δ ⊢ paramSub : Γ
            --
            --  * Normal function, f
            --
            --    Γ = cxt = module parameter telescope of f
            --    Ψ = non-parameter arguments of f (we have f : Γ Ψ → A)
            --    Δ   ⊢ patSub  : Γ Ψ
            --    Γ Ψ ⊢ weakSub : Γ
            --    paramSub = patSub ∘ weakSub
            --
            --  * With-function
            --
            --    Γ = lhs context of the parent clause (cxt = [])
            --    Ψ = argument telescope of with-function
            --    Θ = inserted implicit patterns not in Ψ (#2827)
            --        (this happens if the goal computes to an implicit
            --         function type after some matching in the with-clause)
            --
            --    Ψ   ⊢ withSub : Γ
            --    Δ   ⊢ patSub  : Ψ Θ
            --    Ψ Θ ⊢ weakSub : Ψ
            --    paramSub = patSub ∘ weakSub ∘ withSub
            --
            --    To compute Θ we can look at the arity of the with-function
            --    and compare it to numPats. This works since the with-function
            --    type is fully reduced.

            weakSub :: Substitution
            weakSub :: Substitution
weakSub | Maybe Substitution -> Bool
forall a. Maybe a -> Bool
isJust Maybe Substitution
withSub' = 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_a) Substitution
forall a. Substitution' a
idS -- if numPats < arity, Θ is empty
                    | Bool
otherwise       = 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. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
cxt) Substitution
forall a. Substitution' a
idS
            withSub :: Substitution
withSub  = Substitution -> Maybe Substitution -> Substitution
forall a. a -> Maybe a -> a
fromMaybe Substitution
forall a. Substitution' a
idS Maybe Substitution
withSub'
            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]
qs0) [Term] -> Substitution -> Substitution
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Impossible -> Substitution
forall a. Impossible -> Substitution' a
EmptyS Impossible
HasCallStack => Impossible
impossible
            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

        [ProblemEq]
eqs <- Telescope -> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta (TCMT IO [ProblemEq] -> TCMT IO [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ [ProblemEq] -> TCMT IO [ProblemEq]
checkPatternLinearity [ProblemEq]
eqs

        leftovers :: LeftoverPatterns
leftovers@(LeftoverPatterns IntMap [(Name, PatVarPosition)]
patVars [AsBinding]
asb0 [DotPattern]
dots [AbsurdPattern]
absurds [AnnotationPattern]
annps [Pattern]
otherPats)
          <- Telescope -> TCMT IO LeftoverPatterns -> TCMT IO LeftoverPatterns
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta (TCMT IO LeftoverPatterns -> TCMT IO LeftoverPatterns)
-> TCMT IO LeftoverPatterns -> TCMT IO LeftoverPatterns
forall a b. (a -> b) -> a -> b
$ [ProblemEq] -> TCMT IO LeftoverPatterns
forall (m :: * -> *).
PureTCM m =>
[ProblemEq] -> m LeftoverPatterns
getLeftoverPatterns [ProblemEq]
eqs

        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.leftover" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"leftover patterns: " , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ LeftoverPatterns -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => LeftoverPatterns -> m Doc
prettyTCM LeftoverPatterns
leftovers) ]

        Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless ([Pattern] -> Bool
forall a. Null a => a -> Bool
null [Pattern]
otherPats) TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__

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

        -- Rename internal patterns with these names
        let makeVar :: Maybe Name -> Int -> DeBruijnPattern
makeVar     = (Int -> DeBruijnPattern)
-> (Name -> Int -> DeBruijnPattern)
-> Maybe Name
-> Int
-> DeBruijnPattern
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Int -> DeBruijnPattern
forall a. DeBruijn a => Int -> a
deBruijnVar ((Name -> Int -> DeBruijnPattern)
 -> Maybe Name -> Int -> DeBruijnPattern)
-> (Name -> Int -> DeBruijnPattern)
-> Maybe Name
-> Int
-> DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ [Char] -> Int -> DeBruijnPattern
forall a. DeBruijn a => [Char] -> Int -> a
debruijnNamedVar ([Char] -> Int -> DeBruijnPattern)
-> (Name -> [Char]) -> Name -> Int -> DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameToArgName
            ren :: PatternSubstitution
ren         = [DeBruijnPattern] -> PatternSubstitution
forall a. DeBruijn a => [a] -> Substitution' a
parallelS ([DeBruijnPattern] -> PatternSubstitution)
-> [DeBruijnPattern] -> PatternSubstitution
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..]

        [NamedArg DeBruijnPattern]
qs <- [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transferOrigins ([NamedArg Pattern]
cps [NamedArg Pattern] -> [NamedArg Pattern] -> [NamedArg Pattern]
forall a. [a] -> [a] -> [a]
++ [NamedArg Pattern]
ps) ([NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg 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 PatternSubstitution
Substitution' (SubstArg [NamedArg DeBruijnPattern])
ren [NamedArg DeBruijnPattern]
qs0

        let hasAbsurd :: Bool
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 :: LHSResult
lhsResult = Int
-> Telescope
-> [NamedArg DeBruijnPattern]
-> Bool
-> Arg Type
-> Substitution
-> [AsBinding]
-> IntSet
-> Bool
-> LHSResult
LHSResult (Context -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
cxt) Telescope
delta [NamedArg DeBruijnPattern]
qs Bool
hasAbsurd Arg 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
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
          [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat [ TCMT IO Doc
"checked 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] -> 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
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
delta
                 , TCMT IO Doc
"dots    = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta (TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets (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
fsep ([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]
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc
comma ([TCMT IO Doc] -> [TCMT IO Doc]) -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ (DotPattern -> TCMT IO Doc) -> [DotPattern] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map DotPattern -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => DotPattern -> m Doc
prettyTCM [DotPattern]
dots)
                 , TCMT IO Doc
"asb     = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta (TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets (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
fsep ([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]
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc
comma ([TCMT IO Doc] -> [TCMT IO Doc]) -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ (AsBinding -> TCMT IO Doc) -> [AsBinding] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map AsBinding -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => AsBinding -> m Doc
prettyTCM [AsBinding]
asb)
                 , TCMT IO Doc
"absurds = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta (TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets (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
fsep ([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]
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc
comma ([TCMT IO Doc] -> [TCMT IO Doc]) -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ (AbsurdPattern -> TCMT IO Doc) -> [AbsurdPattern] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map AbsurdPattern -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => AbsurdPattern -> m Doc
prettyTCM [AbsurdPattern]
absurds)
                 , TCMT IO Doc
"qs      = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta ([TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ (NamedArg DeBruijnPattern -> TCMT IO Doc)
-> [NamedArg DeBruijnPattern] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg DeBruijnPattern -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
qs)
                 , TCMT IO Doc
"b       = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta (Arg Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Type -> m Doc
prettyTCM Arg Type
b)
                 ]
               ]
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
          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
"vars   = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Maybe Name] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [Maybe Name]
vars
                 , TCMT IO Doc
"b      = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Type -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Arg Type
b
                 ]
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ 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
"withSub  = " 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
withSub
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ 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
"weakSub  = " 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
weakSub
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ 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
"patSub   = " 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
patSub
        [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ 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
"paramSub = " 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
paramSub

        Context
newCxt <- [Maybe Name] -> Telescope -> TCM Context
computeLHSContext [Maybe Name]
vars Telescope
delta

        Substitution -> (Context -> Context) -> TCMT IO a -> TCMT IO a
forall a.
Substitution -> (Context -> Context) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadAddContext m =>
Substitution -> (Context -> Context) -> m a -> m a
updateContext Substitution
paramSub (Context -> Context -> Context
forall a b. a -> b -> a
const Context
newCxt) (TCMT IO a -> TCMT IO a) -> TCMT IO a -> TCMT IO a
forall a b. (a -> b) -> a -> b
$ do

          [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"bound pattern variables"
          [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
60 (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
"context = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Telescope -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Telescope -> TCMT IO Doc) -> TCMT IO Telescope -> TCMT IO Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCMT IO Telescope
forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Telescope
getContextTelescope)
          [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"type  = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Type -> m Doc
prettyTCM Arg Type
b
          [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
60 (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
"type  = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Type -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Arg Type
b

          [AsBinding] -> TCMT IO () -> TCMT IO ()
forall a. [AsBinding] -> TCM a -> TCM a
bindAsPatterns [AsBinding]
asb (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do

            -- Check dot patterns
            (DotPattern -> TCMT IO ()) -> [DotPattern] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DotPattern -> TCMT IO ()
checkDotPattern [DotPattern]
dots
            (AbsurdPattern -> TCMT IO ()) -> [AbsurdPattern] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ AbsurdPattern -> TCMT IO ()
checkAbsurdPattern [AbsurdPattern]
absurds
            (AnnotationPattern -> TCMT IO ())
-> [AnnotationPattern] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ AnnotationPattern -> TCMT IO ()
checkAnnotationPattern [AnnotationPattern]
annps

          -- Issue2303: don't bind asb' for the continuation (return in lhsResult instead)
          LHSResult -> TCMT IO a
ret LHSResult
lhsResult

  LHSState a
st0 <- Telescope
-> [ProblemEq]
-> [NamedArg Pattern]
-> Type
-> (LHSState a -> TCMT IO a)
-> TCM (LHSState a)
forall a.
Telescope
-> [ProblemEq]
-> [NamedArg Pattern]
-> Type
-> (LHSState a -> TCM a)
-> TCM (LHSState a)
initLHSState Telescope
tel [ProblemEq]
eqs0 [NamedArg Pattern]
ps Type
a LHSState a -> TCMT IO a
finalChecks

  -- after we have introduced variables, we can add the patterns stripped by
  -- with-desugaring to the state.
  let withSub :: Substitution
withSub = Substitution -> Maybe Substitution -> Substitution
forall a. a -> Maybe a -> a
fromMaybe Substitution
forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe Substitution
withSub'
  [ProblemEq]
withEqs <- [ProblemEq] -> TCMT IO [ProblemEq]
updateProblemEqs ([ProblemEq] -> TCMT IO [ProblemEq])
-> [ProblemEq] -> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Substitution' (SubstArg [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg [ProblemEq])
withSub [ProblemEq]
strippedPats
  -- Jesper, 2017-05-13: re-check the stripped patterns here!
  TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext (LHSState a
st0 LHSState a -> Lens' Telescope (LHSState a) -> Telescope
forall o i. o -> Lens' i o -> i
^. (Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
Lens' Telescope (LHSState a)
lhsTel) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [ProblemEq] -> (ProblemEq -> TCMT IO ()) -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProblemEq]
withEqs ProblemEq -> TCMT IO ()
recheckStrippedWithPattern

  let st :: LHSState a
st = Lens' [ProblemEq] (LHSState a) -> LensMap [ProblemEq] (LHSState a)
forall i o. Lens' i o -> LensMap i o
over ((Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
lhsProblem ((Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a))
-> (([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a))
-> ([ProblemEq] -> f [ProblemEq])
-> LHSState a
-> f (LHSState a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs) ([ProblemEq] -> [ProblemEq] -> [ProblemEq]
forall a. [a] -> [a] -> [a]
++ [ProblemEq]
withEqs) LHSState a
st0

  -- doing the splits:
  (a
result, Blocked' Term ()
block) <- TCMT IO (a, Blocked' Term ()) -> TCMT IO (a, Blocked' Term ())
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
unsafeInTopContext (TCMT IO (a, Blocked' Term ()) -> TCMT IO (a, Blocked' Term ()))
-> TCMT IO (a, Blocked' Term ()) -> TCMT IO (a, Blocked' Term ())
forall a b. (a -> b) -> a -> b
$ WriterT (Blocked' Term ()) (TCMT IO) a
-> TCMT IO (a, Blocked' Term ())
forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT (WriterT (Blocked' Term ()) (TCMT IO) a
 -> TCMT IO (a, Blocked' Term ()))
-> WriterT (Blocked' Term ()) (TCMT IO) a
-> TCMT IO (a, Blocked' Term ())
forall a b. (a -> b) -> a -> b
$ (ReaderT Int (WriterT (Blocked' Term ()) (TCMT IO)) a
-> Int -> WriterT (Blocked' Term ()) (TCMT IO) a
forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` (Context -> Int
forall a. Sized a => a -> Int
size Context
cxt)) (ReaderT Int (WriterT (Blocked' Term ()) (TCMT IO)) a
 -> WriterT (Blocked' Term ()) (TCMT IO) a)
-> ReaderT Int (WriterT (Blocked' Term ()) (TCMT IO)) a
-> WriterT (Blocked' Term ()) (TCMT IO) a
forall a b. (a -> b) -> a -> b
$ Maybe QName
-> LHSState a
-> ReaderT Int (WriterT (Blocked' Term ()) (TCMT IO)) a
forall (tcm :: * -> *) a.
(MonadTCM tcm, PureTCM tcm, MonadWriter (Blocked' Term ()) tcm,
 MonadError TCErr tcm, MonadTrace tcm, MonadReader Int tcm) =>
Maybe QName -> LHSState a -> tcm a
checkLHS Maybe QName
f LHSState a
st
  a -> TCMT IO a
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return a
result

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

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

-- | Determine which splits should be tried.
splitStrategy :: [ProblemEq] -> [ProblemEq]
splitStrategy :: [ProblemEq] -> [ProblemEq]
splitStrategy = (ProblemEq -> Bool) -> [ProblemEq] -> [ProblemEq]
forall a. (a -> Bool) -> [a] -> [a]
filter ProblemEq -> Bool
shouldSplit
  where
    shouldSplit :: ProblemEq -> Bool
    shouldSplit :: ProblemEq -> Bool
shouldSplit problem :: ProblemEq
problem@(ProblemEq Pattern
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 :: Pattern
problemInPat = Pattern
p }
      A.AnnP PatInfo
_ Expr
_ Pattern
p -> ProblemEq -> Bool
shouldSplit (ProblemEq -> Bool) -> ProblemEq -> Bool
forall a b. (a -> b) -> a -> b
$ ProblemEq
problem { problemInPat :: Pattern
problemInPat = Pattern
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__


-- | The loop (tail-recursive): split at a variable in the problem until problem is solved
checkLHS
  :: forall tcm a. (MonadTCM tcm, PureTCM tcm, MonadWriter Blocked_ tcm, MonadError TCErr tcm, MonadTrace tcm, MonadReader Nat tcm)
  => Maybe QName      -- ^ The name of the definition we are checking.
  -> LHSState a       -- ^ The current state.
  -> tcm a
checkLHS :: forall (tcm :: * -> *) a.
(MonadTCM tcm, PureTCM tcm, MonadWriter (Blocked' Term ()) tcm,
 MonadError TCErr tcm, MonadTrace tcm, MonadReader Int tcm) =>
Maybe QName -> LHSState a -> tcm a
checkLHS Maybe QName
mf = (LHSState a -> tcm a) -> LHSState a -> tcm a
forall {tcm :: * -> *} {a} {a}.
MonadTCEnv tcm =>
(LHSState a -> tcm a) -> LHSState a -> tcm a
updateModality LHSState a -> tcm a
checkLHS_ where
    -- If the target type is irrelevant or in Prop,
    -- we need to check the lhs in irr. cxt. (see Issue 939).
 updateModality :: (LHSState a -> tcm a) -> LHSState a -> tcm a
updateModality LHSState a -> tcm a
cont st :: LHSState a
st@(LHSState Telescope
tel [NamedArg DeBruijnPattern]
ip Problem a
problem Arg Type
target [Maybe Int]
psplit Bool
_) = do
      let m :: Modality
m = Arg Type -> Modality
forall a. LensModality a => a -> Modality
getModality Arg Type
target
      Modality -> tcm a -> tcm a
forall (tcm :: * -> *) m a.
(MonadTCEnv tcm, LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext Modality
m (tcm a -> tcm a) -> tcm a -> tcm a
forall a b. (a -> b) -> a -> b
$ do
        LHSState a -> tcm a
cont (LHSState a -> tcm a) -> LHSState a -> tcm a
forall a b. (a -> b) -> a -> b
$ Lens' [Dom ([Char], Type)] (LHSState a)
-> LensMap [Dom ([Char], Type)] (LHSState a)
forall i o. Lens' i o -> LensMap i o
over ((Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
lhsTel ((Telescope -> f Telescope) -> LHSState a -> f (LHSState a))
-> (([Dom ([Char], Type)] -> f [Dom ([Char], Type)])
    -> Telescope -> f Telescope)
-> ([Dom ([Char], Type)] -> f [Dom ([Char], Type)])
-> LHSState a
-> f (LHSState a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Dom ([Char], Type)] -> f [Dom ([Char], Type)])
-> Telescope -> f Telescope
Lens' [Dom ([Char], Type)] Telescope
listTel)
                 ((Dom ([Char], Type) -> Dom ([Char], Type))
-> [Dom ([Char], Type)] -> [Dom ([Char], Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((Dom ([Char], Type) -> Dom ([Char], Type))
 -> [Dom ([Char], Type)] -> [Dom ([Char], Type)])
-> (Dom ([Char], Type) -> Dom ([Char], Type))
-> [Dom ([Char], Type)]
-> [Dom ([Char], Type)]
forall a b. (a -> b) -> a -> b
$ Modality -> Dom ([Char], Type) -> Dom ([Char], Type)
forall a. LensModality a => Modality -> a -> a
inverseApplyModalityButNotQuantity Modality
m) LHSState a
st
        -- Andreas, 2018-10-23, issue #3309
        -- the modalities in the clause telescope also need updating.

 checkLHS_ :: LHSState a -> tcm a
checkLHS_ st :: LHSState a
st@(LHSState Telescope
tel [NamedArg DeBruijnPattern]
ip Problem a
problem Arg Type
target [Maybe Int]
psplit Bool
ixsplit) = do
  [Char] -> Int -> TCMT IO Doc -> tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs" Int
40 (TCMT IO Doc -> tcm ()) -> TCMT IO Doc -> tcm ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"tel is" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
tel
  [Char] -> Int -> TCMT IO Doc -> tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs" Int
40 (TCMT IO Doc -> tcm ()) -> TCMT IO Doc -> tcm ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"ip is" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
ip
  [Char] -> Int -> TCMT IO Doc -> tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs" Int
40 (TCMT IO Doc -> tcm ()) -> TCMT IO Doc -> tcm ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target is" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
tel (Arg Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Type -> m Doc
prettyTCM Arg Type
target)
  if Problem a -> Bool
forall a. Problem a -> Bool
isSolvedProblem Problem a
problem then
    TCM a -> tcm a
forall a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM a -> tcm a) -> TCM a -> tcm a
forall a b. (a -> b) -> a -> b
$ (Problem a
problem Problem a
-> Lens' (LHSState a -> TCM a) (Problem a) -> LHSState a -> TCM a
forall o i. o -> Lens' i o -> i
^. ((LHSState a -> TCM a) -> f (LHSState a -> TCM a))
-> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
((LHSState a -> TCM a) -> f (LHSState a -> TCM a))
-> Problem a -> f (Problem a)
Lens' (LHSState a -> TCM a) (Problem a)
problemCont) LHSState a
st
  else do

    [Char] -> Int -> TCMT IO Doc -> tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
30 (TCMT IO Doc -> tcm ()) -> TCMT IO Doc -> 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) ]

    tcm Bool -> tcm () -> tcm ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optPatternMatching (PragmaOptions -> Bool) -> tcm PragmaOptions -> tcm Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (TCState -> PragmaOptions) -> tcm PragmaOptions
forall (m :: * -> *) a. ReadTCState m => (TCState -> a) -> m a
getsTC TCState -> PragmaOptions
forall a. LensPragmaOptions a => a -> PragmaOptions
getPragmaOptions) (tcm () -> tcm ()) -> tcm () -> tcm ()
forall a b. (a -> b) -> a -> b
$
      Bool -> tcm () -> tcm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Problem a -> Bool
forall a. Problem a -> Bool
problemAllVariables Problem a
problem) (tcm () -> tcm ()) -> tcm () -> tcm ()
forall a b. (a -> b) -> a -> b
$
        TypeError -> tcm ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> tcm ()) -> TypeError -> tcm ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$ [Char]
"Pattern matching is disabled"

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

    (ProblemEq
 -> tcm (Either [TCErr] (LHSState a))
 -> tcm (Either [TCErr] (LHSState a)))
-> tcm (Either [TCErr] (LHSState a))
-> [ProblemEq]
-> 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
-> tcm (Either [TCErr] (LHSState a))
-> tcm (Either [TCErr] (LHSState a))
trySplit tcm (Either [TCErr] (LHSState a))
trySplitRest [ProblemEq]
splitsToTry tcm (Either [TCErr] (LHSState a))
-> (Either [TCErr] (LHSState a) -> tcm a) -> tcm a
forall a b. tcm a -> (a -> tcm b) -> tcm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right LHSState a
st' -> Maybe QName -> LHSState a -> tcm a
forall (tcm :: * -> *) a.
(MonadTCM tcm, PureTCM tcm, MonadWriter (Blocked' Term ()) tcm,
 MonadError TCErr tcm, MonadTrace tcm, MonadReader Int tcm) =>
Maybe QName -> LHSState a -> tcm a
checkLHS Maybe QName
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 -> tcm a
forall a. TCErr -> tcm a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
      Left []      -> tcm a
forall a. HasCallStack => a
__IMPOSSIBLE__

  where

    trySplit :: ProblemEq
             -> tcm (Either [TCErr] (LHSState a))
             -> tcm (Either [TCErr] (LHSState a))
    trySplit :: ProblemEq
-> tcm (Either [TCErr] (LHSState a))
-> tcm (Either [TCErr] (LHSState a))
trySplit ProblemEq
eq tcm (Either [TCErr] (LHSState a))
tryNextSplit = ExceptT TCErr tcm (LHSState a) -> tcm (Either TCErr (LHSState a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ProblemEq -> ExceptT TCErr tcm (LHSState a)
splitArg ProblemEq
eq) tcm (Either TCErr (LHSState a))
-> (Either TCErr (LHSState a) -> tcm (Either [TCErr] (LHSState a)))
-> tcm (Either [TCErr] (LHSState a))
forall a b. tcm a -> (a -> tcm b) -> tcm b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Right LHSState a
st' -> Either [TCErr] (LHSState a) -> tcm (Either [TCErr] (LHSState a))
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TCErr] (LHSState a) -> tcm (Either [TCErr] (LHSState a)))
-> Either [TCErr] (LHSState a) -> 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 b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (TCErr
errTCErr -> [TCErr] -> [TCErr]
forall a. a -> [a] -> [a]
:) (Either [TCErr] (LHSState a) -> Either [TCErr] (LHSState a))
-> tcm (Either [TCErr] (LHSState a))
-> tcm (Either [TCErr] (LHSState a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> tcm (Either [TCErr] (LHSState a))
tryNextSplit

    -- If there are any remaining user patterns, try to split on them
    trySplitRest :: tcm (Either [TCErr] (LHSState a))
    trySplitRest :: tcm (Either [TCErr] (LHSState a))
trySplitRest = case Problem a
problem Problem a
-> Lens' [NamedArg Pattern] (Problem a) -> [NamedArg Pattern]
forall o i. o -> Lens' i o -> i
^. ([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
Lens' [NamedArg Pattern] (Problem a)
problemRestPats of
      []    -> Either [TCErr] (LHSState a) -> tcm (Either [TCErr] (LHSState a))
forall a. a -> tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either [TCErr] (LHSState a) -> tcm (Either [TCErr] (LHSState a)))
-> Either [TCErr] (LHSState a) -> 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 b c d. (b -> c) -> Either b d -> Either c d
forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left TCErr -> [TCErr]
forall el coll. Singleton el coll => el -> coll
singleton (Either TCErr (LHSState a) -> Either [TCErr] (LHSState a))
-> tcm (Either TCErr (LHSState a))
-> tcm (Either [TCErr] (LHSState a))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT TCErr tcm (LHSState a) -> tcm (Either TCErr (LHSState a))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (NamedArg Pattern -> ExceptT TCErr tcm (LHSState a)
splitRest NamedArg Pattern
p)

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

      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
30 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr 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
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.
      Int
i <- TCM Int -> ExceptT TCErr tcm Int
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Int -> ExceptT TCErr tcm Int)
-> TCM Int -> ExceptT TCErr tcm Int
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Int -> TCM Int
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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
$
             TypeError -> TCM Int
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> TCM Int) -> TypeError -> TCM Int
forall a b. (a -> b) -> a -> b
$ Term -> Type -> TypeError
SplitOnNonVariable Term
v Type
a

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

      Pattern
p <- TCMT IO Pattern -> ExceptT TCErr tcm Pattern
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Pattern -> ExceptT TCErr tcm Pattern)
-> TCMT IO Pattern -> ExceptT TCErr tcm Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> TCMT IO Pattern
forall (m :: * -> *).
(MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasBuiltins m) =>
Pattern -> m Pattern
expandLitPattern Pattern
p
      let splitOnPat :: Pattern -> ExceptT TCErr tcm (LHSState a)
splitOnPat = \case
            (A.LitP PatInfo
_ Literal
l)      -> Telescope
-> Dom Type
-> Abs Telescope
-> Literal
-> ExceptT TCErr tcm (LHSState a)
splitLit Telescope
delta1 Dom Type
dom Abs Telescope
adelta2 Literal
l
            p :: Pattern
p@A.RecP{}        -> Telescope
-> Dom Type
-> Abs Telescope
-> Pattern
-> Maybe AmbiguousQName
-> ExceptT TCErr tcm (LHSState a)
splitCon Telescope
delta1 Dom Type
dom Abs Telescope
adelta2 Pattern
p Maybe AmbiguousQName
forall a. Maybe a
Nothing
            p :: Pattern
p@(A.ConP ConPatInfo
_ AmbiguousQName
c [NamedArg Pattern]
ps) -> Telescope
-> Dom Type
-> Abs Telescope
-> Pattern
-> Maybe AmbiguousQName
-> ExceptT TCErr tcm (LHSState a)
splitCon Telescope
delta1 Dom Type
dom Abs Telescope
adelta2 Pattern
p (Maybe AmbiguousQName -> ExceptT TCErr tcm (LHSState a))
-> Maybe AmbiguousQName -> ExceptT TCErr tcm (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
_ [(Expr, Expr)]
ts) -> Telescope
-> Dom Type
-> Abs Telescope
-> [(Expr, Expr)]
-> ExceptT TCErr tcm (LHSState a)
splitPartial Telescope
delta1 Dom Type
dom Abs Telescope
adelta2 [(Expr, Expr)]
ts
            A.AsP PatInfo
_ BindName
_ Pattern
p       -> Pattern -> ExceptT TCErr tcm (LHSState a)
splitOnPat Pattern
p
            A.AnnP PatInfo
_ Expr
_ Pattern
p      -> Pattern -> ExceptT TCErr tcm (LHSState a)
splitOnPat Pattern
p

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


    splitRest :: NamedArg A.Pattern -> ExceptT TCErr tcm (LHSState a)
    splitRest :: NamedArg Pattern -> ExceptT TCErr tcm (LHSState a)
splitRest NamedArg Pattern
p = NamedArg Pattern
-> ExceptT TCErr tcm (LHSState a) -> ExceptT TCErr tcm (LHSState a)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Pattern
p (ExceptT TCErr tcm (LHSState a) -> ExceptT TCErr tcm (LHSState a))
-> ExceptT TCErr tcm (LHSState a) -> ExceptT TCErr tcm (LHSState a)
forall a b. (a -> b) -> a -> b
$ do
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr 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
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
<+> Arg Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Type -> m Doc
prettyTCM Arg Type
target
        ]
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
80 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr 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
sep
        [ Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"projection pattern (raw) = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ NamedArg Pattern -> [Char]
forall a. Show a => a -> [Char]
show NamedArg Pattern
p
        ]

      -- @p@ should be a projection pattern projection from @target@
      (ProjOrigin
orig, AmbiguousQName
ambProjName) <- Maybe (ProjOrigin, AmbiguousQName)
-> ((ProjOrigin, AmbiguousQName)
    -> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName))
-> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
-> ExceptT TCErr tcm (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 tcm (ProjOrigin, AmbiguousQName)
forall a. a -> ExceptT TCErr tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
 -> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName))
-> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
-> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
forall a b. (a -> b) -> a -> b
$ Telescope
-> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
-> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
tel (ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
 -> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName))
-> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
-> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
forall a b. (a -> b) -> a -> b
$ do
        Maybe Blocker
block <- Arg Type -> ExceptT TCErr tcm (Maybe Blocker)
forall t (m :: * -> *).
(Reduce t, IsMeta t, MonadReduce m) =>
t -> m (Maybe Blocker)
isBlocked Arg Type
target
        TypeError -> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName))
-> TypeError -> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> NamedArg Pattern -> Type -> TypeError
CannotEliminateWithPattern Maybe Blocker
block NamedArg Pattern
p (Arg Type -> Type
forall e. Arg e -> e
unArg Arg Type
target)

      (QName
projName, Bool
comatchingAllowed, QName
recName, Arg Type
projType, ArgInfo
ai) <- TCM (QName, Bool, QName, Arg Type, ArgInfo)
-> ExceptT TCErr tcm (QName, Bool, QName, Arg Type, ArgInfo)
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors (TCM (QName, Bool, QName, Arg Type, ArgInfo)
 -> ExceptT TCErr tcm (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
-> ExceptT TCErr tcm (QName, Bool, QName, Arg Type, ArgInfo)
forall a b. (a -> b) -> a -> b
$ 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 :: Maybe Hiding
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
        Telescope
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
tel (TCM (QName, Bool, QName, Arg Type, ArgInfo)
 -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a b. (a -> b) -> a -> b
$ Maybe Hiding
-> AmbiguousQName
-> Arg Type
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
disambiguateProjection Maybe Hiding
h AmbiguousQName
ambProjName Arg Type
target

      Bool -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
comatchingAllowed (ExceptT TCErr tcm () -> ExceptT TCErr tcm ())
-> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ do
        TypeError -> ExceptT TCErr tcm ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr tcm ())
-> (Doc -> TypeError) -> Doc -> ExceptT TCErr tcm ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> ExceptT TCErr tcm ())
-> ExceptT TCErr tcm Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
          TCMT IO Doc -> ExceptT TCErr tcm Doc
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Doc -> ExceptT TCErr tcm Doc)
-> TCMT IO Doc -> ExceptT TCErr tcm Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Copattern matching is disabled for record" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
recName

      -- Compute the new rest type by applying the projection type to 'self'.
      -- Note: we cannot be in a let binding.
      QName
f <- Maybe QName
-> (QName -> ExceptT TCErr tcm QName)
-> ExceptT TCErr tcm QName
-> ExceptT TCErr tcm QName
forall a b. Maybe a -> (a -> b) -> b -> b
ifJust Maybe QName
mf QName -> ExceptT TCErr tcm QName
forall a. a -> ExceptT TCErr tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return (ExceptT TCErr tcm QName -> ExceptT TCErr tcm QName)
-> ExceptT TCErr tcm QName -> ExceptT TCErr tcm QName
forall a b. (a -> b) -> a -> b
$ TypeError -> ExceptT TCErr tcm QName
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr tcm QName)
-> TypeError -> ExceptT TCErr tcm QName
forall a b. (a -> b) -> a -> b
$
             [Char] -> TypeError
GenericError [Char]
"Cannot use copatterns in a let binding"
      let self :: Term
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
      Arg Type
target' <- (Type -> ExceptT TCErr tcm Type)
-> Arg Type -> ExceptT TCErr tcm (Arg Type)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Arg a -> f (Arg b)
traverse (Type -> Term -> ExceptT TCErr tcm Type
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
forall (m :: * -> *).
(MonadReduce m, HasBuiltins m) =>
Type -> Term -> m Type
`piApplyM` Term
self) Arg Type
projType

      -- Compute the new state
      let projP :: NamedArg DeBruijnPattern
projP    = Bool
-> (NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern)
-> NamedArg DeBruijnPattern
-> NamedArg DeBruijnPattern
forall a. Bool -> (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]
ip [NamedArg DeBruijnPattern]
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern
projP]
          -- drop the projection pattern (already splitted)
          problem' :: Problem a
problem' = Lens' [NamedArg Pattern] (Problem a)
-> LensMap [NamedArg Pattern] (Problem a)
forall i o. Lens' i o -> LensMap i o
over ([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([NamedArg Pattern] -> f [NamedArg Pattern])
-> Problem a -> f (Problem a)
Lens' [NamedArg Pattern] (Problem a)
problemRestPats [NamedArg Pattern] -> [NamedArg Pattern]
forall a. HasCallStack => [a] -> [a]
tail Problem a
problem
      TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a)
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a))
-> TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a)
forall a b. (a -> b) -> a -> b
$ LHSState a -> TCM (LHSState a)
forall a. LHSState a -> TCM (LHSState a)
updateLHSState (Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
LHSState Telescope
tel [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' [Maybe Int]
psplit Bool
ixsplit)


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

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

      Bool -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Dom Type -> Bool
forall t e. Dom' t e -> Bool
domIsFinite Dom Type
dom) (ExceptT TCErr tcm () -> ExceptT TCErr tcm ())
-> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ TCMT IO () -> ExceptT TCErr tcm ()
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> ExceptT TCErr tcm ())
-> TCMT IO () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1 (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> TCMT IO ())
-> (Doc -> TypeError) -> Doc -> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat [ TCMT IO Doc
"Splitting on partial elements is only allowed at the type Partial, but the domain here is" , 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
$ Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM (Type -> TCMT IO Doc) -> Type -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
dom ]

      Type
tInterval <- TCMT IO Type -> ExceptT TCErr tcm Type
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Type -> ExceptT TCErr tcm Type)
-> TCMT IO Type -> ExceptT TCErr tcm 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

      [Maybe Name]
names <- TCM [Maybe Name] -> ExceptT TCErr tcm [Maybe Name]
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM [Maybe Name] -> ExceptT TCErr tcm [Maybe Name])
-> TCM [Maybe Name] -> ExceptT TCErr tcm [Maybe Name]
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM [Maybe Name] -> TCM [Maybe Name]
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
tel (TCM [Maybe Name] -> TCM [Maybe Name])
-> TCM [Maybe Name] -> TCM [Maybe Name]
forall a b. (a -> b) -> a -> b
$ do
        LeftoverPatterns{patternVariables :: LeftoverPatterns -> IntMap [(Name, PatVarPosition)]
patternVariables = IntMap [(Name, PatVarPosition)]
vars} <- [ProblemEq] -> TCMT IO LeftoverPatterns
forall (m :: * -> *).
PureTCM 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 -> Lens' [ProblemEq] (Problem a) -> [ProblemEq]
forall o i. o -> Lens' i o -> i
^. ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs
        [Maybe Name] -> TCM [Maybe Name]
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Maybe Name] -> TCM [Maybe Name])
-> [Maybe Name] -> TCM [Maybe Name]
forall a b. (a -> b) -> a -> b
$ Int -> [Maybe Name] -> [Maybe Name]
forall a. Int -> [a] -> [a]
take (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
delta1) ([Maybe Name] -> [Maybe Name]) -> [Maybe Name] -> [Maybe Name]
forall a b. (a -> b) -> a -> b
$ ([Maybe Name], [AsBinding]) -> [Maybe Name]
forall a b. (a, b) -> a
fst (([Maybe Name], [AsBinding]) -> [Maybe Name])
-> ([Maybe Name], [AsBinding]) -> [Maybe Name]
forall a b. (a -> b) -> a -> b
$ Telescope
-> IntMap [(Name, PatVarPosition)] -> ([Maybe Name], [AsBinding])
getUserVariableNames Telescope
tel IntMap [(Name, PatVarPosition)]
vars

      -- Problem: The context does not match the checkpoints in checkLHS,
      --          however we still need a proper checkpoint substitution
      --          for checkExpr below.
      --
      -- Solution: partial splits are not allowed when there are
      --           constructor patterns (checked in checkDef), so
      --           newContext is an extension of the definition
      --           context.
      --
      -- i.e.: Given
      --
      --             Γ = context where def is checked, also last checkpoint.
      --
      --       Then
      --
      --             newContext = Γ Ξ
      --             cpSub = raiseS |Ξ|
      --
      Int
lhsCxtSize <- ExceptT TCErr tcm Int
forall r (m :: * -> *). MonadReader r m => m r
ask -- size of the context before checkLHS call.
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"lhsCxtSize =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Int -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Int -> m Doc
prettyTCM Int
lhsCxtSize

      Context
newContext <- TCM Context -> ExceptT TCErr tcm Context
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Context -> ExceptT TCErr tcm Context)
-> TCM Context -> ExceptT TCErr tcm Context
forall a b. (a -> b) -> a -> b
$ [Maybe Name] -> Telescope -> TCM Context
computeLHSContext [Maybe Name]
names Telescope
delta1
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"newContext =" 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
newContext

      let cpSub :: Substitution
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

      (Telescope
gamma,Substitution
sigma) <- TCM (Telescope, Substitution)
-> ExceptT TCErr tcm (Telescope, Substitution)
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (Telescope, Substitution)
 -> ExceptT TCErr tcm (Telescope, Substitution))
-> TCM (Telescope, Substitution)
-> ExceptT TCErr tcm (Telescope, Substitution)
forall a b. (a -> b) -> a -> b
$ Substitution
-> (Context -> Context)
-> TCM (Telescope, Substitution)
-> TCM (Telescope, Substitution)
forall a.
Substitution -> (Context -> Context) -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a.
MonadAddContext m =>
Substitution -> (Context -> Context) -> m a -> m a
updateContext Substitution
cpSub (Context -> Context -> Context
forall a b. a -> b -> a
const Context
newContext) (TCM (Telescope, Substitution) -> TCM (Telescope, Substitution))
-> TCM (Telescope, Substitution) -> TCM (Telescope, Substitution)
forall a b. (a -> b) -> a -> b
$ do
         [Term]
ts <- [(Expr, Expr)] -> ((Expr, Expr) -> TCMT IO Term) -> TCMT IO [Term]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Expr, Expr)]
ts (((Expr, Expr) -> TCMT IO Term) -> TCMT IO [Term])
-> ((Expr, Expr) -> TCMT IO Term) -> TCMT IO [Term]
forall a b. (a -> b) -> a -> b
$ \ (Expr
t,Expr
u) -> do
                 [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"currentCxt =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Context -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Context -> m Doc
prettyTCM (Context -> TCMT IO Doc) -> TCM Context -> TCMT IO Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCM Context
forall (m :: * -> *). MonadTCEnv m => m Context
getContext)
                 [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"t, u (Expr) =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Expr, Expr) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => (Expr, Expr) -> m Doc
prettyTCM (Expr
t,Expr
u)
                 Term
t <- Expr -> Type -> TCMT IO Term
checkExpr Expr
t Type
tInterval
                 Term
u <- Expr -> Type -> TCMT IO Term
checkExpr Expr
u Type
tInterval
                 [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"t, u        =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Term, Term) -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Term
t, Term
u)
                 IntervalView
u <- Term -> TCMT IO IntervalView
forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView (Term -> TCMT IO IntervalView)
-> TCMT IO Term -> TCMT IO IntervalView
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
u
                 case IntervalView
u of
                   IntervalView
IZero -> TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg TCMT IO Term -> TCMT IO Term -> TCMT IO Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
t
                   IntervalView
IOne  -> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
                   IntervalView
_     -> TypeError -> TCMT IO Term
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO Term) -> TypeError -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$ [Char]
"Only 0 or 1 allowed on the rhs of face"
         -- Example: ts = (i=0) (j=1) will result in phi = ¬ i & j
         Term
phi <- case [Term]
ts of
                   [] -> do
                     Term
a <- Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> Type -> Term
forall a b. (a -> b) -> a -> b
$ Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
dom)
                     -- builtinIsOne is defined, since this is a precondition for having Partial
                     QName
isone <- QName -> Maybe QName -> QName
forall a. a -> Maybe a -> a
fromMaybe QName
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe QName -> QName) -> TCMT IO (Maybe QName) -> TCMT IO QName
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>  -- newline because of CPP
                       [Char] -> TCMT IO (Maybe QName)
forall (m :: * -> *). HasBuiltins m => [Char] -> m (Maybe QName)
getBuiltinName' [Char]
builtinIsOne
                     case Term
a of
                       Def QName
q [Apply Arg Term
phi] | QName
q QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
isone -> Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
phi)
                       Term
_           -> TypeError -> TCMT IO Term
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO Term)
-> (Doc -> TypeError) -> Doc -> TCMT IO Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCMT IO Term) -> TCMT IO Doc -> TCMT IO Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                         Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
a TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
" is not IsOne."

                   [Term]
_  -> (TCMT IO Term -> TCMT IO Term -> TCMT IO Term)
-> TCMT IO Term -> [TCMT IO Term] -> TCMT IO Term
forall b a. (b -> a -> b) -> b -> [a] -> b
forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
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) TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne ((Term -> TCMT IO Term) -> [Term] -> [TCMT IO Term]
forall a b. (a -> b) -> [a] -> [b]
map Term -> TCMT IO Term
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure [Term]
ts)
         [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"phi           =" 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
phi
         [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"phi           =" 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
phi
         Term
phi <- Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
phi
         [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"phi (reduced) =" 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
phi
         [(Telescope, Substitution)]
refined <- Term
-> (IntMap Bool
    -> Blocker -> Term -> TCM (Telescope, Substitution))
-> (IntMap Bool -> Substitution -> TCM (Telescope, Substitution))
-> TCMT IO [(Telescope, Substitution)]
forall (m :: * -> *) a.
MonadConversion m =>
Term
-> (IntMap Bool -> Blocker -> Term -> m a)
-> (IntMap Bool -> Substitution -> m a)
-> m [a]
forallFaceMaps Term
phi (\ IntMap Bool
bs Blocker
m Term
t -> TypeError -> TCM (Telescope, Substitution)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM (Telescope, Substitution))
-> TypeError -> TCM (Telescope, Substitution)
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$ [Char]
"face blocked on meta")
                            (\IntMap Bool
_ Substitution
sigma -> (,Substitution
sigma) (Telescope -> (Telescope, Substitution))
-> TCMT IO Telescope -> TCM (Telescope, Substitution)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO Telescope
forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Telescope
getContextTelescope)
         case [(Telescope, Substitution)]
refined of
           [(Telescope
gamma,Substitution
sigma)] -> (Telescope, Substitution) -> TCM (Telescope, Substitution)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope
gamma,Substitution
sigma)
           []              -> TypeError -> TCM (Telescope, Substitution)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM (Telescope, Substitution))
-> TypeError -> TCM (Telescope, Substitution)
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$ [Char]
"The face constraint is unsatisfiable."
           [(Telescope, Substitution)]
_               -> TypeError -> TCM (Telescope, Substitution)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM (Telescope, Substitution))
-> TypeError -> TCM (Telescope, Substitution)
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot have disjunctions in a face constraint."
      Term
itisone <- TCMT IO Term -> ExceptT TCErr tcm Term
forall a. TCM a -> ExceptT TCErr 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
      -- substitute the literal in p1 and dpi
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.faces" Int
60 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Substitution -> [Char]
forall a. Show a => a -> [Char]
show Substitution
sigma

      let oix :: Int
oix = Abs Telescope -> Int
forall a. Sized a => a -> Int
size Abs Telescope
adelta2 -- de brujin index of IsOne
          o_n :: Int
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' :: Telescope
delta2' = Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs Telescope
adelta2 Term
SubstArg Telescope
itisone
          delta2 :: Telescope
delta2 = Substitution' (SubstArg Telescope) -> Telescope -> Telescope
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
Substitution' (SubstArg Telescope)
sigma Telescope
delta2'
          mkConP :: Term -> DeBruijnPattern
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 :: Maybe (Arg Type)
conPType = Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just (ArgInfo -> Type -> Arg Type
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo Type
tInterval)
                                              , conPFallThrough :: Bool
conPFallThrough = Bool
True })
                          []
          mkConP (Var Int
i []) = PatternInfo -> DBPatVar -> DeBruijnPattern
forall x. PatternInfo -> x -> Pattern' x
VarP PatternInfo
defaultPatternInfo ([Char] -> Int -> DBPatVar
DBPatVar [Char]
"x" Int
i)
          mkConP Term
_          = DeBruijnPattern
forall a. HasCallStack => a
__IMPOSSIBLE__
          rho0 :: PatternSubstitution
rho0 = (Term -> DeBruijnPattern) -> Substitution -> PatternSubstitution
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 :: PatternSubstitution
rho    = Int -> PatternSubstitution -> PatternSubstitution
forall a. Int -> Substitution' a -> Substitution' a
liftS (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
delta2) (PatternSubstitution -> PatternSubstitution)
-> PatternSubstitution -> PatternSubstitution
forall a b. (a -> b) -> a -> b
$ DeBruijnPattern -> PatternSubstitution -> PatternSubstitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS (PatternInfo -> Term -> DeBruijnPattern
forall x. PatternInfo -> Term -> Pattern' x
DotP PatternInfo
defaultPatternInfo Term
itisone) PatternSubstitution
rho0

          delta' :: Telescope
delta'   = Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
abstract Telescope
gamma Telescope
delta2
          eqs' :: [ProblemEq]
eqs'     = PatternSubstitution -> [ProblemEq] -> [ProblemEq]
forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a -> Lens' [ProblemEq] (Problem a) -> [ProblemEq]
forall o i. o -> Lens' i o -> i
^. ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
Lens' [ProblemEq] (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 PatternSubstitution
Substitution' (SubstArg [NamedArg DeBruijnPattern])
rho [NamedArg DeBruijnPattern]
ip
          target' :: Arg Type
target'  = PatternSubstitution -> Arg Type -> Arg Type
forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho Arg Type
target

      -- Compute the new state
      let problem' :: Problem a
problem' = Lens' [ProblemEq] (Problem a) -> LensSet [ProblemEq] (Problem a)
forall i o. Lens' i o -> LensSet i o
set ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs [ProblemEq]
eqs' Problem a
problem
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
60 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text (Problem a -> [Char]
forall a. Show a => a -> [Char]
show Problem a
problem')
      TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a)
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a))
-> TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a)
forall a b. (a -> b) -> a -> b
$ LHSState a -> TCM (LHSState a)
forall a. LHSState a -> TCM (LHSState a)
updateLHSState (Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
LHSState Telescope
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' ([Maybe Int]
psplit [Maybe Int] -> [Maybe Int] -> [Maybe Int]
forall a. [a] -> [a] -> [a]
++ [Int -> Maybe Int
forall a. a -> Maybe a
Just Int
o_n]) Bool
ixsplit)


    splitLit :: Telescope      -- The types of arguments before the one we split on
             -> Dom Type       -- The type of the literal we split on
             -> Abs Telescope  -- The types of arguments after the one we split on
             -> Literal        -- The literal written by the user
             -> ExceptT TCErr tcm (LHSState a)
    splitLit :: Telescope
-> Dom Type
-> Abs Telescope
-> Literal
-> ExceptT TCErr tcm (LHSState a)
splitLit Telescope
delta1 dom :: Dom Type
dom@Dom{domInfo :: forall t e. Dom' t e -> ArgInfo
domInfo = ArgInfo
info, unDom :: forall t e. Dom' t e -> e
unDom = Type
a} Abs Telescope
adelta2 Literal
lit = do
      let delta2 :: Telescope
delta2 = Abs Telescope -> SubstArg Telescope -> Telescope
forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs Telescope
adelta2 (Literal -> Term
Lit Literal
lit)
          delta' :: Telescope
delta' = Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
abstract Telescope
delta1 Telescope
delta2
          rho :: PatternSubstitution
rho    = Int -> DeBruijnPattern -> PatternSubstitution
forall a. DeBruijn a => Int -> a -> Substitution' a
singletonS (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
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'     = PatternSubstitution -> [ProblemEq] -> [ProblemEq]
forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a -> Lens' [ProblemEq] (Problem a) -> [ProblemEq]
forall o i. o -> Lens' i o -> i
^. ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
Lens' [ProblemEq] (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 PatternSubstitution
Substitution' (SubstArg [NamedArg DeBruijnPattern])
rho [NamedArg DeBruijnPattern]
ip
          target' :: Arg Type
target'  = PatternSubstitution -> Arg Type -> Arg Type
forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho Arg Type
target

      -- Andreas, 2010-09-07 cannot split on irrelevant args
      Bool -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ArgInfo -> Bool
forall a. LensRelevance a => a -> Bool
usableRelevance ArgInfo
info) (ExceptT TCErr tcm () -> ExceptT TCErr tcm ())
-> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$
        Telescope -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1 (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 :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr tcm ())
-> TypeError -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Dom Type -> TypeError
SplitOnIrrelevant Dom Type
dom

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

      ExceptT TCErr tcm Bool
-> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (ArgInfo -> ExceptT TCErr tcm Bool
forall (m :: * -> *) a.
(HasOptions m, LensCohesion a) =>
a -> m Bool
splittableCohesion ArgInfo
info) (ExceptT TCErr tcm () -> ExceptT TCErr tcm ())
-> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$
        Telescope -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1 (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 :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr tcm ())
-> TypeError -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Dom Type -> TypeError
SplitOnUnusableCohesion Dom Type
dom

      -- check that a is indeed the type of lit (otherwise fail softly)
      -- if not, fail softly since it could be instantiated by a later split.
      TCMT IO () -> ExceptT TCErr tcm ()
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors (TCMT IO () -> ExceptT TCErr tcm ())
-> TCMT IO () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Type -> Type -> TCMT IO ()
forall (m :: * -> *). MonadConversion m => Type -> Type -> m ()
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' = Lens' [ProblemEq] (Problem a) -> LensSet [ProblemEq] (Problem a)
forall i o. Lens' i o -> LensSet i o
set ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs [ProblemEq]
eqs' Problem a
problem
      TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a)
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a))
-> TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a)
forall a b. (a -> b) -> a -> b
$ LHSState a -> TCM (LHSState a)
forall a. LHSState a -> TCM (LHSState a)
updateLHSState (Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
LHSState Telescope
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' [Maybe Int]
psplit Bool
ixsplit)


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

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

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

      -- We cannot split on (shape-)irrelevant arguments.
      [Char] -> Int -> [Char] -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.lhs.split" Int
30 ([Char] -> ExceptT TCErr tcm ()) -> [Char] -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ [Char]
"split ConP: relevance is " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Relevance -> [Char]
forall a. Show a => a -> [Char]
show (ArgInfo -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance ArgInfo
info)
      Bool -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ArgInfo -> Bool
forall a. LensRelevance a => a -> Bool
usableRelevance ArgInfo
info) (ExceptT TCErr tcm () -> ExceptT TCErr tcm ())
-> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1 (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 :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr tcm ())
-> TypeError -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Dom Type -> TypeError
SplitOnIrrelevant Dom Type
dom

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

      ExceptT TCErr tcm Bool
-> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (ArgInfo -> ExceptT TCErr tcm Bool
forall (m :: * -> *) a.
(HasOptions m, LensCohesion a) =>
a -> m Bool
splittableCohesion ArgInfo
info) (ExceptT TCErr tcm () -> ExceptT TCErr tcm ())
-> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$
        Telescope -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1 (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 :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr tcm ())
-> TypeError -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Dom Type -> TypeError
SplitOnUnusableCohesion Dom Type
dom

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

      -- We should be at a data/record type
      (DataOrRecord
dr, QName
d, Args
pars, Args
ixs) <- Telescope
-> ExceptT TCErr tcm (DataOrRecord, QName, Args, Args)
-> ExceptT TCErr tcm (DataOrRecord, QName, Args, Args)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1 (ExceptT TCErr tcm (DataOrRecord, QName, Args, Args)
 -> ExceptT TCErr tcm (DataOrRecord, QName, Args, Args))
-> ExceptT TCErr tcm (DataOrRecord, QName, Args, Args)
-> ExceptT TCErr tcm (DataOrRecord, QName, Args, Args)
forall a b. (a -> b) -> a -> b
$ Type -> ExceptT TCErr tcm (DataOrRecord, QName, Args, Args)
forall (m :: * -> *).
(MonadTCM m, PureTCM m) =>
Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
isDataOrRecordType Type
a
      let isRec :: Bool
isRec = case DataOrRecord
dr of
            IsData{}   -> Bool
False
            IsRecord{} -> Bool
True

      QName -> DataOrRecord -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadTCError m =>
QName -> DataOrRecord -> m ()
checkMatchingAllowed QName
d DataOrRecord
dr  -- No splitting on coinductive constructors.
      Telescope -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1 (ExceptT TCErr tcm () -> ExceptT TCErr tcm ())
-> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ DataOrRecord
-> Type -> Telescope -> Maybe (Arg Type) -> ExceptT TCErr tcm ()
forall (m :: * -> *) a ty.
(MonadTCM m, PureTCM m, MonadError TCErr m, LensSort a,
 PrettyTCM a, LensSort ty, PrettyTCM ty) =>
DataOrRecord -> a -> Telescope -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr Type
a Telescope
delta2 (Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just Arg Type
target)

      -- Jesper, 2019-09-13: if the data type we split on is a strict
      -- set, we locally enable --with-K during unification.
      TCMT IO UnificationResult -> TCMT IO UnificationResult
withKIfStrict <- Sort' Term -> ExceptT TCErr tcm (Sort' Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Type -> Sort' Term
forall a. LensSort a => a -> Sort' Term
getSort Type
a) ExceptT TCErr tcm (Sort' Term)
-> (Sort' Term
    -> ExceptT
         TCErr tcm (TCMT IO UnificationResult -> TCMT IO UnificationResult))
-> ExceptT
     TCErr tcm (TCMT IO UnificationResult -> TCMT IO UnificationResult)
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
        SSet{} -> (TCMT IO UnificationResult -> TCMT IO UnificationResult)
-> ExceptT
     TCErr tcm (TCMT IO UnificationResult -> TCMT IO UnificationResult)
forall a. a -> ExceptT TCErr tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return ((TCMT IO UnificationResult -> TCMT IO UnificationResult)
 -> ExceptT
      TCErr tcm (TCMT IO UnificationResult -> TCMT IO UnificationResult))
-> (TCMT IO UnificationResult -> TCMT IO UnificationResult)
-> ExceptT
     TCErr tcm (TCMT IO UnificationResult -> TCMT IO UnificationResult)
forall a b. (a -> b) -> a -> b
$ Lens' Bool TCEnv
-> (Bool -> Bool)
-> TCMT IO UnificationResult
-> TCMT IO UnificationResult
forall (m :: * -> *) a b.
MonadTCEnv m =>
Lens' a TCEnv -> (a -> a) -> m b -> m b
locallyTC (Bool -> f Bool) -> TCEnv -> f TCEnv
Lens' Bool TCEnv
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
        Sort' Term
_      -> (TCMT IO UnificationResult -> TCMT IO UnificationResult)
-> ExceptT
     TCErr tcm (TCMT IO UnificationResult -> TCMT IO UnificationResult)
forall a. a -> ExceptT TCErr tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return TCMT IO UnificationResult -> TCMT IO UnificationResult
forall a. a -> a
id

      -- The constructor should construct an element of this datatype
      (ConHead
c :: ConHead, Type
b :: Type) <- TCM (ConHead, Type) -> ExceptT TCErr tcm (ConHead, Type)
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (ConHead, Type) -> ExceptT TCErr tcm (ConHead, Type))
-> TCM (ConHead, Type) -> ExceptT TCErr tcm (ConHead, Type)
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM (ConHead, Type) -> TCM (ConHead, Type)
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1 (TCM (ConHead, Type) -> TCM (ConHead, Type))
-> TCM (ConHead, Type) -> TCM (ConHead, Type)
forall a b. (a -> b) -> a -> b
$ case Maybe AmbiguousQName
ambC of
        Just AmbiguousQName
ambC -> AmbiguousQName -> QName -> Args -> TCM (ConHead, Type)
disambiguateConstructor AmbiguousQName
ambC QName
d Args
pars
        Maybe AmbiguousQName
Nothing   -> QName -> Args -> Type -> TCM (ConHead, Type)
getRecordConstructor QName
d Args
pars Type
a

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

      -- The type of the constructor will end in an application of the datatype
      (TelV Telescope
gamma (El Sort' Term
_ Term
ctarget), Boundary
boundary) <- TCM (TelV Type, Boundary)
-> ExceptT TCErr tcm (TelV Type, Boundary)
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (TelV Type, Boundary)
 -> ExceptT TCErr tcm (TelV Type, Boundary))
-> TCM (TelV Type, Boundary)
-> ExceptT TCErr tcm (TelV Type, Boundary)
forall a b. (a -> b) -> a -> b
$ Type -> TCM (TelV Type, Boundary)
forall (m :: * -> *). PureTCM m => Type -> m (TelV Type, Boundary)
telViewPathBoundaryP Type
b
      let Def QName
d' Elims
es' = Term
ctarget
          cixs :: Args
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
$ Args -> Maybe Args -> Args
forall a. a -> Maybe a -> a
fromMaybe Args
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Args -> Args) -> Maybe Args -> Args
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es'

      -- Δ₁Γ ⊢ boundary
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.con" Int
50 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"  boundary = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Boundary -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Boundary -> m Doc
prettyTCM Boundary
boundary

      Bool -> ExceptT TCErr tcm () -> ExceptT TCErr tcm ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QName
d QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
d') {-'-} ExceptT TCErr tcm ()
forall a. HasCallStack => a
__IMPOSSIBLE__

      -- Get names for the constructor arguments from the user patterns
      Telescope
gamma <- TCMT IO Telescope -> ExceptT TCErr tcm Telescope
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Telescope -> ExceptT TCErr tcm Telescope)
-> TCMT IO Telescope -> ExceptT TCErr tcm Telescope
forall a b. (a -> b) -> a -> b
$ case Pattern
focusPat of
        A.ConP ConPatInfo
_ AmbiguousQName
_ [NamedArg Pattern]
ps -> do
          [NamedArg Pattern]
ps <- ExpandHidden
-> [NamedArg Pattern] -> Telescope -> TCMT IO [NamedArg Pattern]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
 MonadTrace m) =>
ExpandHidden
-> [NamedArg Pattern] -> Telescope -> m [NamedArg Pattern]
insertImplicitPatterns ExpandHidden
ExpandLast [NamedArg Pattern]
ps Telescope
gamma
          Telescope -> TCMT IO Telescope
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope -> TCMT IO Telescope) -> Telescope -> TCMT IO Telescope
forall a b. (a -> b) -> a -> b
$ [NamedArg Pattern] -> Telescope -> Telescope
useNamesFromPattern [NamedArg Pattern]
ps Telescope
gamma
        A.RecP PatInfo
_ [FieldAssignment' Pattern]
fs -> do
          [Arg Name]
axs <- (Dom' Term Name -> Arg Name) -> [Dom' Term Name] -> [Arg Name]
forall a b. (a -> b) -> [a] -> [b]
map Dom' Term Name -> Arg Name
forall t a. Dom' t a -> Arg a
argFromDom ([Dom' Term Name] -> [Arg Name])
-> (Definition -> [Dom' Term Name]) -> Definition -> [Arg Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defn -> [Dom' Term Name]
recordFieldNames (Defn -> [Dom' Term Name])
-> (Definition -> Defn) -> Definition -> [Dom' Term Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Defn
theDef (Definition -> [Arg Name])
-> TCMT IO Definition -> TCMT IO [Arg Name]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
          [NamedArg Pattern]
ps <- QName
-> (Name -> Pattern)
-> [FieldAssignment' Pattern]
-> [Arg Name]
-> TCMT IO [NamedArg Pattern]
forall a.
HasRange a =>
QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFieldsFail 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
patNoRange) [FieldAssignment' Pattern]
fs [Arg Name]
axs
          [NamedArg Pattern]
ps <- ExpandHidden
-> [NamedArg Pattern] -> Telescope -> TCMT IO [NamedArg Pattern]
forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
 MonadTrace m) =>
ExpandHidden
-> [NamedArg Pattern] -> Telescope -> m [NamedArg Pattern]
insertImplicitPatterns ExpandHidden
ExpandLast [NamedArg Pattern]
ps Telescope
gamma
          Telescope -> TCMT IO Telescope
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope -> TCMT IO Telescope) -> Telescope -> TCMT IO Telescope
forall a b. (a -> b) -> a -> b
$ [NamedArg Pattern] -> Telescope -> Telescope
useNamesFromPattern [NamedArg Pattern]
ps Telescope
gamma
        Pattern
_ -> TCMT IO Telescope
forall a. HasCallStack => a
__IMPOSSIBLE__

      -- Andreas 2010-09-07  propagate relevance info to new vars
      -- Andreas 2018-10-17  propagate modality
      let updMod :: Modality -> Modality
updMod = Modality -> Modality -> Modality
composeModality (ArgInfo -> Modality
forall a. LensModality a => a -> Modality
getModality ArgInfo
info)
      Telescope
gamma <- Telescope -> ExceptT TCErr tcm Telescope
forall a. a -> ExceptT TCErr tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope -> ExceptT TCErr tcm Telescope)
-> Telescope -> ExceptT TCErr tcm Telescope
forall a b. (a -> b) -> a -> b
$ (Modality -> Modality) -> Dom Type -> Dom Type
forall a. LensModality a => (Modality -> Modality) -> a -> a
mapModality Modality -> Modality
updMod (Dom Type -> Dom Type) -> Telescope -> Telescope
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope
gamma

      -- Get the type of the datatype.
      Type
da <- (Type -> Args -> Type
`piApply` Args
pars) (Type -> Type) -> (Definition -> Type) -> Definition -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType (Definition -> Type)
-> ExceptT TCErr tcm Definition -> ExceptT TCErr tcm Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ExceptT TCErr tcm Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
30 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"  da = " 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
da

      [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
15 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"preparing to unify"
            , 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
"c      =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ConHead -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ConHead -> m Doc
prettyTCM ConHead
c 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 -> 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
b
              , TCMT IO Doc
"d      =" 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 (QName -> Elims -> Term
Def QName
d ((Arg Term -> Elim' Term) -> Args -> Elims
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply Args
pars)) 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 -> 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
da
              , TCMT IO Doc
"isRec  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> (Bool -> [Char]) -> Bool -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool -> [Char]
forall a. Show a => a -> [Char]
show) Bool
isRec
              , TCMT IO Doc
"gamma  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
gamma
              , TCMT IO Doc
"pars   =" 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 :: * -> *). Functor m => m Doc -> m Doc
brackets ([TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep ([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]
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc
comma ([TCMT IO Doc] -> [TCMT IO Doc]) -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> TCMT IO Doc) -> Args -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM Args
pars)
              , TCMT IO Doc
"ixs    =" 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 :: * -> *). Functor m => m Doc -> m Doc
brackets ([TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep ([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]
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc
comma ([TCMT IO Doc] -> [TCMT IO Doc]) -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> TCMT IO Doc) -> Args -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM Args
ixs)
              , TCMT IO Doc
"cixs   =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
gamma (TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets ([TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep ([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]
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc
comma ([TCMT IO Doc] -> [TCMT IO Doc]) -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> TCMT IO Doc) -> Args -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM Args
cixs))
              ]
            ]
                 -- We ignore forcing for make-case
      [IsForced]
cforced <- ExceptT TCErr tcm Bool
-> ExceptT TCErr tcm [IsForced]
-> ExceptT TCErr tcm [IsForced]
-> ExceptT TCErr tcm [IsForced]
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (Lens' Bool TCEnv -> ExceptT TCErr tcm Bool
forall (m :: * -> *) a. MonadTCEnv m => Lens' a TCEnv -> m a
viewTC (Bool -> f Bool) -> TCEnv -> f TCEnv
Lens' Bool TCEnv
eMakeCase) ([IsForced] -> ExceptT TCErr tcm [IsForced]
forall a. a -> ExceptT TCErr tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return []) (ExceptT TCErr tcm [IsForced] -> ExceptT TCErr tcm [IsForced])
-> ExceptT TCErr tcm [IsForced] -> ExceptT TCErr tcm [IsForced]
forall a b. (a -> b) -> a -> b
$
                 {-else-} Definition -> [IsForced]
defForced (Definition -> [IsForced])
-> ExceptT TCErr tcm Definition -> ExceptT TCErr tcm [IsForced]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ExceptT TCErr tcm Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
c)

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

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

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

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

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

      TCMT IO UnificationResult -> ExceptT TCErr tcm UnificationResult
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO UnificationResult -> TCMT IO UnificationResult
withKIfStrict (TCMT IO UnificationResult -> TCMT IO UnificationResult)
-> TCMT IO UnificationResult -> TCMT IO UnificationResult
forall a b. (a -> b) -> a -> b
$ Maybe NoLeftInv
-> Telescope
-> FlexibleVars
-> Type
-> Args
-> Args
-> TCMT IO UnificationResult
forall (m :: * -> *).
(PureTCM m, MonadBench m, BenchPhase m ~ Phase,
 MonadError TCErr m) =>
Maybe NoLeftInv
-> Telescope
-> FlexibleVars
-> Type
-> Args
-> Args
-> m UnificationResult
unifyIndices Maybe NoLeftInv
genTrx Telescope
delta1Gamma FlexibleVars
flex Type
da' Args
cixs Args
ixs') ExceptT TCErr tcm UnificationResult
-> (UnificationResult -> ExceptT TCErr tcm (LHSState a))
-> ExceptT TCErr tcm (LHSState a)
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

        -- Mismatch.  Report and abort.
        NoUnify NegativeUnification
neg -> TypeError -> ExceptT TCErr tcm (LHSState a)
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr tcm (LHSState a))
-> TypeError -> ExceptT TCErr tcm (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 tcm (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 tcm (LHSState a)
stuck Maybe Blocker
forall a. Maybe a
Nothing [UnificationFailure]
errs

        -- Success.
        Unifies (Telescope
delta1',PatternSubstitution
rho0,[NamedArg DeBruijnPattern]
es) -> do

          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
15 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"unification successful"
          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
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
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
delta1'
            , TCMT IO Doc
"rho0    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta1' (PatternSubstitution -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => PatternSubstitution -> m Doc
prettyTCM PatternSubstitution
rho0)
            , TCMT IO Doc
"es      =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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 (PatternSubstitution
rho1,PatternSubstitution
rho2) = Int
-> PatternSubstitution
-> (PatternSubstitution, PatternSubstitution)
forall a.
Int -> Substitution' a -> (Substitution' a, Substitution' a)
splitS (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
gamma) PatternSubstitution
rho0

          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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
<+> PatternSubstitution -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => PatternSubstitution -> m Doc
prettyTCM PatternSubstitution
rho1
            , TCMT IO Doc
"rho2    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> PatternSubstitution -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => PatternSubstitution -> m Doc
prettyTCM PatternSubstitution
rho2
            ]

          -- Andreas, 2010-09-09, save the type.
          -- It is relative to Δ₁, but it should be relative to Δ₁'
          let a' :: Type
a' = PatternSubstitution -> Type -> Type
forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
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 PatternSubstitution
Substitution' (SubstArg [NamedArg DeBruijnPattern])
rho0 ([NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ (Telescope -> Boundary -> [NamedArg DeBruijnPattern]
forall a.
DeBruijn a =>
Telescope -> Boundary -> [NamedArg (Pattern' a)]
telePatterns Telescope
gamma Boundary
boundary)
              rho3 :: PatternSubstitution
rho3    = DeBruijnPattern -> PatternSubstitution -> PatternSubstitution
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS DeBruijnPattern
crho PatternSubstitution
rho1
              delta2' :: Telescope
delta2' = PatternSubstitution -> Telescope -> Telescope
forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho3 Telescope
delta2
              delta' :: Telescope
delta'  = Telescope
delta1' Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
delta2'
              rho :: PatternSubstitution
rho     = Int -> PatternSubstitution -> PatternSubstitution
forall a. Int -> Substitution' a -> Substitution' a
liftS (Telescope -> Int
forall a. Sized a => a -> Int
size Telescope
delta2) PatternSubstitution
rho3

          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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
<+> PatternSubstitution -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => PatternSubstitution -> m Doc
prettyTCM PatternSubstitution
rho3
            , TCMT IO Doc
"delta2' =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
delta2'
            ]
          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
70 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
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
<+> PatternSubstitution -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty PatternSubstitution
rho3
            , TCMT IO Doc
"delta2' =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Telescope
delta2'
            ]

          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
15 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr tcm ()
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
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM Telescope
delta'
            , TCMT IO Doc
"rho     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta' (PatternSubstitution -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => PatternSubstitution -> m Doc
prettyTCM PatternSubstitution
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 PatternSubstitution
Substitution' (SubstArg [NamedArg DeBruijnPattern])
rho [NamedArg DeBruijnPattern]
ip
              target' :: Arg Type
target'  = PatternSubstitution -> Arg Type -> Arg Type
forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho Arg Type
target

          -- Update the problem equations
          let eqs' :: [ProblemEq]
eqs' = PatternSubstitution -> [ProblemEq] -> [ProblemEq]
forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a -> Lens' [ProblemEq] (Problem a) -> [ProblemEq]
forall o i. o -> Lens' i o -> i
^. ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs
              problem' :: Problem a
problem' = Lens' [ProblemEq] (Problem a) -> LensSet [ProblemEq] (Problem a)
forall i o. Lens' i o -> LensSet i o
set ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs [ProblemEq]
eqs' Problem a
problem

          -- The result type's quantity is set to 0 for erased
          -- constructors, but not if the match is made in an erased
          -- position, or if the original constructor definition is
          -- not erased.
          Quantity
cq <- Definition -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity (Definition -> Quantity)
-> ExceptT TCErr tcm Definition -> ExceptT TCErr tcm Quantity
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> ExceptT TCErr tcm Definition
forall (m :: * -> *).
(ReadTCState m, HasConstInfo m) =>
QName -> m Definition
getOriginalConstInfo (ConHead -> QName
conName ConHead
c)
          let target'' :: Arg Type
target'' = (Quantity -> Quantity) -> Arg Type -> Arg Type
forall a. LensQuantity a => (Quantity -> Quantity) -> a -> a
mapQuantity Quantity -> Quantity
updResMod Arg Type
target'
                where
                  erased :: Bool
erased = case ArgInfo -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity ArgInfo
info of
                    Quantity0{} -> Bool
True
                    Quantity1{} -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
                    Quantityω{} -> Bool
False
                  -- either sets to Quantity0 or is the identity.
                  updResMod :: Quantity -> Quantity
updResMod Quantity
q =
                    case Quantity
cq of
                     Quantity
_ | Bool
erased  -> Quantity
q
                     Quantity0{} -> Quantity -> Quantity -> Quantity
composeQuantity Quantity
cq Quantity
q
                                 -- zero-out, preserves origin
                     Quantity1{} -> Quantity
forall a. HasCallStack => a
__IMPOSSIBLE__
                     Quantityω{} -> Quantity
q

          TCMT IO () -> ExceptT TCErr tcm ()
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> ExceptT TCErr tcm ())
-> TCMT IO () -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext Telescope
delta' (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ do
            Bool
withoutK <- WithDefault 'False -> Bool
forall (b :: Bool). KnownBool b => WithDefault b -> Bool
collapseDefault (WithDefault 'False -> Bool)
-> (PragmaOptions -> WithDefault 'False) -> PragmaOptions -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PragmaOptions -> WithDefault 'False
optWithoutK (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
            Bool
cubical <- WithDefault 'False -> Bool
forall (b :: Bool). KnownBool b => WithDefault b -> Bool
collapseDefault (WithDefault 'False -> Bool)
-> (PragmaOptions -> WithDefault 'False) -> PragmaOptions -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. PragmaOptions -> WithDefault 'False
optCubicalCompatible (PragmaOptions -> Bool) -> TCMT IO PragmaOptions -> TCMT IO Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
            Modality
mod <- Lens' Modality TCEnv -> TCMT IO Modality
forall (m :: * -> *) a. MonadTCEnv m => Lens' a TCEnv -> m a
viewTC (Modality -> f Modality) -> TCEnv -> f TCEnv
Lens' Modality TCEnv
eModality
            Bool -> TCMT IO () -> TCMT IO ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Bool
withoutK Bool -> Bool -> Bool
|| Bool
cubical) Bool -> Bool -> Bool
&& Bool -> Bool
not (Args -> Bool
forall a. Null a => a -> Bool
null Args
ixs)) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
              Modality
-> PatternSubstitution -> Int -> Telescope -> Type -> TCMT IO ()
conSplitModalityCheck Modality
mod PatternSubstitution
rho (Telescope -> Int
forall a. Tele a -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Telescope
delta2) Telescope
tel (Arg Type -> Type
forall e. Arg e -> e
unArg Arg Type
target)

          -- if rest type reduces,
          -- extend the split problem by previously not considered patterns
          LHSState a
st' <- TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a)
forall a. TCM a -> ExceptT TCErr tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM (LHSState a) -> ExceptT TCErr tcm (LHSState a))
-> TCM (LHSState a) -> ExceptT TCErr tcm (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
$ Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
LHSState Telescope
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target'' [Maybe Int]
psplit (Bool
ixsplit Bool -> Bool -> Bool
|| Bool -> Bool
not (Args -> Bool
forall a. Null a => a -> Bool
null Args
ixs))

          [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
12 (TCMT IO Doc -> ExceptT TCErr tcm ())
-> TCMT IO Doc -> ExceptT TCErr 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
sep
            [ TCMT IO Doc
"new problem from 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] -> 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
<+> Telescope -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Telescope -> m Doc
prettyTCM (LHSState a
st' LHSState a -> Lens' Telescope (LHSState a) -> Telescope
forall o i. o -> Lens' i o -> i
^. (Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
Lens' Telescope (LHSState a)
lhsTel)
              , TCMT IO Doc
"eqs'    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext (LHSState a
st' LHSState a -> Lens' Telescope (LHSState a) -> Telescope
forall o i. o -> Lens' i o -> i
^. (Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
Lens' Telescope (LHSState a)
lhsTel) ([ProblemEq] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [ProblemEq] -> m Doc
prettyTCM ([ProblemEq] -> TCMT IO Doc) -> [ProblemEq] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ LHSState a
st' LHSState a -> Lens' [ProblemEq] (LHSState a) -> [ProblemEq]
forall o i. o -> Lens' i o -> i
^. ((Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a)
lhsProblem ((Problem a -> f (Problem a)) -> LHSState a -> f (LHSState a))
-> (([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a))
-> ([ProblemEq] -> f [ProblemEq])
-> LHSState a
-> f (LHSState a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
forall a (f :: * -> *).
Functor f =>
([ProblemEq] -> f [ProblemEq]) -> Problem a -> f (Problem a)
problemEqs))
              , TCMT IO Doc
"ip'     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCMT IO Doc -> TCMT IO Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
forall (m :: * -> *) a.
MonadAddContext m =>
Telescope -> m a -> m a
addContext (LHSState a
st' LHSState a -> Lens' Telescope (LHSState a) -> Telescope
forall o i. o -> Lens' i o -> i
^. (Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
(Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
Lens' Telescope (LHSState a)
lhsTel) ([NamedArg DeBruijnPattern] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty ([NamedArg DeBruijnPattern] -> TCMT IO Doc)
-> [NamedArg DeBruijnPattern] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ LHSState a
st' LHSState a
-> Lens' [NamedArg DeBruijnPattern] (LHSState a)
-> [NamedArg DeBruijnPattern]
forall o i. o -> Lens' i o -> i
^. ([NamedArg DeBruijnPattern] -> f [NamedArg DeBruijnPattern])
-> LHSState a -> f (LHSState a)
forall a (f :: * -> *).
Functor f =>
([NamedArg DeBruijnPattern] -> f [NamedArg DeBruijnPattern])
-> LHSState a -> f (LHSState a)
Lens' [NamedArg DeBruijnPattern] (LHSState a)
lhsOutPat)
              ]
            ]
          LHSState a -> ExceptT TCErr tcm (LHSState a)
forall a. a -> ExceptT TCErr tcm a
forall (m :: * -> *) a. Monad m => a -> m a
return LHSState a
st'


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

checkMatchingAllowed :: (MonadTCError m)
  => 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 =>
QName -> DataOrRecord -> m ()
checkMatchingAllowed QName
d = \case
  IsRecord Maybe Induction
ind EtaEquality
eta
    | Just Induction
CoInductive <- Maybe Induction
ind -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m ()) -> TypeError -> m ()
forall a b. (a -> b) -> a -> b
$
        [Char] -> TypeError
GenericError [Char]
"Pattern matching on coinductive types is not allowed"
    | Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ EtaEquality -> Bool
forall a. PatternMatchingAllowed a => a -> Bool
patternMatchingAllowed EtaEquality
eta -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> m ()) -> TypeError -> m ()
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
SplitOnNonEtaRecord QName
d
    | Bool
otherwise -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  DataOrRecord
IsData -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

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

data DataOrRecord
  = IsData
  | IsRecord
    { DataOrRecord -> Maybe Induction
recordInduction   :: Maybe Induction
    , DataOrRecord -> EtaEquality
recordEtaEquality :: EtaEquality
    }
  deriving (Int -> DataOrRecord -> [Char] -> [Char]
[DataOrRecord] -> [Char] -> [Char]
DataOrRecord -> [Char]
(Int -> DataOrRecord -> [Char] -> [Char])
-> (DataOrRecord -> [Char])
-> ([DataOrRecord] -> [Char] -> [Char])
-> Show DataOrRecord
forall a.
(Int -> a -> [Char] -> [Char])
-> (a -> [Char]) -> ([a] -> [Char] -> [Char]) -> Show a
$cshowsPrec :: Int -> DataOrRecord -> [Char] -> [Char]
showsPrec :: Int -> DataOrRecord -> [Char] -> [Char]
$cshow :: DataOrRecord -> [Char]
show :: DataOrRecord -> [Char]
$cshowList :: [DataOrRecord] -> [Char] -> [Char]
showList :: [DataOrRecord] -> [Char] -> [Char]
Show)

-- | Check if the type is a data or record type and return its name,
--   definition, 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, Args, Args)
       -- ^ The 'Args' are parameters and indices.

isDataOrRecordType :: forall (m :: * -> *).
(MonadTCM m, PureTCM m) =>
Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
isDataOrRecordType Type
a0 = Type
-> (Blocker
    -> Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> (NotBlocked
    -> Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> ExceptT TCErr m (DataOrRecord, QName, 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, Args, Args)
blocked ((NotBlocked
  -> Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
 -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> (NotBlocked
    -> Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> ExceptT TCErr m (DataOrRecord, QName, 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 Defn -> ExceptT TCErr m Defn
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (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 => QName -> m Definition
getConstInfo QName
d) ExceptT TCErr m Defn
-> (Defn -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> ExceptT TCErr m (DataOrRecord, QName, 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
>>= \case

      Datatype{dataPars :: Defn -> Int
dataPars = Int
np} -> 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, MonadReduce 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
$ TypeError -> ExceptT TCErr m ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr m ())
-> ExceptT TCErr m TypeError -> ExceptT TCErr m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

        let (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
$ Args -> Maybe Args -> Args
forall a. a -> Maybe a -> a
fromMaybe Args
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Args -> Args) -> Maybe Args -> Args
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
        (DataOrRecord, QName, Args, Args)
-> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall a. a -> ExceptT TCErr m a
forall (m :: * -> *) a. Monad m => a -> m a
return (DataOrRecord
IsData, QName
d, 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 = Args -> Maybe Args -> Args
forall a. a -> Maybe a -> a
fromMaybe Args
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Args -> Args) -> Maybe Args -> Args
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
        (DataOrRecord, QName, Args, Args)
-> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall a. a -> ExceptT TCErr m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Induction -> EtaEquality -> DataOrRecord
IsRecord Maybe Induction
recInduction EtaEquality
recEtaEquality', QName
d, Args
pars, [])

      -- Issue #2253: the data type could be abstract.
      AbstractDefn{} -> TypeError -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> (Doc -> TypeError)
-> Doc
-> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> ExceptT TCErr m Doc
-> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
        TCMT IO Doc -> ExceptT TCErr m Doc
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Doc -> ExceptT TCErr m Doc)
-> TCMT IO Doc -> ExceptT TCErr m Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Cannot split on abstract data type" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
d

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

      -- Can't match before we have the definition
      DataOrRecSig{} -> TypeError -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> (Doc -> TypeError)
-> Doc
-> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> ExceptT TCErr m Doc
-> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
        TCMT IO Doc -> ExceptT TCErr m Doc
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Doc -> ExceptT TCErr m Doc)
-> TCMT IO Doc -> ExceptT TCErr m Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Cannot split on data type" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
d TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"whose definition has not yet been checked"

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

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

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

      PrimitiveSort{} -> TypeError -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> ExceptT TCErr m TypeError
-> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

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

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

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

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

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

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

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

  where
  notData :: ExceptT TCErr m TypeError
notData      = TCM TypeError -> ExceptT TCErr m TypeError
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> ExceptT TCErr m TypeError)
-> TCM TypeError -> ExceptT TCErr m TypeError
forall a b. (a -> b) -> a -> b
$ SplitError -> TypeError
SplitError (SplitError -> TypeError)
-> (Closure Type -> SplitError) -> Closure Type -> TypeError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure Type -> SplitError
NotADatatype (Closure Type -> TypeError)
-> TCMT IO (Closure Type) -> TCM TypeError
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, Args, Args)
blocked Blocker
b Type
_a = TypeError -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> ExceptT TCErr m (DataOrRecord, QName, Args, Args))
-> ExceptT TCErr m TypeError
-> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do TCM TypeError -> ExceptT TCErr m TypeError
forall a. TCM a -> ExceptT TCErr m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> ExceptT TCErr m TypeError)
-> TCM TypeError -> ExceptT TCErr m TypeError
forall a b. (a -> b) -> a -> b
$ SplitError -> TypeError
SplitError (SplitError -> TypeError)
-> (Closure Type -> SplitError) -> Closure Type -> TypeError
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocker -> Closure Type -> SplitError
BlockedType Blocker
b (Closure Type -> TypeError)
-> TCMT IO (Closure Type) -> TCM TypeError
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
  ConHead
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 => QName -> m Definition
getConstInfo QName
d) TCMT IO Defn -> (Defn -> TCMT IO ConHead) -> TCMT IO ConHead
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Record{recConHead :: Defn -> ConHead
recConHead = ConHead
con} -> ConHead -> TCMT IO ConHead
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConHead -> TCMT IO ConHead) -> ConHead -> TCMT IO ConHead
forall a b. (a -> b) -> a -> b
$ KillRangeT ConHead
forall a. KillRange a => KillRangeT a
killRange ConHead
con
    Defn
_ -> TypeError -> TCMT IO ConHead
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ConHead) -> TypeError -> TCMT IO ConHead
forall a b. (a -> b) -> a -> b
$ Type -> TypeError
ShouldBeRecordType Type
a
  Type
b <- (Type -> Args -> Type
`piApply` Args
pars) (Type -> Type) -> (Definition -> Type) -> Definition -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType (Definition -> Type) -> TCMT IO Definition -> TCMT IO Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
con)
  (ConHead, Type) -> TCM (ConHead, Type)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (ConHead
con, Type
b)


-- | Disambiguate a projection based on the record type it is supposed to be
--   projecting from. Returns the unambiguous projection name and its type.
--   Throws an error if the type is not a record type.
disambiguateProjection
  :: Maybe Hiding   -- ^ Hiding info of the projection's principal argument.
                    --   @Nothing@ if 'Postfix' projection.
  -> AmbiguousQName -- ^ Name of the projection to be disambiguated.
  -> Arg Type       -- ^ Record type we are projecting from.
  -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
       -- ^ @Bool@ signifies whether copattern matching is allowed at
       --   the inferred record type.
disambiguateProjection :: Maybe Hiding
-> AmbiguousQName
-> Arg Type
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
disambiguateProjection Maybe Hiding
h ambD :: AmbiguousQName
ambD@(AmbQ List1 QName
ds) Arg 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 (Maybe (QName, Args, Defn))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
-> ((QName, Args, Defn)
    -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (TCMT IO (Maybe (QName, Args, Defn))
-> TCMT IO (Maybe (QName, Args, Defn))
forall a. TCM a -> TCM a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (Maybe (QName, Args, Defn))
 -> TCMT IO (Maybe (QName, Args, Defn)))
-> TCMT IO (Maybe (QName, Args, Defn))
-> TCMT IO (Maybe (QName, Args, Defn))
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO (Maybe (QName, Args, Defn))
forall (m :: * -> *).
PureTCM m =>
Type -> m (Maybe (QName, Args, Defn))
isRecordType (Type -> TCMT IO (Maybe (QName, Args, Defn)))
-> Type -> TCMT IO (Maybe (QName, Args, Defn))
forall a b. (a -> b) -> a -> b
$ Arg Type -> Type
forall e. Arg e -> e
unArg Arg Type
b) TCM (QName, Bool, QName, Arg Type, ArgInfo)
notRecord (((QName, Args, Defn)
  -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
 -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> ((QName, Args, Defn)
    -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a b. (a -> b) -> a -> b
$ \(QName
r, Args
vs, Defn
def) -> case Defn
def of
    Record{ recFields :: Defn -> [Dom' Term QName]
recFields = [Dom' Term QName]
fs, Maybe Induction
recInduction :: Defn -> Maybe Induction
recInduction :: Maybe Induction
recInduction, recEtaEquality' :: Defn -> EtaEquality
recEtaEquality' = EtaEquality
eta } -> do
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"we are of record type r  = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
r
        , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"applied to parameters vs = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Args -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Args -> m Doc
prettyTCM Args
vs
        , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"and have fields       fs = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Arg QName] -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ((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
recInduction 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
            ([]   , []      ) -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a. HasCallStack => a
__IMPOSSIBLE__
            (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
            ([TCErr]
_    , disambs :: [(QName, (Arg Type, ArgInfo, Maybe TCState))]
disambs@((QName
d,(Arg Type, ArgInfo, Maybe TCState)
a):[(QName, (Arg Type, ArgInfo, Maybe TCState))]
_)) -> TypeError -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> (Doc -> TypeError)
-> Doc
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCMT IO Doc -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
              [ TCMT IO Doc
"Ambiguous projection " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
d TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> TCMT IO Doc
"."
              , TCMT IO Doc
"It could refer to any of"
              , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ ((QName, (Arg Type, ArgInfo, Maybe TCState)) -> TCMT IO Doc)
-> [(QName, (Arg Type, ArgInfo, Maybe TCState))] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> TCMT IO Doc
prettyDisambProj (QName -> TCMT IO Doc)
-> ((QName, (Arg Type, ArgInfo, Maybe TCState)) -> QName)
-> (QName, (Arg Type, ArgInfo, Maybe TCState))
-> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName, (Arg Type, ArgInfo, Maybe TCState)) -> QName
forall a b. (a, b) -> a
fst) [(QName, (Arg Type, ArgInfo, Maybe TCState))]
disambs
              ]
    Defn
_ -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a. HasCallStack => a
__IMPOSSIBLE__

  where
    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.
      NonEmpty (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState)))
disambiguations <- (QName
 -> TCM (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState))))
-> List1 QName
-> TCM
     (NonEmpty
        (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 (TCMT IO) (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 (TCMT IO) (QName, (Arg Type, ArgInfo, Maybe TCState))
 -> TCM (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState))))
-> (QName
    -> ExceptT
         TCErr (TCMT IO) (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 (TCMT IO) (QName, (Arg Type, ArgInfo, Maybe TCState))
tryProj Bool
constraintsOk [Dom' Term QName]
fs QName
r Args
vs) List1 QName
ds
      case NonEmpty (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState)))
-> ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
forall a b. List1 (Either a b) -> ([a], [b])
List1.partitionEithers NonEmpty (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState)))
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 :: TCM (QName, Bool, QName, Arg Type, ArgInfo)
notRecord = QName -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj (QName -> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> QName -> TCM (QName, Bool, QName, Arg Type, ArgInfo)
forall a b. (a -> b) -> a -> b
$ List1 QName -> QName
forall a. NonEmpty a -> a
List1.head List1 QName
ds

    wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a
    wrongProj :: forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d = TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m a) -> m TypeError -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM TypeError -> m TypeError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> m TypeError) -> TCM TypeError -> m TypeError
forall a b. (a -> b) -> a -> b
$ Doc -> TypeError
GenericDocError (Doc -> TypeError) -> TCMT IO Doc -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ TCMT IO Doc
"Cannot eliminate type "
        , Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM (Arg Type -> Type
forall e. Arg e -> e
unArg Arg Type
b)
        , TCMT IO Doc
" with projection "
        , if AmbiguousQName -> Bool
isAmbiguous AmbiguousQName
ambD then
            [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc)
-> (QName -> [Char]) -> QName -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (QName -> TCMT IO Doc) -> TCMT IO QName -> TCMT IO Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> TCMT IO QName
dropTopLevelModule QName
d
          else
            QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
d
        ]

    wrongHiding :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a
    wrongHiding :: forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongHiding QName
d = TypeError -> m a
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m a) -> m TypeError -> m a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM TypeError -> m TypeError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> m TypeError) -> TCM TypeError -> m TypeError
forall a b. (a -> b) -> a -> b
$ Doc -> TypeError
GenericDocError (Doc -> TypeError) -> TCMT IO Doc -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ TCMT IO Doc
"Wrong hiding used for projection " , QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
d ]

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

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

        -- If projIndex==0, then the projection is already applied
        -- to the record value (like in @open R r@), and then it
        -- is no longer a projection but a record field.
        Bool -> ExceptT TCErr (TCMT IO) () -> ExceptT TCErr (TCMT IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (ProjLams -> Bool
forall a. Null a => a -> Bool
null (ProjLams -> Bool) -> ProjLams -> Bool
forall a b. (a -> b) -> a -> b
$ Projection -> ProjLams
projLams Projection
proj) (ExceptT TCErr (TCMT IO) () -> ExceptT TCErr (TCMT IO) ())
-> ExceptT TCErr (TCMT IO) () -> ExceptT TCErr (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ QName -> ExceptT TCErr (TCMT IO) ()
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d
        [Char] -> Int -> [Char] -> ExceptT TCErr (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.lhs.split" Int
90 [Char]
"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.
        [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 (TCMT IO Doc -> ExceptT TCErr (TCMT IO) ())
-> TCMT IO Doc -> ExceptT TCErr (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
          [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"proj                  d0 = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
d0
          , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"original proj         d  = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
d
          ]
        -- Get the field decoration.
        -- If the projection pattern name @d@ is not a field name,
        -- we have to try the next projection name.
        -- If this was not an ambiguous projection, that's an error.
        Dom' Term QName
argd <- ExceptT TCErr (TCMT IO) (Dom' Term QName)
-> (Dom' Term QName -> ExceptT TCErr (TCMT IO) (Dom' Term QName))
-> Maybe (Dom' Term QName)
-> ExceptT TCErr (TCMT IO) (Dom' Term QName)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (QName -> ExceptT TCErr (TCMT IO) (Dom' Term QName)
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d) Dom' Term QName -> ExceptT TCErr (TCMT IO) (Dom' Term QName)
forall a. a -> ExceptT TCErr (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Dom' Term QName)
 -> ExceptT TCErr (TCMT IO) (Dom' Term QName))
-> Maybe (Dom' Term QName)
-> ExceptT TCErr (TCMT IO) (Dom' Term QName)
forall a b. (a -> b) -> a -> b
$ (Dom' Term QName -> Bool)
-> [Dom' Term QName] -> Maybe (Dom' Term QName)
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((QName
d QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
==) (QName -> Bool)
-> (Dom' Term QName -> QName) -> Dom' Term QName -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom' Term QName -> QName
forall t e. Dom' t e -> e
unDom) [Dom' Term QName]
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 :: ArgInfo
ai = Dom' Term QName -> ArgInfo
forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom' Term QName
argd

        [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 (TCMT IO Doc -> ExceptT TCErr (TCMT IO) ())
-> TCMT IO Doc -> ExceptT TCErr (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"original proj relevance  = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Relevance -> [Char]
forall a. Show a => a -> [Char]
show (Dom' Term QName -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Dom' Term QName
argd)
          , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"original proj quantity   = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Quantity -> [Char]
forall a. Show a => a -> [Char]
show (Dom' Term QName -> Quantity
forall a. LensQuantity a => a -> Quantity
getQuantity  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.
        Bool -> ExceptT TCErr (TCMT IO) () -> ExceptT TCErr (TCMT IO) ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (Maybe Hiding -> Bool -> (Hiding -> Bool) -> Bool
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe Hiding
h Bool
True ((Hiding -> Bool) -> Bool) -> (Hiding -> Bool) -> Bool
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Hiding -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding (ArgInfo -> Hiding -> Bool) -> ArgInfo -> Hiding -> Bool
forall a b. (a -> b) -> a -> b
$ Projection -> ArgInfo
projArgInfo Projection
proj) (ExceptT TCErr (TCMT IO) () -> ExceptT TCErr (TCMT IO) ())
-> ExceptT TCErr (TCMT IO) () -> ExceptT TCErr (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ QName -> ExceptT TCErr (TCMT IO) ()
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongHiding QName
d

        -- Andreas, 2016-12-31, issue #1976: Check parameters.
        let chk :: TCMT IO ()
chk = QName -> QName -> Args -> TCMT IO ()
forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> Args -> tcm ()
checkParameters QName
qr QName
r Args
vs
        Maybe TCState
mst <- TCM (Maybe TCState) -> ExceptT TCErr (TCMT IO) (Maybe TCState)
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors (TCM (Maybe TCState) -> ExceptT TCErr (TCMT IO) (Maybe TCState))
-> TCM (Maybe TCState) -> ExceptT TCErr (TCMT IO) (Maybe TCState)
forall a b. (a -> b) -> a -> b
$
          if Bool
constraintsOk then TCState -> Maybe TCState
forall a. a -> Maybe a
Just (TCState -> Maybe TCState)
-> (((), TCState) -> TCState) -> ((), TCState) -> Maybe TCState
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ((), TCState) -> TCState
forall a b. (a, b) -> b
snd (((), TCState) -> Maybe TCState)
-> TCMT IO ((), TCState) -> TCM (Maybe TCState)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO () -> TCMT IO ((), TCState)
forall a. TCM a -> TCM (a, TCState)
localTCStateSaving TCMT IO ()
chk
          else Maybe TCState
forall a. Maybe a
Nothing Maybe TCState -> TCMT IO () -> TCM (Maybe TCState)
forall a b. a -> TCMT IO b -> TCMT IO a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ TCMT IO () -> TCMT IO ()
forall (m :: * -> *) a.
(HasOptions m, MonadConstraint m, MonadDebug m, MonadError TCErr m,
 MonadFresh ProblemId m, MonadTCEnv m, MonadWarning m) =>
m a -> m a
nonConstraining TCMT IO ()
chk

        -- Get the type of projection d applied to "self"
        Type
dType <- TCMT IO Type -> ExceptT TCErr (TCMT IO) Type
forall a. TCM a -> ExceptT TCErr (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Type -> ExceptT TCErr (TCMT IO) Type)
-> TCMT IO Type -> ExceptT TCErr (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ 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 => QName -> m Definition
getConstInfo QName
d  -- full type!
        [Char] -> Int -> TCMT IO Doc -> ExceptT TCErr (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 (TCMT IO Doc -> ExceptT TCErr (TCMT IO) ())
-> TCMT IO Doc -> ExceptT TCErr (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 being projected by dType = " 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
dType
          ]
        Type
projType <- TCMT IO Type -> ExceptT TCErr (TCMT IO) Type
forall a. TCM a -> ExceptT TCErr (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Type -> ExceptT TCErr (TCMT IO) Type)
-> TCMT IO Type -> ExceptT TCErr (TCMT IO) Type
forall a b. (a -> b) -> a -> b
$ Type
dType Type -> Args -> TCMT IO Type
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
forall (m :: * -> *).
(MonadReduce m, HasBuiltins m) =>
Type -> Args -> m Type
`piApplyM` Args
vs
        (QName, (Arg Type, ArgInfo, Maybe TCState))
-> ExceptT
     TCErr (TCMT IO) (QName, (Arg Type, ArgInfo, Maybe TCState))
forall a. a -> ExceptT TCErr (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
d0, (ArgInfo -> Type -> Arg Type
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
ai Type
projType, Projection -> ArgInfo
projArgInfo Projection
proj, Maybe TCState
mst))

-- | Disambiguate a constructor based on the data type it is supposed to be
--   constructing. Returns the unambiguous constructor name and its type.
--   Precondition: type should be a data/record type.
disambiguateConstructor
  :: AmbiguousQName    -- ^ The name of the constructor to be disambiguated.
  -> QName             -- ^ Name of the datatype.
  -> Args              -- ^ Parameters of the datatype
  -> TCM (ConHead, Type)
disambiguateConstructor :: AmbiguousQName -> QName -> Args -> TCM (ConHead, Type)
disambiguateConstructor ambC :: AmbiguousQName
ambC@(AmbQ List1 QName
cs) QName
d Args
pars = do
  QName
d <- QName -> TCMT IO QName
forall (m :: * -> *). HasConstInfo m => QName -> m QName
canonicalName QName
d
  [QName]
cons <- 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 => QName -> m Definition
getConstInfo QName
d TCMT IO Defn -> (Defn -> TCMT IO [QName]) -> TCMT IO [QName]
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
    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.
  Bool
-> QName
-> [QName]
-> (([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
    -> TCM (ConHead, Type))
-> TCM (ConHead, Type)
tryDisambiguate Bool
False 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
$ \ ([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 :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> 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]
_    , disambs :: [List1 (QName, ConHead, (Type, Maybe TCState))]
disambs@(((QName
c,ConHead
_,(Type, Maybe TCState)
_):|[(QName, ConHead, (Type, Maybe TCState))]
_):[List1 (QName, ConHead, (Type, Maybe TCState))]
_)) -> TypeError -> TCM (ConHead, Type)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM (ConHead, Type))
-> (Doc -> TypeError) -> Doc -> TCM (ConHead, Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCM (ConHead, Type)) -> TCMT IO Doc -> TCM (ConHead, Type)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"Ambiguous constructor " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> Name -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (QName -> Name
qnameName QName
c) TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> TCMT IO Doc
"."
          , TCMT IO Doc
"It could refer to any of"
          , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ ((QName, ConHead, (Type, Maybe TCState)) -> TCMT IO Doc)
-> [(QName, ConHead, (Type, Maybe TCState))] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> TCMT IO Doc
prettyDisambCons (QName -> TCMT IO Doc)
-> ((QName, ConHead, (Type, Maybe TCState)) -> QName)
-> (QName, ConHead, (Type, Maybe TCState))
-> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. 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
. (QName, ConHead, (Type, Maybe TCState)) -> ConHead
forall a b c. (a, b, c) -> b
snd3) ([(QName, ConHead, (Type, Maybe TCState))] -> [TCMT IO Doc])
-> [(QName, ConHead, (Type, Maybe TCState))] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ [List1 (QName, ConHead, (Type, Maybe TCState))]
-> [(QName, ConHead, (Type, Maybe TCState))]
forall a. [List1 a] -> [a]
List1.concat [List1 (QName, ConHead, (Type, Maybe TCState))]
disambs
          ]

  where
    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
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.disamb" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [[TCMT IO Doc]] -> [TCMT IO Doc]
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat ([[TCMT IO Doc]] -> [TCMT IO Doc])
-> [[TCMT IO Doc]] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$
        [ [ TCMT IO Doc
"tryDisambiguate" ]
        , if Bool
constraintsOk then [ TCMT IO Doc
"(allowing new constraints)" ] else [TCMT IO Doc]
forall a. Null a => a
empty
        , (QName -> TCMT IO Doc) -> [QName] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc)
-> (QName -> TCMT IO Doc) -> QName -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty) ([QName] -> [TCMT IO Doc]) -> [QName] -> [TCMT IO Doc]
forall a b. (a -> b) -> a -> b
$ 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
        ]
      NonEmpty (Either TCErr (QName, ConHead, (Type, Maybe TCState)))
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 (TCMT IO) (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 (TCMT IO) (QName, ConHead, (Type, Maybe TCState))
 -> TCMT IO (Either TCErr (QName, ConHead, (Type, Maybe TCState))))
-> (QName
    -> ExceptT TCErr (TCMT IO) (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 (TCMT IO) (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 ([TCErr]
errs, [(QName, ConHead, (Type, Maybe TCState))]
fits0) = NonEmpty (Either TCErr (QName, ConHead, (Type, Maybe TCState)))
-> ([TCErr], [(QName, ConHead, (Type, Maybe TCState))])
forall a b. List1 (Either a b) -> ([a], [b])
List1.partitionEithers NonEmpty (Either TCErr (QName, ConHead, (Type, Maybe TCState)))
disambiguations
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.disamb" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ do
        let hideSt :: (a, b, (a, f b)) -> (a, b, (a, f [Char]))
hideSt (a
c0,b
c,(a
a,f b
mst)) = (a
c0, b
c, (a
a, ([Char]
"(state change)" :: String) [Char] -> f b -> f [Char]
forall a b. a -> f b -> f a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f b
mst))
        TCMT IO Doc
"remaining candidates: " TCMT IO Doc -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. a -> [a] -> [a]
: ((QName, ConHead, (Type, Maybe TCState)) -> TCMT IO Doc)
-> [(QName, ConHead, (Type, Maybe TCState))] -> [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, ConHead, (Type, Maybe TCState)) -> TCMT IO Doc)
-> (QName, ConHead, (Type, Maybe TCState))
-> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName, ConHead, (Type, Maybe [Char])) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *).
MonadPretty m =>
(QName, ConHead, (Type, Maybe [Char])) -> m Doc
prettyTCM ((QName, ConHead, (Type, Maybe [Char])) -> TCMT IO Doc)
-> ((QName, ConHead, (Type, Maybe TCState))
    -> (QName, ConHead, (Type, Maybe [Char])))
-> (QName, ConHead, (Type, Maybe TCState))
-> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName, ConHead, (Type, Maybe TCState))
-> (QName, ConHead, (Type, Maybe [Char]))
forall {f :: * -> *} {a} {b} {a} {b}.
Functor f =>
(a, b, (a, f b)) -> (a, b, (a, f [Char]))
hideSt) [(QName, ConHead, (Type, Maybe TCState))]
fits0
      [(QName, ConHead, (Type, Maybe TCState))]
-> TCM [List1 (QName, ConHead, (Type, Maybe TCState))]
forall a.
[(a, ConHead, (Type, Maybe TCState))]
-> TCM [List1 (a, ConHead, (Type, Maybe TCState))]
dedupCons [(QName, ConHead, (Type, Maybe TCState))]
fits0 TCM [List1 (QName, ConHead, (Type, Maybe TCState))]
-> ([List1 (QName, ConHead, (Type, Maybe TCState))]
    -> TCM (ConHead, Type))
-> TCM (ConHead, Type)
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

        -- Single candidate remains.
        [ (QName
c0,ConHead
c,(Type
a,Maybe TCState
mst)) :| [] ] -> do
          [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.disamb" Int
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
            [ TCMT IO Doc
"tryDisambiguate suceeds with"
            , QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty QName
c0
            , TCMT IO Doc
":"
            , Type -> 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 (f :: * -> *). Applicative f => Bool -> f () -> f ()
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 :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m a) -> TypeError -> m a
forall a b. (a -> b) -> a -> b
$
      QName -> TypeError
AbstractConstructorNotInScope QName
c

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

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

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

        -- Get the type from the original constructor.
        -- Andreas, 2020-06-17 TODO:
        -- Couldn't we return this type from checkConstructorParameters?
        Type
cType <- (Type -> Args -> Type
`piApply` Args
pars) (Type -> Type) -> (Definition -> Type) -> Definition -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType (Definition -> Type)
-> ExceptT TCErr (TCMT IO) Definition
-> ExceptT TCErr (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConHead -> ExceptT TCErr (TCMT IO) Definition
forall (m :: * -> *). HasConstInfo m => ConHead -> m Definition
getConInfo ConHead
con

        (QName, ConHead, (Type, Maybe TCState))
-> ExceptT TCErr (TCMT IO) (QName, ConHead, (Type, Maybe TCState))
forall a. a -> ExceptT TCErr (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
c, ConHead
con, (Type
cType, Maybe TCState
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 :: [List1 (a, ConHead, (Type, Maybe TCState))]
groups = ((a, ConHead, (Type, Maybe TCState)) -> QName)
-> [(a, ConHead, (Type, Maybe TCState))]
-> [List1 (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
. (a, ConHead, (Type, Maybe TCState)) -> ConHead
forall a b c. (a, b, c) -> b
snd3) [(a, ConHead, (Type, Maybe TCState))]
cands
      -- Eliminate duplicates (same type) from groups.
      (List1 (a, ConHead, (Type, Maybe TCState))
 -> TCMT IO (List1 (a, ConHead, (Type, Maybe TCState))))
-> [List1 (a, ConHead, (Type, Maybe TCState))]
-> TCM [List1 (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)
-> List1 (a, ConHead, (Type, Maybe TCState))
-> TCMT IO (List1 (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` (a, ConHead, (Type, Maybe TCState)) -> (Type, Maybe TCState)
forall a b c. (a, b, c) -> c
thd3)) [List1 (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
forall (m :: * -> *).
(MonadConstraint m, MonadWarning m, MonadError TCErr m,
 MonadFresh ProblemId m) =>
m () -> m Bool
tryConversion (TCMT IO () -> TCMT IO Bool) -> TCMT IO () -> TCMT IO Bool
forall a b. (a -> b) -> a -> b
$ Type -> Type -> TCMT IO ()
forall (m :: * -> *). MonadConversion m => Type -> Type -> m ()
equalType 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


prettyDisamb :: (QName -> Maybe (Range' SrcFile)) -> QName -> TCM Doc
prettyDisamb :: (QName -> Maybe (Range' SrcFile)) -> QName -> TCMT IO Doc
prettyDisamb QName -> Maybe (Range' SrcFile)
f QName
x = do
  let d :: TCMT IO Doc
d  = QName -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (QName -> TCMT IO Doc) -> TCMT IO QName -> TCMT IO Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> TCMT IO QName
dropTopLevelModule QName
x
  Maybe (Range' SrcFile)
-> TCMT IO Doc -> (Range' SrcFile -> TCMT IO Doc) -> TCMT IO Doc
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe (QName -> Maybe (Range' SrcFile)
f QName
x) TCMT IO Doc
d ((Range' SrcFile -> TCMT IO Doc) -> TCMT IO Doc)
-> (Range' SrcFile -> TCMT IO Doc) -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ \ Range' SrcFile
r -> TCMT IO Doc
d TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (TCMT IO Doc
"(introduced at " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> Range' SrcFile -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Range' SrcFile -> m Doc
prettyTCM Range' SrcFile
r TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall a. Semigroup a => a -> a -> a
<> TCMT IO Doc
")")

-- | For Ambiguous Projection errors, print the last range in 'qnameModule'.
--   For Ambiguous Constructor errors, print the range in 'qnameName'. This fixes the bad
--   error message in #4130.
prettyDisambProj, prettyDisambCons :: QName -> TCM Doc
prettyDisambProj :: QName -> TCMT IO Doc
prettyDisambProj = (QName -> Maybe (Range' SrcFile)) -> QName -> TCMT IO Doc
prettyDisamb ((QName -> Maybe (Range' SrcFile)) -> QName -> TCMT IO Doc)
-> (QName -> Maybe (Range' SrcFile)) -> QName -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Range' SrcFile] -> Maybe (Range' SrcFile)
forall a. [a] -> Maybe a
lastMaybe ([Range' SrcFile] -> Maybe (Range' SrcFile))
-> (QName -> [Range' SrcFile]) -> QName -> Maybe (Range' SrcFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Range' SrcFile -> Bool) -> [Range' SrcFile] -> [Range' SrcFile]
forall a. (a -> Bool) -> [a] -> [a]
filter (Range' SrcFile
forall a. Range' a
noRange Range' SrcFile -> Range' SrcFile -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([Range' SrcFile] -> [Range' SrcFile])
-> (QName -> [Range' SrcFile]) -> QName -> [Range' SrcFile]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name -> Range' SrcFile) -> [Name] -> [Range' SrcFile]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Range' SrcFile
nameBindingSite ([Name] -> [Range' SrcFile])
-> (QName -> [Name]) -> QName -> [Range' SrcFile]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ModuleName -> [Name]
mnameToList (ModuleName -> [Name]) -> (QName -> ModuleName) -> QName -> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> ModuleName
qnameModule
prettyDisambCons :: QName -> TCMT IO Doc
prettyDisambCons = (QName -> Maybe (Range' SrcFile)) -> QName -> TCMT IO Doc
prettyDisamb ((QName -> Maybe (Range' SrcFile)) -> QName -> TCMT IO Doc)
-> (QName -> Maybe (Range' SrcFile)) -> QName -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Range' SrcFile -> Maybe (Range' SrcFile)
forall a. a -> Maybe a
Just (Range' SrcFile -> Maybe (Range' SrcFile))
-> (QName -> Range' SrcFile) -> QName -> Maybe (Range' SrcFile)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Range' SrcFile
nameBindingSite (Name -> Range' SrcFile)
-> (QName -> Name) -> QName -> Range' SrcFile
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName

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

-- | Check that given parameters match the parameters of the inferred
--   constructor/projection.
checkParameters
  :: MonadTCM tcm
  => QName  -- ^ The record/data type name of the chosen constructor/projection.
  -> QName  -- ^ The record/data type name as supplied by the type signature.
  -> Args   -- ^ The parameters.
  -> tcm ()
checkParameters :: forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> Args -> tcm ()
checkParameters QName
dc QName
d Args
pars = TCMT IO () -> tcm ()
forall a. TCM a -> tcm a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ do
  Term
a  <- Term -> TCMT IO Term
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (QName -> Elims -> Term
Def QName
dc [])
  case Term
a of
    Def QName
d0 Elims
es -> do -- compare parameters
      let vs :: Args
vs = Args -> Maybe Args -> Args
forall a. a -> Maybe a -> a
fromMaybe Args
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe Args -> Args) -> Maybe Args -> Args
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe Args
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
      [Char] -> Int -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
        [ TCMT IO Doc
"checkParameters"
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"d                   =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc)
-> (QName -> [Char]) -> QName -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow) QName
d
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"d0 (should be == d) =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc)
-> (QName -> [Char]) -> QName -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow) QName
d0
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"dc                  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc)
-> (QName -> [Char]) -> QName -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow) QName
dc
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"vs                  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Args -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Args -> m Doc
prettyTCM Args
vs
        , Int -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"pars                =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Args -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Args -> m Doc
prettyTCM Args
pars
        ]
      -- when (d0 /= d) __IMPOSSIBLE__ -- d could have extra qualification
      Type
t <- QName -> TCMT IO Type
forall (m :: * -> *).
(HasConstInfo m, ReadTCState m) =>
QName -> m Type
typeOfConst QName
d
      [Polarity]
-> [IsForced] -> Type -> Term -> Args -> Args -> TCMT IO ()
forall (m :: * -> *).
MonadConversion m =>
[Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> m ()
compareArgs [] [] Type
t (QName -> Elims -> Term
Def QName
d []) Args
vs (Int -> Args -> Args
forall a. Int -> [a] -> [a]
take (Args -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length Args
vs) Args
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 -> Telescope -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr a
a Telescope
tel Maybe ty
mtarget = do
  TCM (Sort' Term) -> m (Sort' Term)
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (Sort' Term -> TCM (Sort' Term)
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (Sort' Term -> TCM (Sort' Term)) -> Sort' Term -> TCM (Sort' Term)
forall a b. (a -> b) -> a -> b
$ a -> Sort' Term
forall a. LensSort a => a -> Sort' Term
getSort a
a) m (Sort' Term) -> (Sort' Term -> 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
    sa :: Sort' Term
sa@Type{} -> m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
forall (m :: * -> *). HasOptions m => m Bool
isTwoLevelEnabled m ()
checkFibrantSplit
    Prop{} -> m ()
checkPropSplit
    Inf IsFibrant
IsFibrant Integer
_ -> m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM m Bool
forall (m :: * -> *). HasOptions m => m Bool
isTwoLevelEnabled m ()
checkFibrantSplit
    Inf IsFibrant
IsStrict Integer
_ -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    SSet{} -> () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Sort' Term
sa      -> TypeError -> m ()
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m ()) -> m TypeError -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM TypeError -> m TypeError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> m TypeError) -> TCM TypeError -> m TypeError
forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> TypeError
SortOfSplitVarError (Maybe Blocker -> Doc -> TypeError)
-> TCMT IO (Maybe Blocker) -> TCMT IO (Doc -> TypeError)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Sort' Term -> TCMT IO (Maybe Blocker)
forall t (m :: * -> *).
(Reduce t, IsMeta t, MonadReduce m) =>
t -> m (Maybe Blocker)
isBlocked Sort' Term
sa TCMT IO (Doc -> TypeError) -> TCMT IO Doc -> TCM TypeError
forall a b. TCMT IO (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ TCMT IO Doc
"Cannot split on datatype in sort" , Sort' Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Sort' Term -> m Doc
prettyTCM (a -> Sort' Term
forall a. LensSort a => a -> Sort' Term
getSort a
a) ]

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

    checkIsProp :: ty -> m ()
checkIsProp ty
t = BlockT m Bool -> m (Either Blocker Bool)
forall (m :: * -> *) a.
Monad m =>
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 :: * -> *} {b}.
(ReadTCState m, MonadError TCErr m, MonadTCM m) =>
DataOrRecord -> m b
splitOnPropError DataOrRecord
dr -- TODO
      Right Bool
False -> DataOrRecord -> m ()
forall {m :: * -> *} {b}.
(ReadTCState m, MonadError TCErr m, MonadTCM m) =>
DataOrRecord -> m b
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 Maybe Induction
_ EtaEquality
_ <- DataOrRecord
dr     = () -> m ()
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Just ty
target <- Maybe ty
mtarget = do
          [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target:" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ty -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ty -> m Doc
prettyTCM ty
target
          ty -> m ()
checkIsFibrant ty
target
          [Dom ([Char], Type)] -> (Dom ([Char], Type) -> m ()) -> m ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (Telescope -> [Dom ([Char], Type)]
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Telescope
tel) ((Dom ([Char], Type) -> m ()) -> m ())
-> (Dom ([Char], Type) -> m ()) -> m ()
forall a b. (a -> b) -> a -> b
$ \ Dom ([Char], Type)
d -> do
            let ty :: Type
ty = ([Char], Type) -> Type
forall a b. (a, b) -> b
snd (([Char], Type) -> Type) -> ([Char], Type) -> Type
forall a b. (a -> b) -> a -> b
$ Dom ([Char], Type) -> ([Char], Type)
forall t e. Dom' t e -> e
unDom Dom ([Char], Type)
d
            Type -> m ()
checkIsCoFibrant Type
ty
      | Bool
otherwise              = do
          [Char] -> Int -> TCMT IO Doc -> m ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 (TCMT IO Doc -> m ()) -> TCMT IO Doc -> m ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"no target"
          Maybe Blocker -> m ()
splitOnFibrantError Maybe Blocker
forall a. Maybe a
Nothing

    -- Cofibrant types are those that could be the domain of a fibrant
    -- pi type. (Notion by C. Sattler).
    checkIsCoFibrant :: Type -> m ()
checkIsCoFibrant Type
t = BlockT m Bool -> m (Either Blocker Bool)
forall (m :: * -> *) a.
Monad m =>
BlockT m a -> m (Either Blocker a)
runBlocked (Type -> BlockT m Bool
forall a (m :: * -> *).
(LensSort a, PureTCM m, MonadBlock m) =>
a -> m 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, MonadReduce 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 = BlockT m Bool -> m (Either Blocker Bool)
forall (m :: * -> *) a.
Monad m =>
BlockT m a -> m (Either Blocker a)
runBlocked (ty -> BlockT m Bool
forall a (m :: * -> *).
(LensSort a, PureTCM m, MonadBlock m) =>
a -> m 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 b
splitOnPropError DataOrRecord
dr = TypeError -> m b
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m b) -> m TypeError -> m b
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
      TCM TypeError -> m TypeError
forall a. TCM a -> m a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM TypeError -> m TypeError) -> TCM TypeError -> m TypeError
forall a b. (a -> b) -> a -> b
$ Doc -> TypeError
GenericDocError (Doc -> TypeError) -> TCMT IO Doc -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
        (TCMT IO Doc
"Cannot split on" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> DataOrRecord -> TCMT IO Doc
kindOfData DataOrRecord
dr TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"in Prop unless target is in Prop")
      where
        kindOfData :: DataOrRecord -> TCM Doc
        kindOfData :: DataOrRecord -> TCMT IO Doc
kindOfData DataOrRecord
IsData                          = TCMT IO Doc
"datatype"
        kindOfData (IsRecord Maybe Induction
Nothing EtaEquality
_)            = TCMT IO Doc
"record type"
        kindOfData (IsRecord (Just Induction
Inductive) EtaEquality
_)   = TCMT IO Doc
"inductive record type"
        kindOfData (IsRecord (Just Induction
CoInductive) EtaEquality
_) = TCMT IO Doc
"coinductive record type"

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