{-# LANGUAGE NondecreasingIndentation #-}

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

import Prelude hiding ( mapM, null, sequence )

import Data.Maybe

import Control.Arrow (left)
import Control.Monad
import Control.Monad.Reader
import Control.Monad.Writer hiding ((<>))
import Control.Monad.Trans.Maybe

import Data.Either (partitionEithers)
import Data.IntMap (IntMap)
import qualified Data.IntMap as IntMap
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List (findIndex)
import qualified Data.List as List
import Data.List.NonEmpty (NonEmpty(..))
import qualified Data.List.NonEmpty as NonEmpty
import Data.Monoid ( Monoid, mempty, mappend )
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 (storeDisambiguatedName, disambiguateRecordFields)
import Agda.Interaction.Options
import Agda.Interaction.Options.Lenses

import Agda.Syntax.Internal as I
import Agda.Syntax.Internal.Pattern
import Agda.Syntax.Abstract (IsProjP(..))
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.Forcing
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.Primitive hiding (Nat)
import Agda.TypeChecking.Monad.Builtin

import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkExpr)
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.Except (MonadError(..), ExceptT, runExceptT)
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
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
--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 :: a -> MaybeT TCM FlexibleVarKind

  isFlexiblePattern :: a -> TCM 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)
-> TCM (Maybe FlexibleVarKind) -> TCM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> MaybeT TCM FlexibleVarKind -> TCM (Maybe FlexibleVarKind)
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (a -> MaybeT TCM FlexibleVarKind
forall a. IsFlexiblePattern a => a -> MaybeT TCM 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 :: Pattern -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern Pattern
p = do
    VerboseKey -> VerboseLevel -> TCM Doc -> MaybeT TCM ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.flex" VerboseLevel
30 (TCM Doc -> MaybeT TCM ()) -> TCM Doc -> MaybeT TCM ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"maybeFlexiblePattern" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Pattern -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
p
    VerboseKey -> VerboseLevel -> TCM Doc -> MaybeT TCM ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.flex" VerboseLevel
60 (TCM Doc -> MaybeT TCM ()) -> TCM Doc -> MaybeT TCM ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"maybeFlexiblePattern (raw) " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc)
-> (Pattern -> VerboseKey) -> Pattern -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> VerboseKey
forall a. Show a => a -> VerboseKey
show (Pattern -> VerboseKey)
-> (Pattern -> Pattern) -> Pattern -> VerboseKey
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 TCM FlexibleVarKind
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
DotFlex
      A.VarP{}  -> FlexibleVarKind -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
ImplicitFlex
      A.WildP{} -> FlexibleVarKind -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
ImplicitFlex
      A.AsP PatInfo
_ BindName
_ Pattern
p -> Pattern -> MaybeT TCM FlexibleVarKind
forall a. IsFlexiblePattern a => a -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern Pattern
p
      A.ConP ConPatInfo
_ AmbiguousQName
cs NAPs Expr
qs | Just QName
c <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
cs ->
        MaybeT TCM Bool
-> MaybeT TCM FlexibleVarKind
-> MaybeT TCM FlexibleVarKind
-> MaybeT TCM 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 TCM (Maybe (QName, Defn)) -> MaybeT TCM Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> MaybeT TCM (Maybe (QName, Defn))
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Maybe (QName, Defn))
isRecordConstructor QName
c) (FlexibleVarKind -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
OtherFlex) {-else-}
            (NAPs Expr -> MaybeT TCM FlexibleVarKind
forall a. IsFlexiblePattern a => a -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern NAPs Expr
qs)
      A.LitP{}  -> FlexibleVarKind -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
OtherFlex
      Pattern
_ -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. MonadPlus m => m a
mzero

instance IsFlexiblePattern (I.Pattern' a) where
  maybeFlexiblePattern :: Pattern' a -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern Pattern' a
p =
    case Pattern' a
p of
      I.DotP{}  -> FlexibleVarKind -> MaybeT TCM FlexibleVarKind
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 TCM FlexibleVarKind
forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
ImplicitFlex  -- expanded from ImplicitP
        | ConPatternInfo -> Bool
conPRecord ConPatternInfo
i -> [NamedArg (Pattern' a)] -> MaybeT TCM FlexibleVarKind
forall a. IsFlexiblePattern a => a -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern [NamedArg (Pattern' a)]
ps
        | Bool
otherwise -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.VarP{}  -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.LitP{}  -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.ProjP{} -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.IApplyP{} -> MaybeT TCM FlexibleVarKind
forall (m :: * -> *) a. MonadPlus m => m a
mzero
      I.DefP{} -> MaybeT TCM FlexibleVarKind
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 :: [a] -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern [a]
ps = [FlexibleVarKind] -> FlexibleVarKind
RecordFlex ([FlexibleVarKind] -> FlexibleVarKind)
-> MaybeT TCM [FlexibleVarKind] -> MaybeT TCM FlexibleVarKind
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (a -> MaybeT TCM FlexibleVarKind)
-> [a] -> MaybeT TCM [FlexibleVarKind]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM a -> MaybeT TCM FlexibleVarKind
forall a. IsFlexiblePattern a => a -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern [a]
ps

instance IsFlexiblePattern a => IsFlexiblePattern (Arg a) where
  maybeFlexiblePattern :: Arg a -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern = a -> MaybeT TCM FlexibleVarKind
forall a. IsFlexiblePattern a => a -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern (a -> MaybeT TCM FlexibleVarKind)
-> (Arg a -> a) -> Arg a -> MaybeT TCM 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 :: Named name a -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern = a -> MaybeT TCM FlexibleVarKind
forall a. IsFlexiblePattern a => a -> MaybeT TCM FlexibleVarKind
maybeFlexiblePattern (a -> MaybeT TCM FlexibleVarKind)
-> (Named name a -> a)
-> Named name a
-> MaybeT TCM 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 :: 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
^. forall a. Lens' Telescope (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
^. forall a. Lens' (Problem a) (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
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
^. forall a. Lens' [ProblemEq] (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs
  Telescope
tel' <- [ProblemEq] -> Telescope -> TCM Telescope
useNamesFromProblemEqs [ProblemEq]
eqs' Telescope
tel
  LHSState a -> TCM (LHSState a)
forall a. LHSState a -> TCM (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 forall a. Lens' Telescope (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. Lens' (Problem a) (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. Lens' [ProblemEq] (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
  VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
    [ TCM Doc
"updateProblem: equations to update"
    , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ if [ProblemEq] -> Bool
forall a. Null a => a -> Bool
null [ProblemEq]
eqs then TCM Doc
"(none)" else [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ (ProblemEq -> TCM Doc) -> [ProblemEq] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map ProblemEq -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [ProblemEq]
eqs
    ]

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

  VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
    [ TCM Doc
"updateProblem: new equations"
    , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ if [ProblemEq] -> Bool
forall a. Null a => a -> Bool
null [ProblemEq]
eqs' then TCM Doc
"(none)" else [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ (ProblemEq -> TCM Doc) -> [ProblemEq] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map ProblemEq -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [ProblemEq]
eqs'
    ]

  [ProblemEq] -> TCMT IO [ProblemEq]
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)
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 (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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Term -> TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
Term -> m Term
constructorForm TCMT IO Term
-> (Term -> TCMT IO [ProblemEq]) -> TCMT IO [ProblemEq]
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Con ConHead
c ConInfo
ci Elims
es -> do
        let vs :: [Arg Term]
vs = [Arg Term] -> Maybe [Arg Term] -> [Arg Term]
forall a. a -> Maybe a -> a
fromMaybe [Arg Term]
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe [Arg Term] -> [Arg Term]) -> Maybe [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
        -- we should only simplify equations between fully applied constructors
        Maybe ((QName, Type, [Arg Term]), Type)
contype <- ConHead
-> Type -> TCMT IO (Maybe ((QName, Type, [Arg Term]), Type))
forall (m :: * -> *).
(HasConstInfo m, MonadReduce m, MonadDebug m) =>
ConHead -> Type -> m (Maybe ((QName, Type, [Arg Term]), Type))
getFullyAppliedConType ConHead
c (Type -> TCMT IO (Maybe ((QName, Type, [Arg Term]), Type)))
-> TCMT IO Type
-> TCMT IO (Maybe ((QName, Type, [Arg Term]), 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, [Arg Term]), Type)
-> TCMT IO [ProblemEq]
-> (((QName, Type, [Arg Term]), Type) -> TCMT IO [ProblemEq])
-> TCMT IO [ProblemEq]
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe ((QName, Type, [Arg Term]), Type)
contype ([ProblemEq] -> TCMT IO [ProblemEq]
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]) ((((QName, Type, [Arg Term]), Type) -> TCMT IO [ProblemEq])
 -> TCMT IO [ProblemEq])
-> (((QName, Type, [Arg Term]), Type) -> TCMT IO [ProblemEq])
-> TCMT IO [ProblemEq]
forall a b. (a -> b) -> a -> b
$ \((QName
d,Type
_,[Arg Term]
pars),Type
b) -> do
        TelV Telescope
ctel Type
_ <- Type -> TCM (TelV Type)
telViewPath Type
b
        let bs :: [Dom Type]
bs = Telescope -> [Term] -> [Dom Type]
instTel Telescope
ctel ((Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Term
forall e. Arg e -> e
unArg [Arg Term]
vs)

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

            -- Issue #3014: If the constructor is forced but the user wrote a
            -- different constructor,that's an error. We simply keep the
            -- problem equation, this will result in a proper error message later.
            if 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 (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq] else do

            -- Insert implicit patterns
            NAPs Expr
ps <- ExpandHidden -> NAPs Expr -> Telescope -> TCM (NAPs Expr)
insertImplicitPatterns ExpandHidden
ExpandLast NAPs Expr
ps Telescope
ctel
            VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.imp" VerboseLevel
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
              TCM Doc
"insertImplicitPatternsT returned" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ((NamedArg Pattern -> TCM Doc) -> NAPs Expr -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA NAPs Expr
ps)

            -- Check argument count and hiding (not just count: #3074)
            let checkArgs :: [x] -> [a] -> m ()
checkArgs [] [] = () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                checkArgs (x
p : [x]
ps) (a
v : [a]
vs)
                  | x -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding x
p Hiding -> Hiding -> Bool
forall a. Eq a => a -> a -> Bool
== a -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding a
v = [x] -> [a] -> m ()
checkArgs [x]
ps [a]
vs
                  | Bool
otherwise                  = x -> m () -> m ()
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm a
setCurrentRange x
p (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Doc -> m ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
Doc -> m a
genericDocError (Doc -> m ()) -> m Doc -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                      [m Doc] -> m Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ([m Doc] -> m Doc) -> [m Doc] -> m Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey -> [m Doc]
forall (m :: * -> *). Monad m => VerboseKey -> [m Doc]
pwords (VerboseKey
"Expected an " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Hiding -> VerboseKey
forall p. IsString p => Hiding -> p
which (a -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding a
v) VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseKey
" argument " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++
                                     VerboseKey
"instead of "  VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Hiding -> VerboseKey
forall p. IsString p => Hiding -> p
which (x -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding x
p) VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseKey
" argument") [m Doc] -> [m Doc] -> [m Doc]
forall a. [a] -> [a] -> [a]
++
                             [ x -> m Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA x
p ]
                  where which :: Hiding -> p
which Hiding
NotHidden  = p
"explicit"
                        which Hiding
Hidden     = p
"implicit"
                        which Instance{} = p
"instance"
                checkArgs [] [a]
vs = Doc -> m ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
Doc -> m a
genericDocError (Doc -> m ()) -> m Doc -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                    [m Doc] -> m Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ([m Doc] -> m Doc) -> [m Doc] -> m Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey -> [m Doc]
forall (m :: * -> *). Monad m => VerboseKey -> [m Doc]
pwords VerboseKey
"Too few arguments to constructor" [m Doc] -> [m Doc] -> [m Doc]
forall a. [a] -> [a] -> [a]
++ [ConHead -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ConHead
c m Doc -> m Doc -> m Doc
forall a. Semigroup a => a -> a -> a
<> m Doc
","] [m Doc] -> [m Doc] -> [m Doc]
forall a. [a] -> [a] -> [a]
++
                           VerboseKey -> [m Doc]
forall (m :: * -> *). Monad m => VerboseKey -> [m Doc]
pwords (VerboseKey
"expected " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseLevel -> VerboseKey
forall a. Show a => a -> VerboseKey
show VerboseLevel
n VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseKey
" more explicit "  VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseKey
arguments)
                  where n :: VerboseLevel
n = [a] -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length ((a -> Bool) -> [a] -> [a]
forall a. (a -> Bool) -> [a] -> [a]
filter a -> Bool
forall a. LensHiding a => a -> Bool
visible [a]
vs)
                        arguments :: VerboseKey
arguments | VerboseLevel
n VerboseLevel -> VerboseLevel -> Bool
forall a. Eq a => a -> a -> Bool
== VerboseLevel
1    = VerboseKey
"argument"
                                  | Bool
otherwise = VerboseKey
"arguments"
                checkArgs (x
p : [x]
_) [] = x -> m () -> m ()
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm a
setCurrentRange x
p (m () -> m ()) -> m () -> m ()
forall a b. (a -> b) -> a -> b
$ Doc -> m ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
Doc -> m a
genericDocError (Doc -> m ()) -> m Doc -> m ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                  [m Doc] -> m Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ([m Doc] -> m Doc) -> [m Doc] -> m Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey -> [m Doc]
forall (m :: * -> *). Monad m => VerboseKey -> [m Doc]
pwords VerboseKey
"Too many arguments to constructor" [m Doc] -> [m Doc] -> [m Doc]
forall a. [a] -> [a] -> [a]
++ [ConHead -> m Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ConHead
c]
            NAPs Expr -> [Arg Term] -> TCMT IO ()
forall (m :: * -> *) x a c.
(LensHiding x, MonadTCM m, HasRange x, MonadError TCErr m,
 Pretty c, ToConcrete x c, MonadStConcreteNames m, HasBuiltins m,
 Semigroup (m Doc), MonadReduce m, MonadAddContext m,
 MonadInteractionPoints m, MonadFresh NameId m, HasConstInfo m,
 IsString (m Doc), Null (m Doc), LensHiding a) =>
[x] -> [a] -> m ()
checkArgs NAPs Expr
ps [Arg Term]
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) -> NAPs Expr -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> Pattern
forall a. NamedArg a -> a
namedArg NAPs Expr
ps) ((Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Term
forall e. Arg e -> e
unArg [Arg Term]
vs) [Dom Type]
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 (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.
            NAPs Expr
ps <- QName
-> (Name -> Pattern)
-> [FieldAssignment' Pattern]
-> [Arg Name]
-> TCM (NAPs Expr)
forall a.
QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFields 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.
            NAPs Expr
ps <- ExpandHidden -> NAPs Expr -> Telescope -> TCM (NAPs Expr)
insertImplicitPatterns ExpandHidden
ExpandLast NAPs Expr
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) -> NAPs Expr -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> Pattern
forall a. NamedArg a -> a
namedArg NAPs Expr
ps) ((Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Term
forall e. Arg e -> e
unArg [Arg Term]
vs) [Dom Type]
bs
            [ProblemEq] -> TCMT IO [ProblemEq]
updates [ProblemEq]
eqs

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

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

      Term
_ | A.EqualP{} <- Pattern
p -> do
        Term
itisone <- TCMT IO Term -> TCMT IO Term
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
        TCM 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 () -> TCM Bool
forall (m :: * -> *).
(MonadConstraint m, MonadWarning m, MonadError TCErr m,
 MonadFresh ProblemId m) =>
m () -> m Bool
tryConversion (TCMT IO () -> TCM Bool) -> TCMT IO () -> TCM 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 (m :: * -> *) a. Monad m => a -> m a
return []) ([ProblemEq] -> TCMT IO [ProblemEq]
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq])

      Term
_ -> [ProblemEq] -> TCMT IO [ProblemEq]
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 -> Term -> Telescope
forall t a. Subst t a => Abs a -> t -> a
absApp Abs Telescope
tel Term
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 :: Problem a -> Bool
isSolvedProblem Problem a
problem = NAPs Expr -> Bool
forall a. Null a => a -> Bool
null (Problem a
problem Problem a -> Lens' (NAPs Expr) (Problem a) -> NAPs Expr
forall o i. o -> Lens' i o -> i
^. forall a. Lens' (NAPs Expr) (Problem a)
Lens' (NAPs Expr) (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 :: 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 -> Pattern) -> Pattern -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Name], Pattern) -> Pattern
forall a b. (a, b) -> b
snd (([Name], Pattern) -> Pattern)
-> (Pattern -> ([Name], Pattern)) -> Pattern -> Pattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Pattern -> ([Name], Pattern)
asView) ([Pattern] -> Bool) -> [Pattern] -> Bool
forall a b. (a -> b) -> a -> b
$
      (NamedArg Pattern -> Pattern) -> NAPs Expr -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> Pattern
forall a. NamedArg a -> a
namedArg (Problem a
problem Problem a -> Lens' (NAPs Expr) (Problem a) -> NAPs Expr
forall o i. o -> Lens' i o -> i
^. forall a. Lens' (NAPs Expr) (Problem a)
Lens' (NAPs Expr) (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
    -- impossible:
    isSolved A.ProjP{}       = Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
    isSolved A.DefP{}        = Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
    isSolved A.AsP{}         = Bool
forall a. HasCallStack => a
__IMPOSSIBLE__  -- removed by asView
    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 (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 ([Name], Pattern) -> Pattern
forall a b. (a, b) -> b
snd (([Name], Pattern) -> Pattern) -> ([Name], Pattern) -> Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> ([Name], Pattern)
asView Pattern
p of
   A.WildP       {} -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   A.AbsurdP     {} -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   A.DotP        {} -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   A.EqualP      {} -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
   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.AsP         {} -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__ -- removed by asView
   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
    VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.shadow" VerboseLevel
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
      [ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"checking whether pattern variable " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Name -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow Name
x VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseKey
" shadows a constructor"
      , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"type of variable =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
a
      , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"position of variable =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc)
-> (Range -> VerboseKey) -> Range -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Range -> VerboseKey
forall a. Show a => a -> VerboseKey
show) (Name -> Range
forall t. HasRange t => t -> Range
getRange Name
x)
      ]
    VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.shadow" VerboseLevel
70 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"a =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall (m :: * -> *) a. (Monad 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 (m :: * -> *) a. Monad m => a -> m a
return ()
              (QName
c : [QName]
_) -> Name -> TCMT IO () -> TCMT IO ()
forall (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 (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 (m :: * -> *) a. Monad m => a -> m a
return ()
          DataOrRecSig{} -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Function    {} -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
          Record      {} -> () -> TCMT IO ()
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 (m :: * -> *) a. Monad m => a -> m a
return ()
      Var   {} -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Pi    {} -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      Sort  {} -> () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      MetaV {} -> () -> TCMT IO ()
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 VerboseKey
s Elims
_  -> VerboseKey -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
VerboseKey -> m a
__IMPOSSIBLE_VERBOSE__ VerboseKey
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 (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm 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
  VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.dot" VerboseLevel
15 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep [ TCM Doc
"checking dot pattern"
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Expr -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA Expr
e
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"=" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
v
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
":" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
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
    VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.dot" VerboseLevel
50 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
      [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep [ TCM Doc
"equalTerm"
          , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Type -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty Type
a
          , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Term -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty Term
u
          , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Term -> TCM Doc
forall (m :: * -> *) a. (Monad 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
r Type
a) = Range -> Type -> TCMT IO ()
ensureEmptyType Range
r Type
a

-- | 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 :: NAPs Expr
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transferOrigins NAPs Expr
ps [NamedArg DeBruijnPattern]
qs = do
  VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.origin" VerboseLevel
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
    [ TCM Doc
"transferOrigins"
    , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
      [ TCM Doc
"ps  =   " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> NAPs Expr -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA NAPs Expr
ps
      , TCM Doc
"qs  =   " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg DeBruijnPattern] -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
qs
      ]
    ]
  NAPs Expr
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers NAPs Expr
ps [NamedArg DeBruijnPattern]
qs

  where
    transfers :: [NamedArg A.Pattern]
              -> [NamedArg DeBruijnPattern]
              -> TCM [NamedArg DeBruijnPattern]
    transfers :: NAPs Expr
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [] [NamedArg DeBruijnPattern]
qs
      | (NamedArg DeBruijnPattern -> Bool)
-> [NamedArg DeBruijnPattern] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all NamedArg DeBruijnPattern -> Bool
forall a. LensHiding a => a -> Bool
notVisible [NamedArg DeBruijnPattern]
qs = [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
forall (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 : NAPs Expr
ps) [] = TCM [NamedArg DeBruijnPattern]
forall a. HasCallStack => a
__IMPOSSIBLE__
    transfers (NamedArg Pattern
p : NAPs Expr
ps) (NamedArg DeBruijnPattern
q : [NamedArg DeBruijnPattern]
qs)
      | NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
matchingArgs NamedArg Pattern
p NamedArg DeBruijnPattern
q = do
          NamedArg DeBruijnPattern
q' <- (Maybe (WithOrigin (Ranged VerboseKey))
 -> Maybe (WithOrigin (Ranged VerboseKey)))
-> NamedArg DeBruijnPattern -> NamedArg DeBruijnPattern
forall name a.
LensNamed name a =>
(Maybe name -> Maybe name) -> a -> a
mapNameOf ((Maybe (WithOrigin (Ranged VerboseKey))
 -> Maybe (WithOrigin (Ranged VerboseKey)))
-> (WithOrigin (Ranged VerboseKey)
    -> Maybe (WithOrigin (Ranged VerboseKey))
    -> Maybe (WithOrigin (Ranged VerboseKey)))
-> Maybe (WithOrigin (Ranged VerboseKey))
-> Maybe (WithOrigin (Ranged VerboseKey))
-> Maybe (WithOrigin (Ranged VerboseKey))
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Maybe (WithOrigin (Ranged VerboseKey))
-> Maybe (WithOrigin (Ranged VerboseKey))
forall a. a -> a
id (Maybe (WithOrigin (Ranged VerboseKey))
-> Maybe (WithOrigin (Ranged VerboseKey))
-> Maybe (WithOrigin (Ranged VerboseKey))
forall a b. a -> b -> a
const (Maybe (WithOrigin (Ranged VerboseKey))
 -> Maybe (WithOrigin (Ranged VerboseKey))
 -> Maybe (WithOrigin (Ranged VerboseKey)))
-> (WithOrigin (Ranged VerboseKey)
    -> Maybe (WithOrigin (Ranged VerboseKey)))
-> WithOrigin (Ranged VerboseKey)
-> Maybe (WithOrigin (Ranged VerboseKey))
-> Maybe (WithOrigin (Ranged VerboseKey))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. WithOrigin (Ranged VerboseKey)
-> Maybe (WithOrigin (Ranged VerboseKey))
forall a. a -> Maybe a
Just) (Maybe (WithOrigin (Ranged VerboseKey))
 -> Maybe (WithOrigin (Ranged VerboseKey))
 -> Maybe (WithOrigin (Ranged VerboseKey)))
-> Maybe (WithOrigin (Ranged VerboseKey))
-> Maybe (WithOrigin (Ranged VerboseKey))
-> Maybe (WithOrigin (Ranged VerboseKey))
forall a b. (a -> b) -> a -> b
$ NamedArg Pattern -> Maybe (WithOrigin (Ranged VerboseKey))
forall name a. LensNamed name a => a -> Maybe name
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 (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
 -> TCMT
      IO (Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern))
-> NamedArg DeBruijnPattern -> TCMT IO (NamedArg DeBruijnPattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
  -> TCMT
       IO (Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern))
 -> NamedArg DeBruijnPattern -> TCMT IO (NamedArg DeBruijnPattern))
-> (Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
    -> TCMT
         IO (Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern))
-> NamedArg DeBruijnPattern
-> TCMT IO (NamedArg DeBruijnPattern)
forall a b. (a -> b) -> a -> b
$ (DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
-> TCMT IO (Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ((DeBruijnPattern -> TCMT IO DeBruijnPattern)
 -> Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
 -> TCMT
      IO (Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern))
-> (DeBruijnPattern -> TCMT IO DeBruijnPattern)
-> Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
-> TCMT IO (Named (WithOrigin (Ranged VerboseKey)) 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
<$> NAPs Expr
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers NAPs Expr
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
<$> NAPs Expr
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers (NamedArg Pattern
p NamedArg Pattern -> NAPs Expr -> NAPs Expr
forall a. a -> [a] -> [a]
: NAPs Expr
ps) [NamedArg DeBruijnPattern]
qs

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

      (([Name]
asB , A.ConP ConPatInfo
pi AmbiguousQName
_ NAPs Expr
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
<$> NAPs Expr
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers NAPs Expr
ps [NamedArg DeBruijnPattern]
qs

      (([Name]
asB , 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
        NAPs Expr
ps <- QName
-> (Name -> Pattern)
-> [FieldAssignment' Pattern]
-> [Arg Name]
-> TCM (NAPs Expr)
forall a.
QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFields 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
<$> NAPs Expr
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers NAPs Expr
ps [NamedArg DeBruijnPattern]
qs

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

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

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

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

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

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

    matchingArgs :: NamedArg A.Pattern -> NamedArg DeBruijnPattern -> Bool
    matchingArgs :: NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
matchingArgs NamedArg Pattern
p NamedArg DeBruijnPattern
q
      -- The arguments match if
      -- 1. they are both projections,
      | Maybe (ProjOrigin, AmbiguousQName) -> Bool
forall a. Maybe a -> Bool
isJust (NamedArg Pattern -> Maybe (ProjOrigin, AmbiguousQName)
forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
A.isProjP NamedArg Pattern
p) = Maybe (ProjOrigin, AmbiguousQName) -> Bool
forall a. Maybe a -> Bool
isJust (NamedArg DeBruijnPattern -> Maybe (ProjOrigin, AmbiguousQName)
forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
isProjP NamedArg DeBruijnPattern
q)
      -- 2. or they are both visible,
      | NamedArg Pattern -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Pattern
p Bool -> Bool -> Bool
&& NamedArg DeBruijnPattern -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg DeBruijnPattern
q = Bool
True
      -- 3. or they have the same hiding and the argument is not named,
      | NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding NamedArg Pattern
p NamedArg DeBruijnPattern
q Bool -> Bool -> Bool
&& Maybe (WithOrigin (Ranged VerboseKey)) -> Bool
forall a. Maybe a -> Bool
isNothing (NamedArg Pattern -> Maybe (WithOrigin (Ranged VerboseKey))
forall name a. LensNamed name a => a -> Maybe name
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 (WithOrigin (Ranged VerboseKey)) a,
 LensNamed (WithOrigin (Ranged VerboseKey)) b) =>
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
  VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.linear" VerboseLevel
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"Checking linearity of pattern variables"
  Map BindName Term -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName Term
forall k a. Map k a
Map.empty [ProblemEq]
eqs
  where
    check :: Map A.BindName Term -> [ProblemEq] -> TCM [ProblemEq]
    check :: Map BindName Term -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName Term
_ [] = [ProblemEq] -> TCMT IO [ProblemEq]
forall (m :: * -> *) a. Monad m => a -> m a
return []
    check Map BindName Term
vars (eq :: ProblemEq
eq@(ProblemEq Pattern
p Term
u Dom Type
a) : [ProblemEq]
eqs) = do
      VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.linear" VerboseLevel
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
        [ TCM Doc
"linearity: checking pattern "
        , Pattern -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
p
        , TCM Doc
" equal to term "
        , Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
u
        ]
      case Pattern
p of
        A.VarP BindName
x -> do
          VerboseKey -> VerboseLevel -> VerboseKey -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.lhs.linear" VerboseLevel
60 (VerboseKey -> TCMT IO ()) -> VerboseKey -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
            let y :: Name
y = BindName -> Name
A.unBind BindName
x
            in VerboseKey
"pattern variable " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Name -> VerboseKey
forall a. Show a => a -> VerboseKey
show (Name -> Name
A.nameConcrete Name
y) VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ VerboseKey
" with id " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ NameId -> VerboseKey
forall a. Show a => a -> VerboseKey
show (Name -> NameId
A.nameId Name
y)
          case BindName -> Map BindName Term -> Maybe Term
forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BindName
x Map BindName Term
vars of
            Just Term
v -> do
              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 -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName Term
vars [ProblemEq]
eqs
            Maybe Term
Nothing -> (ProblemEq
eqProblemEq -> [ProblemEq] -> [ProblemEq]
forall a. a -> [a] -> [a]
:) ([ProblemEq] -> [ProblemEq])
-> TCMT IO [ProblemEq] -> TCMT IO [ProblemEq]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
              Map BindName Term -> [ProblemEq] -> TCMT IO [ProblemEq]
check (BindName -> Term -> Map BindName Term -> Map BindName Term
forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BindName
x Term
u Map BindName Term
vars) [ProblemEq]
eqs
        A.AsP PatInfo
_ BindName
x Pattern
p ->
          Map BindName Term -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName Term
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.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 -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName Term
vars [ProblemEq]
eqs

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

    dummyName :: p -> VerboseKey -> m Name
dummyName p
taken VerboseKey
s =
      if VerboseKey -> Bool
forall a. Underscore a => a -> Bool
isUnderscore VerboseKey
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
<$> VerboseKey -> m Name
forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
freshName_ (VerboseKey -> VerboseKey
argNameToString VerboseKey
s)

-- | Bind as patterns
bindAsPatterns :: [AsBinding] -> TCM a -> TCM a
bindAsPatterns :: [AsBinding] -> TCM a -> TCM a
bindAsPatterns []                TCM a
ret = TCM a
ret
bindAsPatterns (AsB Name
x Term
v Type
a : [AsBinding]
asb) TCM a
ret = do
  VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.as" VerboseLevel
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"as pattern" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Name -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Name
x TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>
    [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep [ TCM Doc
":" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
a
        , TCM Doc
"=" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
v
        ]
  ArgInfo -> Name -> Term -> Type -> TCM a -> TCM a
forall (m :: * -> *) a.
MonadAddContext m =>
ArgInfo -> Name -> Term -> Type -> m a -> m a
addLetBinding 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 e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \TCErr
_ -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 ()) -> TCM Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
    [ TCM Doc
"Ill-typed pattern after with abstraction: " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Pattern -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
p
    , TCM Doc
"(perhaps you can replace it by `_`?)"
    ]

-- | Result of checking the LHS of a clause.
data LHSResult = LHSResult
  { LHSResult -> VerboseLevel
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?
  }

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

-- | 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 :: Call
-> Maybe QName
-> NAPs Expr
-> Type
-> Maybe Substitution
-> [ProblemEq]
-> (LHSResult -> TCM a)
-> TCM a
checkLeftHandSide Call
call Maybe QName
f NAPs Expr
ps Type
a Maybe Substitution
withSub' [ProblemEq]
strippedPats =
 Account Phase
-> ((LHSResult -> TCM a) -> TCM a) -> (LHSResult -> TCM a) -> TCM a
forall a (m :: * -> *) b c.
MonadBench a m =>
Account a -> ((b -> m c) -> m c) -> (b -> m c) -> m c
Bench.billToCPS [Phase
Bench.Typing, Phase
Bench.CheckLHS] (((LHSResult -> TCM a) -> TCM a) -> (LHSResult -> TCM a) -> TCM a)
-> ((LHSResult -> TCM a) -> TCM a) -> (LHSResult -> TCM a) -> TCM a
forall a b. (a -> b) -> a -> b
$
 Call
-> ((LHSResult -> TCM a) -> TCM a) -> (LHSResult -> TCM a) -> TCM a
forall (tcm :: * -> *) a b.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> ((a -> tcm b) -> tcm b) -> (a -> tcm b) -> tcm b
traceCallCPS Call
call (((LHSResult -> TCM a) -> TCM a) -> (LHSResult -> TCM a) -> TCM a)
-> ((LHSResult -> TCM a) -> TCM a) -> (LHSResult -> TCM a) -> TCM a
forall a b. (a -> b) -> a -> b
$ \ LHSResult -> TCM 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 <- (Dom (Name, Type) -> Dom (Name, Type)) -> Context -> Context
forall a b. (a -> b) -> [a] -> [b]
map (Origin -> Dom (Name, Type) -> Dom (Name, Type)
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 -> VerboseKey) -> Context -> Telescope
forall a. (a -> VerboseKey) -> ListTel' a -> Telescope
telFromList' Name -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow Context
cxt
      cps :: [Arg (Named name (Pattern' e))]
cps = [ Pattern' e -> Named name (Pattern' e)
forall a name. a -> Named name a
unnamed (Pattern' e -> Named name (Pattern' e))
-> ((Name, Type) -> Pattern' e)
-> (Name, Type)
-> Named name (Pattern' e)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. BindName -> Pattern' e
forall e. BindName -> Pattern' e
A.VarP (BindName -> Pattern' e)
-> ((Name, Type) -> BindName) -> (Name, Type) -> Pattern' e
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 name (Pattern' e))
-> Arg (Name, Type) -> Arg (Named name (Pattern' e))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Dom (Name, Type) -> Arg (Name, Type)
forall t a. Dom' t a -> Arg a
argFromDom Dom (Name, Type)
d
            | Dom (Name, Type)
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) -> NAPs Expr -> [Pattern]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Pattern -> Pattern
forall a. NamedArg a -> a
namedArg NAPs Expr
forall name e. [Arg (Named name (Pattern' e))]
cps) ((VerboseLevel -> Term) -> [VerboseLevel] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map VerboseLevel -> Term
var ([VerboseLevel] -> [Term]) -> [VerboseLevel] -> [Term]
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> [VerboseLevel]
forall a. Integral a => a -> [a]
downFrom (VerboseLevel -> [VerboseLevel]) -> VerboseLevel -> [VerboseLevel]
forall a b. (a -> b) -> a -> b
$ Telescope -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
size Telescope
tel) (Telescope -> [Dom Type]
forall a. Subst Term a => Tele (Dom a) -> [Dom a]
flattenTel Telescope
tel)

  let finalChecks :: LHSState a -> TCM a
      finalChecks :: LHSState a -> TCM a
finalChecks (LHSState Telescope
delta [NamedArg DeBruijnPattern]
qs0 (Problem [ProblemEq]
eqs NAPs Expr
rps LHSState a -> TCM a
_) Arg Type
b [Maybe VerboseLevel]
psplit) = do

        VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
          [ TCM Doc
"lhs: final checks with remaining equations"
          , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ if [ProblemEq] -> Bool
forall a. Null a => a -> Bool
null [ProblemEq]
eqs then TCM Doc
"(none)" else Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ (ProblemEq -> TCM Doc) -> [ProblemEq] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map ProblemEq -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [ProblemEq]
eqs
          , TCM Doc
"qs0 =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta ([NamedArg DeBruijnPattern] -> TCM 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 (NAPs Expr -> Bool
forall a. Null a => a -> Bool
null NAPs Expr
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
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
          [NamedArg DeBruijnPattern] -> TCMT IO ()
noPatternMatchingOnCodata [NamedArg DeBruijnPattern]
qs0

        -- Compute substitution from the out patterns @qs0@
        let notProj :: Pattern' x -> Bool
notProj ProjP{} = Bool
False
            notProj Pattern' x
_       = Bool
True
            numPats :: VerboseLevel
numPats  = [NamedArg DeBruijnPattern] -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length ([NamedArg DeBruijnPattern] -> VerboseLevel)
-> [NamedArg DeBruijnPattern] -> VerboseLevel
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' = VerboseLevel -> Substitution -> Substitution
forall a. VerboseLevel -> Substitution' a -> Substitution' a
wkS (VerboseLevel -> VerboseLevel -> VerboseLevel
forall a. Ord a => a -> a -> a
max VerboseLevel
0 (VerboseLevel -> VerboseLevel) -> VerboseLevel -> VerboseLevel
forall a b. (a -> b) -> a -> b
$ VerboseLevel
numPats VerboseLevel -> VerboseLevel -> VerboseLevel
forall a. Num a => a -> a -> a
- Type -> VerboseLevel
arity Type
a) Substitution
forall a. Substitution' a
idS -- if numPats < arity, Θ is empty
                    | Bool
otherwise       = VerboseLevel -> Substitution -> Substitution
forall a. VerboseLevel -> Substitution' a -> Substitution' a
wkS (VerboseLevel
numPats VerboseLevel -> VerboseLevel -> VerboseLevel
forall a. Num a => a -> a -> a
- Context -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
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] -> [Term])
-> [NamedArg DeBruijnPattern] -> [Term]
forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. [a] -> [a]
reverse ([NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ VerboseLevel
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall a. VerboseLevel -> [a] -> [a]
take VerboseLevel
numPats [NamedArg DeBruijnPattern]
qs0) [Term] -> Substitution -> Substitution
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# (Empty -> Substitution
forall a. Empty -> Substitution' a
EmptyS Empty
forall a. HasCallStack => a
__IMPOSSIBLE__)
            paramSub :: Substitution
paramSub = Substitution
patSub Substitution -> Substitution -> Substitution
forall a.
Subst a a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Substitution
weakSub Substitution -> Substitution -> Substitution
forall a.
Subst a 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
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 [Pattern]
otherPats)
          <- Telescope -> TCMT IO LeftoverPatterns -> TCMT IO LeftoverPatterns
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> 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
getLeftoverPatterns [ProblemEq]
eqs

        VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.leftover" VerboseLevel
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
          [ TCM Doc
"leftover patterns: " , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ LeftoverPatterns -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> 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 -> VerboseLevel -> DeBruijnPattern
makeVar     = (VerboseLevel -> DeBruijnPattern)
-> (Name -> VerboseLevel -> DeBruijnPattern)
-> Maybe Name
-> VerboseLevel
-> DeBruijnPattern
forall b a. b -> (a -> b) -> Maybe a -> b
maybe VerboseLevel -> DeBruijnPattern
forall a. DeBruijn a => VerboseLevel -> a
deBruijnVar ((Name -> VerboseLevel -> DeBruijnPattern)
 -> Maybe Name -> VerboseLevel -> DeBruijnPattern)
-> (Name -> VerboseLevel -> DeBruijnPattern)
-> Maybe Name
-> VerboseLevel
-> DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ VerboseKey -> VerboseLevel -> DeBruijnPattern
forall a. DeBruijn a => VerboseKey -> VerboseLevel -> a
debruijnNamedVar (VerboseKey -> VerboseLevel -> DeBruijnPattern)
-> (Name -> VerboseKey) -> Name -> VerboseLevel -> DeBruijnPattern
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> VerboseKey
nameToArgName
            ren :: Substitution' DeBruijnPattern
ren         = [DeBruijnPattern] -> Substitution' DeBruijnPattern
forall a. DeBruijn a => [a] -> Substitution' a
parallelS ([DeBruijnPattern] -> Substitution' DeBruijnPattern)
-> [DeBruijnPattern] -> Substitution' DeBruijnPattern
forall a b. (a -> b) -> a -> b
$ (Maybe Name -> VerboseLevel -> DeBruijnPattern)
-> [Maybe Name] -> [VerboseLevel] -> [DeBruijnPattern]
forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe Name -> VerboseLevel -> DeBruijnPattern
makeVar ([Maybe Name] -> [Maybe Name]
forall a. [a] -> [a]
reverse [Maybe Name]
vars) [VerboseLevel
0..]

        [NamedArg DeBruijnPattern]
qs <- NAPs Expr
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transferOrigins (NAPs Expr
forall name e. [Arg (Named name (Pattern' e))]
cps NAPs Expr -> NAPs Expr -> NAPs Expr
forall a. [a] -> [a] -> [a]
++ NAPs Expr
ps) ([NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern])
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
forall a b. (a -> b) -> a -> b
$ Substitution' DeBruijnPattern
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall t a. Subst t a => Substitution' t -> a -> a
applySubst Substitution' 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 = VerboseLevel
-> Telescope
-> [NamedArg DeBruijnPattern]
-> Bool
-> Arg Type
-> Substitution
-> [AsBinding]
-> IntSet
-> LHSResult
LHSResult (Context -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length Context
cxt) Telescope
delta [NamedArg DeBruijnPattern]
qs Bool
hasAbsurd Arg Type
b Substitution
patSub [AsBinding]
asb ([VerboseLevel] -> IntSet
IntSet.fromList ([VerboseLevel] -> IntSet) -> [VerboseLevel] -> IntSet
forall a b. (a -> b) -> a -> b
$ [Maybe VerboseLevel] -> [VerboseLevel]
forall a. [Maybe a] -> [a]
catMaybes [Maybe VerboseLevel]
psplit)

        -- Debug output
        VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
          [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat [ TCM Doc
"checked lhs:"
               , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
                 [ TCM Doc
"delta   = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta
                 , TCM Doc
"dots    = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc -> [TCM Doc] -> [TCM Doc]
forall (m :: * -> *).
(Applicative m, Semigroup (m Doc)) =>
m Doc -> [m Doc] -> [m Doc]
punctuate TCM Doc
forall (m :: * -> *). Monad m => m Doc
comma ([TCM Doc] -> [TCM Doc]) -> [TCM Doc] -> [TCM Doc]
forall a b. (a -> b) -> a -> b
$ (DotPattern -> TCM Doc) -> [DotPattern] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map DotPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [DotPattern]
dots)
                 , TCM Doc
"asb     = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc -> [TCM Doc] -> [TCM Doc]
forall (m :: * -> *).
(Applicative m, Semigroup (m Doc)) =>
m Doc -> [m Doc] -> [m Doc]
punctuate TCM Doc
forall (m :: * -> *). Monad m => m Doc
comma ([TCM Doc] -> [TCM Doc]) -> [TCM Doc] -> [TCM Doc]
forall a b. (a -> b) -> a -> b
$ (AsBinding -> TCM Doc) -> [AsBinding] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map AsBinding -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [AsBinding]
asb)
                 , TCM Doc
"absurds = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc -> [TCM Doc] -> [TCM Doc]
forall (m :: * -> *).
(Applicative m, Semigroup (m Doc)) =>
m Doc -> [m Doc] -> [m Doc]
punctuate TCM Doc
forall (m :: * -> *). Monad m => m Doc
comma ([TCM Doc] -> [TCM Doc]) -> [TCM Doc] -> [TCM Doc]
forall a b. (a -> b) -> a -> b
$ (AbsurdPattern -> TCM Doc) -> [AbsurdPattern] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map AbsurdPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [AbsurdPattern]
absurds)
                 , TCM Doc
"qs      = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta ([TCM Doc] -> TCM Doc
forall (m :: * -> *).
(Monad m, Semigroup (m Doc)) =>
[m Doc] -> m Doc
prettyList ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ (NamedArg DeBruijnPattern -> TCM Doc)
-> [NamedArg DeBruijnPattern] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg DeBruijnPattern -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
qs)
                 ]
               ]
        VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
          VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
                 [ TCM Doc
"vars   = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text ([Maybe Name] -> VerboseKey
forall a. Show a => a -> VerboseKey
show [Maybe Name]
vars)
                 ]
        VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"withSub  = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty Substitution
withSub
        VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"weakSub  = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty Substitution
weakSub
        VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"patSub   = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty Substitution
patSub
        VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"paramSub = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution -> TCM Doc
forall (m :: * -> *) a. (Monad 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) -> TCM a -> TCM 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) (TCM a -> TCM a) -> TCM a -> TCM a
forall a b. (a -> b) -> a -> b
$ do

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

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

  LHSState a
st0 <- Telescope
-> [ProblemEq]
-> NAPs Expr
-> Type
-> (LHSState a -> TCM a)
-> TCM (LHSState a)
forall a.
Telescope
-> [ProblemEq]
-> NAPs Expr
-> Type
-> (LHSState a -> TCM a)
-> TCM (LHSState a)
initLHSState Telescope
tel [ProblemEq]
eqs0 NAPs Expr
ps Type
a LHSState a -> TCM 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 -> [ProblemEq] -> [ProblemEq]
forall t a. Subst t a => Substitution' t -> a -> a
applySubst Substitution
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
addContext (LHSState a
st0 LHSState a -> Lens' Telescope (LHSState a) -> Telescope
forall o i. o -> Lens' i o -> i
^. forall a. Lens' Telescope (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. Lens' (Problem a) (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. Lens' [ProblemEq] (Problem a)
problemEqs) ([ProblemEq] -> [ProblemEq] -> [ProblemEq]
forall a. [a] -> [a] -> [a]
++ [ProblemEq]
withEqs) LHSState a
st0

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

-- | Determine which splits should be tried.
splitStrategy :: [ProblemEq] -> [ProblemEq]
splitStrategy :: [ProblemEq] -> [ProblemEq]
splitStrategy = (ProblemEq -> Bool) -> [ProblemEq] -> [ProblemEq]
forall a. (a -> Bool) -> [a] -> [a]
filter ProblemEq -> Bool
shouldSplit
  where
    shouldSplit :: ProblemEq -> Bool
    shouldSplit :: ProblemEq -> Bool
shouldSplit (ProblemEq Pattern
p Term
v Dom Type
a) = case ([Name], Pattern) -> Pattern
forall a b. (a, b) -> b
snd (([Name], Pattern) -> Pattern) -> ([Name], Pattern) -> Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> ([Name], Pattern)
asView 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.ProjP{}       -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
      A.DefP{}        -> Bool
forall a. HasCallStack => a
__IMPOSSIBLE__
      A.AsP{}         -> 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, MonadReduce tcm, MonadAddContext tcm, MonadWriter Blocked_ tcm, HasConstInfo tcm, MonadError TCErr tcm, MonadDebug tcm, MonadReader Nat tcm)
  => Maybe QName      -- ^ The name of the definition we are checking.
  -> LHSState a       -- ^ The current state.
  -> tcm a
checkLHS :: 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 VerboseLevel]
psplit) = 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 (VerboseKey, Type)] (LHSState a)
-> LensMap [Dom (VerboseKey, Type)] (LHSState a)
forall i o. Lens' i o -> LensMap i o
over ((Telescope -> f Telescope) -> LHSState a -> f (LHSState a)
forall a. Lens' Telescope (LHSState a)
lhsTel ((Telescope -> f Telescope) -> LHSState a -> f (LHSState a))
-> (([Dom (VerboseKey, Type)] -> f [Dom (VerboseKey, Type)])
    -> Telescope -> f Telescope)
-> ([Dom (VerboseKey, Type)] -> f [Dom (VerboseKey, Type)])
-> LHSState a
-> f (LHSState a)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ([Dom (VerboseKey, Type)] -> f [Dom (VerboseKey, Type)])
-> Telescope -> f Telescope
Lens' [Dom (VerboseKey, Type)] Telescope
listTel) ((Dom (VerboseKey, Type) -> Dom (VerboseKey, Type))
-> [Dom (VerboseKey, Type)] -> [Dom (VerboseKey, Type)]
forall a b. (a -> b) -> [a] -> [b]
map ((Dom (VerboseKey, Type) -> Dom (VerboseKey, Type))
 -> [Dom (VerboseKey, Type)] -> [Dom (VerboseKey, Type)])
-> (Dom (VerboseKey, Type) -> Dom (VerboseKey, Type))
-> [Dom (VerboseKey, Type)]
-> [Dom (VerboseKey, Type)]
forall a b. (a -> b) -> a -> b
$ Modality -> Dom (VerboseKey, Type) -> Dom (VerboseKey, Type)
forall a. LensModality a => Modality -> a -> a
inverseApplyModality 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 VerboseLevel]
psplit) = do

  if Problem a -> Bool
forall a. Problem a -> Bool
isSolvedProblem Problem a
problem then
    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
^. forall a. Lens' (LHSState a -> TCM a) (Problem a)
Lens' (LHSState a -> TCM a) (Problem a)
problemCont) LHSState a
st
  else do

    VerboseKey -> VerboseLevel -> TCM Doc -> tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
30 (TCM Doc -> tcm ()) -> TCM Doc -> tcm ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
      [ TCM Doc
"LHS state: " , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (LHSState a -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => 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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> tcm ()) -> TypeError -> tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TypeError
GenericError (VerboseKey -> TypeError) -> VerboseKey -> TypeError
forall a b. (a -> b) -> a -> b
$ VerboseKey
"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
^. forall a. Lens' [ProblemEq] (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 (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 (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, MonadReduce tcm, MonadAddContext tcm,
 MonadWriter (Blocked ()) tcm, HasConstInfo tcm,
 MonadError TCErr tcm, MonadDebug tcm,
 MonadReader VerboseLevel 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 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 (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 (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 (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' (NAPs Expr) (Problem a) -> NAPs Expr
forall o i. o -> Lens' i o -> i
^. forall a. Lens' (NAPs Expr) (Problem a)
Lens' (NAPs Expr) (Problem a)
problemRestPats of
      []    -> Either [TCErr] (LHSState a) -> tcm (Either [TCErr] (LHSState 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:NAPs Expr
_) -> (TCErr -> [TCErr])
-> Either TCErr (LHSState a) -> Either [TCErr] (LHSState a)
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 (tcm :: * -> *) a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm) =>
Call -> tcm a -> tcm 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

      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
30 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
        [ TCM Doc
"split looking at pattern"
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"p =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Pattern -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
p
        ]

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

      let pos :: VerboseLevel
pos = Telescope -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
size Telescope
tel VerboseLevel -> VerboseLevel -> VerboseLevel
forall a. Num a => a -> a -> a
- (VerboseLevel
iVerboseLevel -> VerboseLevel -> VerboseLevel
forall a. Num a => a -> a -> a
+VerboseLevel
1)
          (Telescope
delta1, tel' :: Telescope
tel'@(ExtendTel Dom Type
dom Abs Telescope
adelta2)) = VerboseLevel -> Telescope -> (Telescope, Telescope)
splitTelescopeAt VerboseLevel
pos Telescope
tel

      Pattern
p <- TCM Pattern -> ExceptT TCErr tcm Pattern
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Pattern -> ExceptT TCErr tcm Pattern)
-> TCM Pattern -> ExceptT TCErr tcm Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> TCM Pattern
expandLitPattern Pattern
p
      case ([Name], Pattern) -> Pattern
forall a b. (a, b) -> b
snd (([Name], Pattern) -> Pattern) -> ([Name], Pattern) -> Pattern
forall a b. (a -> b) -> a -> b
$ Pattern -> ([Name], Pattern)
asView Pattern
p of
        (A.LitP 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 NAPs Expr
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.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.AsP{}         -> 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__


    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 (tcm :: * -> *) x a.
(MonadTCM tcm, ReadTCState tcm, MonadDebug tcm, HasRange x) =>
x -> tcm a -> tcm 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
      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
20 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
        [ TCM Doc
"splitting problem rest"
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"projection pattern =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> NamedArg Pattern -> TCM Doc
forall c a (m :: * -> *).
(Pretty c, ToConcrete a c, MonadAbsToCon m) =>
a -> m Doc
prettyA NamedArg Pattern
p
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"eliminates type    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Arg Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Arg Type
target
        ]
      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
80 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
        [ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"projection pattern (raw) = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ NamedArg Pattern -> VerboseKey
forall a. Show a => a -> VerboseKey
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 (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
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
$ TypeError -> ExceptT TCErr tcm (ProjOrigin, AmbiguousQName)
forall (m :: * -> *) a.
(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
$ NamedArg Pattern -> Type -> TypeError
CannotEliminateWithPattern NamedArg Pattern
p (Arg Type -> Type
forall e. Arg e -> e
unArg Arg Type
target)

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

      -- 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 (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. MonadTCM m => TypeError -> m a
hardTypeError (TypeError -> ExceptT TCErr tcm QName)
-> TypeError -> ExceptT TCErr tcm QName
forall a b. (a -> b) -> a -> b
$
             VerboseKey -> TypeError
GenericError VerboseKey
"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)
traverse (Type -> Term -> ExceptT TCErr tcm Type
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m) =>
Type -> a -> m Type
`piApplyM` Term
self) Arg Type
projType

      -- Compute the new state
      let projP :: Arg (Named name (Pattern' x))
projP    = Bool
-> (Arg (Named name (Pattern' x)) -> Arg (Named name (Pattern' x)))
-> Arg (Named name (Pattern' x))
-> Arg (Named name (Pattern' x))
forall a. Bool -> (a -> a) -> a -> a
applyWhen (ProjOrigin
orig ProjOrigin -> ProjOrigin -> Bool
forall a. Eq a => a -> a -> Bool
== ProjOrigin
ProjPostfix) (Hiding
-> Arg (Named name (Pattern' x)) -> Arg (Named name (Pattern' x))
forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
NotHidden) (Arg (Named name (Pattern' x)) -> Arg (Named name (Pattern' x)))
-> Arg (Named name (Pattern' x)) -> Arg (Named name (Pattern' x))
forall a b. (a -> b) -> a -> b
$
                       Arg Type
target' Arg Type
-> Named name (Pattern' x) -> Arg (Named name (Pattern' x))
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> Maybe name -> Pattern' x -> Named name (Pattern' x)
forall name a. Maybe name -> a -> Named name a
Named Maybe name
forall a. Maybe a
Nothing (ProjOrigin -> QName -> Pattern' x
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
forall name x. Arg (Named name (Pattern' x))
projP]
          -- drop the projection pattern (already splitted)
          problem' :: Problem a
problem' = Lens' (NAPs Expr) (Problem a) -> LensMap (NAPs Expr) (Problem a)
forall i o. Lens' i o -> LensMap i o
over forall a. Lens' (NAPs Expr) (Problem a)
Lens' (NAPs Expr) (Problem a)
problemRestPats NAPs Expr -> NAPs Expr
forall a. [a] -> [a]
tail Problem a
problem
      TCM (LHSState a) -> ExceptT TCErr tcm (LHSState 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 VerboseLevel]
-> LHSState a
forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe VerboseLevel]
-> LHSState a
LHSState Telescope
tel [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' [Maybe VerboseLevel]
psplit)


    -- | 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
domFinite 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 (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
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(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 ()) -> TCM Doc -> TCMT IO ()
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<<
        [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
hsep [ TCM Doc
"Not a finite domain:" , Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Type -> TCM Doc) -> Type -> TCM 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 (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 Term -> TCMT IO Type
forall (m :: * -> *). Functor m => m Term -> m Type
elInf TCMT IO Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primInterval

      [Maybe Name]
names <- TCM [Maybe Name] -> ExceptT TCErr tcm [Maybe Name]
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
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
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
^. forall a. Lens' [ProblemEq] (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs
        [Maybe Name] -> TCM [Maybe Name]
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
$ VerboseLevel -> [Maybe Name] -> [Maybe Name]
forall a. VerboseLevel -> [a] -> [a]
take (Telescope -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
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 |Ξ|
      --
      VerboseLevel
lhsCxtSize <- ExceptT TCErr tcm VerboseLevel
forall r (m :: * -> *). MonadReader r m => m r
ask -- size of the context before checkLHS call.
      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.partial" VerboseLevel
10 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"lhsCxtSize =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> VerboseLevel -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM VerboseLevel
lhsCxtSize

      Context
newContext <- TCM Context -> ExceptT TCErr tcm Context
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
      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.partial" VerboseLevel
10 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"newContext =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Context -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Context
newContext

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

      (Telescope
gamma,Substitution
sigma) <- TCM (Telescope, Substitution)
-> ExceptT TCErr tcm (Telescope, Substitution)
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 (m :: * -> *) a.
MonadAddContext m =>
Substitution -> (Context -> Context) -> m a -> m a
updateContext Substitution
forall a. Substitution' a
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
                 VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.partial" VerboseLevel
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"currentCxt =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Context -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Context -> TCM Doc) -> TCM Context -> TCM Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCM Context
forall (m :: * -> *). MonadTCEnv m => m Context
getContext)
                 VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.partial" VerboseLevel
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text VerboseKey
"t, u (Expr) =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Expr, Expr) -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> 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
                 VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.partial" VerboseLevel
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text VerboseKey
"t, u        =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (Term, Term) -> TCM Doc
forall (m :: * -> *) a. (Monad 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 (tcm :: * -> *).
Monad tcm =>
tcm Term -> tcm Term -> tcm Term
<@> Term -> TCMT IO Term
forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
t
                   IntervalView
IOne  -> Term -> TCMT IO Term
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
                   IntervalView
_     -> TypeError -> TCMT IO Term
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO Term) -> TypeError -> TCMT IO Term
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TypeError
GenericError (VerboseKey -> TypeError) -> VerboseKey -> TypeError
forall a b. (a -> b) -> a -> b
$ VerboseKey
"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
                       VerboseKey -> TCMT IO (Maybe QName)
forall (m :: * -> *).
HasBuiltins m =>
VerboseKey -> m (Maybe QName)
getBuiltinName' VerboseKey
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 (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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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) -> TCM Doc -> TCMT IO Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
                         Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
a TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCM Doc
" is not IsOne."

                   [Term]
_  -> (TCMT IO Term -> TCMT IO Term -> TCMT IO Term)
-> TCMT IO Term -> [TCMT IO Term] -> TCMT IO Term
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 (tcm :: * -> *).
Monad tcm =>
tcm Term -> tcm Term -> tcm Term
<@> TCMT IO Term
x TCMT IO Term -> TCMT IO Term -> TCMT IO Term
forall (tcm :: * -> *).
Monad tcm =>
tcm Term -> tcm Term -> tcm 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 (f :: * -> *) a. Applicative f => a -> f a
pure [Term]
ts)
         VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.partial" VerboseLevel
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text VerboseKey
"phi           =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
phi
         VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.partial" VerboseLevel
30 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text VerboseKey
"phi           =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall (m :: * -> *) a. (Monad 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
         VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.partial" VerboseLevel
10 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text VerboseKey
"phi (reduced) =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
phi
         [(Telescope, Substitution)]
refined <- Term
-> (Map VerboseLevel Bool
    -> MetaId -> Term -> TCM (Telescope, Substitution))
-> (Substitution -> TCM (Telescope, Substitution))
-> TCMT IO [(Telescope, Substitution)]
forall (m :: * -> *) a.
MonadConversion m =>
Term
-> (Map VerboseLevel Bool -> MetaId -> Term -> m a)
-> (Substitution -> m a)
-> m [a]
forallFaceMaps Term
phi (\ Map VerboseLevel Bool
bs MetaId
m Term
t -> TypeError -> TCM (Telescope, Substitution)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCM (Telescope, Substitution))
-> TypeError -> TCM (Telescope, Substitution)
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TypeError
GenericError (VerboseKey -> TypeError) -> VerboseKey -> TypeError
forall a b. (a -> b) -> a -> b
$ VerboseKey
"face blocked on meta")
                            (\ Substitution
sigma -> (,Substitution
sigma) (Telescope -> (Telescope, Substitution))
-> TCM Telescope -> TCM (Telescope, Substitution)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCM 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 (m :: * -> *) a. Monad m => a -> m a
return (Telescope
gamma,Substitution
sigma)
           []              -> TypeError -> TCM (Telescope, Substitution)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCM (Telescope, Substitution))
-> TypeError -> TCM (Telescope, Substitution)
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TypeError
GenericError (VerboseKey -> TypeError) -> VerboseKey -> TypeError
forall a b. (a -> b) -> a -> b
$ VerboseKey
"The face constraint is unsatisfiable."
           [(Telescope, Substitution)]
_               -> TypeError -> TCM (Telescope, Substitution)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCM (Telescope, Substitution))
-> TypeError -> TCM (Telescope, Substitution)
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TypeError
GenericError (VerboseKey -> TypeError) -> VerboseKey -> TypeError
forall a b. (a -> b) -> a -> b
$ VerboseKey
"Cannot have disjunctions in a face constraint."
      Term
itisone <- TCMT IO Term -> ExceptT TCErr tcm Term
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
      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.faces" VerboseLevel
60 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Substitution -> VerboseKey
forall a. Show a => a -> VerboseKey
show Substitution
sigma

      let oix :: VerboseLevel
oix = Abs Telescope -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
size Abs Telescope
adelta2 -- de brujin index of IsOne
          o_n :: VerboseLevel
o_n = VerboseLevel -> Maybe VerboseLevel -> VerboseLevel
forall a. a -> Maybe a -> a
fromMaybe VerboseLevel
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe VerboseLevel -> VerboseLevel)
-> Maybe VerboseLevel -> VerboseLevel
forall a b. (a -> b) -> a -> b
$
            ((NamedArg DeBruijnPattern -> Bool)
 -> [NamedArg DeBruijnPattern] -> Maybe VerboseLevel)
-> [NamedArg DeBruijnPattern]
-> (NamedArg DeBruijnPattern -> Bool)
-> Maybe VerboseLevel
forall a b c. (a -> b -> c) -> b -> a -> c
flip (NamedArg DeBruijnPattern -> Bool)
-> [NamedArg DeBruijnPattern] -> Maybe VerboseLevel
forall a. (a -> Bool) -> [a] -> Maybe VerboseLevel
findIndex [NamedArg DeBruijnPattern]
ip (\ NamedArg DeBruijnPattern
x -> case Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
-> DeBruijnPattern
forall name a. Named name a -> a
namedThing (NamedArg DeBruijnPattern
-> Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
forall e. Arg e -> e
unArg NamedArg DeBruijnPattern
x) of
                                           VarP PatternInfo
_ DBPatVar
x -> DBPatVar -> VerboseLevel
dbPatVarIndex DBPatVar
x VerboseLevel -> VerboseLevel -> Bool
forall a. Eq a => a -> a -> Bool
== VerboseLevel
oix
                                           DeBruijnPattern
_        -> Bool
False)
          delta2' :: Telescope
delta2' = Abs Telescope -> Term -> Telescope
forall t a. Subst t a => Abs a -> t -> a
absApp Abs Telescope
adelta2 Term
itisone
          delta2 :: Telescope
delta2 = Substitution -> Telescope -> Telescope
forall t a. Subst t a => Substitution' t -> a -> a
applySubst Substitution
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 VerboseLevel
i []) = PatternInfo -> DBPatVar -> DeBruijnPattern
forall x. PatternInfo -> x -> Pattern' x
VarP PatternInfo
defaultPatternInfo (VerboseKey -> VerboseLevel -> DBPatVar
DBPatVar VerboseKey
"x" VerboseLevel
i)
          mkConP Term
_          = DeBruijnPattern
forall a. HasCallStack => a
__IMPOSSIBLE__
          rho0 :: Substitution' DeBruijnPattern
rho0 = (Term -> DeBruijnPattern)
-> Substitution -> Substitution' DeBruijnPattern
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> DeBruijnPattern
mkConP Substitution
sigma

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

          delta' :: Telescope
delta'   = Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
abstract Telescope
gamma Telescope
delta2
          eqs' :: [ProblemEq]
eqs'     = Substitution' DeBruijnPattern -> [ProblemEq] -> [ProblemEq]
forall a. Subst Term a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a -> Lens' [ProblemEq] (Problem a) -> [ProblemEq]
forall o i. o -> Lens' i o -> i
^. forall a. Lens' [ProblemEq] (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs
          ip' :: [NamedArg DeBruijnPattern]
ip'      = Substitution' DeBruijnPattern
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall t a. Subst t a => Substitution' t -> a -> a
applySubst Substitution' DeBruijnPattern
rho [NamedArg DeBruijnPattern]
ip
          target' :: Arg Type
target'  = Substitution' DeBruijnPattern -> Arg Type -> Arg Type
forall a. Subst Term a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
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 forall a. Lens' [ProblemEq] (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs [ProblemEq]
eqs' Problem a
problem
      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.partial" VerboseLevel
60 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (Problem a -> VerboseKey
forall a. Show a => a -> VerboseKey
show Problem a
problem')
      TCM (LHSState a) -> ExceptT TCErr tcm (LHSState 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 VerboseLevel]
-> LHSState a
forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe VerboseLevel]
-> LHSState a
LHSState Telescope
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' ([Maybe VerboseLevel]
psplit [Maybe VerboseLevel]
-> [Maybe VerboseLevel] -> [Maybe VerboseLevel]
forall a. [a] -> [a] -> [a]
++ [VerboseLevel -> Maybe VerboseLevel
forall a. a -> Maybe a
Just VerboseLevel
o_n]))


    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 -> Term -> Telescope
forall t a. Subst t a => Abs a -> t -> 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 :: Substitution' DeBruijnPattern
rho    = VerboseLevel -> DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. DeBruijn a => VerboseLevel -> a -> Substitution' a
singletonS (Telescope -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
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'     = Substitution' DeBruijnPattern -> [ProblemEq] -> [ProblemEq]
forall a. Subst Term a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a -> Lens' [ProblemEq] (Problem a) -> [ProblemEq]
forall o i. o -> Lens' i o -> i
^. forall a. Lens' [ProblemEq] (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs
          ip' :: [NamedArg DeBruijnPattern]
ip'      = Substitution' DeBruijnPattern
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall t a. Subst t a => Substitution' t -> a -> a
applySubst Substitution' DeBruijnPattern
rho [NamedArg DeBruijnPattern]
ip
          target' :: Arg Type
target'  = Substitution' DeBruijnPattern -> Arg Type -> Arg Type
forall a. Subst Term a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
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
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.
(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
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.
(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 forall a. Lens' [ProblemEq] (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs [ProblemEq]
eqs' Problem a
problem
      TCM (LHSState a) -> ExceptT TCErr tcm (LHSState 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 VerboseLevel]
-> LHSState a
forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe VerboseLevel]
-> LHSState a
LHSState Telescope
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' [Maybe VerboseLevel]
psplit)


    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 t a. Subst t a => Abs a -> a
absBody Abs Telescope
adelta2

      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
10 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
        [ TCM Doc
"checking lhs"
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"tel =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"rel =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Relevance -> VerboseKey
forall a. Show a => a -> VerboseKey
show (Relevance -> VerboseKey) -> Relevance -> VerboseKey
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance ArgInfo
info)
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"mod =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ Modality -> VerboseKey
forall a. Show a => a -> VerboseKey
show (Modality -> VerboseKey) -> Modality -> VerboseKey
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Modality
forall a. LensModality a => a -> Modality
getModality  ArgInfo
info)
        ]

      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
15 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
        [ TCM Doc
"split problem"
        , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
          [ TCM Doc
"delta1 = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta1
          , TCM Doc
"a      = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 (Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
a)
          , TCM Doc
"delta2 = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1
                              ((VerboseKey, Dom Type) -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext (VerboseKey
"x" :: String, Dom Type
dom) (Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta2))
          ]
        ]

      -- We cannot split on (shape-)irrelevant arguments.
      VerboseKey -> VerboseLevel -> VerboseKey -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.lhs.split" VerboseLevel
30 (VerboseKey -> ExceptT TCErr tcm ())
-> VerboseKey -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey
"split ConP: relevance is " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Relevance -> VerboseKey
forall a. Show a => a -> VerboseKey
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
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.
(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
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.
(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

      -- We should be at a data/record type
      (DataOrRecord
dr, QName
d, [Arg Term]
pars, [Arg Term]
ixs) <- Telescope
-> ExceptT TCErr tcm (DataOrRecord, QName, [Arg Term], [Arg Term])
-> ExceptT TCErr tcm (DataOrRecord, QName, [Arg Term], [Arg Term])
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 (ExceptT TCErr tcm (DataOrRecord, QName, [Arg Term], [Arg Term])
 -> ExceptT TCErr tcm (DataOrRecord, QName, [Arg Term], [Arg Term]))
-> ExceptT TCErr tcm (DataOrRecord, QName, [Arg Term], [Arg Term])
-> ExceptT TCErr tcm (DataOrRecord, QName, [Arg Term], [Arg Term])
forall a b. (a -> b) -> a -> b
$ Type
-> ExceptT TCErr tcm (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *).
(MonadTCM m, MonadDebug m, ReadTCState m) =>
Type
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
isDataOrRecordType Type
a

      DataOrRecord -> Type -> Maybe (Arg Type) -> ExceptT TCErr tcm ()
forall (m :: * -> *) a ty.
(MonadTCM m, MonadReduce m, MonadError TCErr m, ReadTCState m,
 MonadDebug m, LensSort a, PrettyTCM a, LensSort ty,
 PrettyTCM ty) =>
DataOrRecord -> a -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr Type
a (Arg Type -> Maybe (Arg Type)
forall a. a -> Maybe a
Just Arg Type
target)

      -- The constructor should construct an element of this datatype
      (ConHead
c, Type
b) <- TCM (ConHead, Type) -> ExceptT TCErr tcm (ConHead, Type)
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
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 -> [Arg Term] -> TCM (ConHead, Type)
disambiguateConstructor AmbiguousQName
ambC QName
d [Arg Term]
pars
        Maybe AmbiguousQName
Nothing   -> QName -> [Arg Term] -> Type -> TCM (ConHead, Type)
getRecordConstructor QName
d [Arg Term]
pars Type
a

      -- Don't split on lazy (non-eta) constructor
      case Pattern
focusPat of
        A.ConP ConPatInfo
cpi AmbiguousQName
_ NAPs Expr
_ | 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.
(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 (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 (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 :: * -> *).
(MonadReduce m, HasBuiltins m) =>
Type -> m (TelV Type, Boundary)
telViewPathBoundaryP Type
b
      let Def QName
d' Elims
es' = Term
ctarget
          cixs :: [Arg Term]
cixs = VerboseLevel -> [Arg Term] -> [Arg Term]
forall a. VerboseLevel -> [a] -> [a]
drop ([Arg Term] -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
size [Arg Term]
pars) ([Arg Term] -> [Arg Term]) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$ [Arg Term] -> Maybe [Arg Term] -> [Arg Term]
forall a. a -> Maybe a -> a
fromMaybe [Arg Term]
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe [Arg Term] -> [Arg Term]) -> Maybe [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es'

      -- Δ₁Γ ⊢ boundary
      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split.con" VerboseLevel
50 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text VerboseKey
"  boundary = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Boundary -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> 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 <- TCM Telescope -> ExceptT TCErr tcm Telescope
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Telescope -> ExceptT TCErr tcm Telescope)
-> TCM Telescope -> ExceptT TCErr tcm Telescope
forall a b. (a -> b) -> a -> b
$ case Pattern
focusPat of
        A.ConP ConPatInfo
_ AmbiguousQName
_ NAPs Expr
ps -> do
          NAPs Expr
ps <- ExpandHidden -> NAPs Expr -> Telescope -> TCM (NAPs Expr)
insertImplicitPatterns ExpandHidden
ExpandLast NAPs Expr
ps Telescope
gamma
          Telescope -> TCM Telescope
forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope -> TCM Telescope) -> Telescope -> TCM Telescope
forall a b. (a -> b) -> a -> b
$ NAPs Expr -> Telescope -> Telescope
useNamesFromPattern NAPs Expr
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
          NAPs Expr
ps <- QName
-> (Name -> Pattern)
-> [FieldAssignment' Pattern]
-> [Arg Name]
-> TCM (NAPs Expr)
forall a.
QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFields 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
          NAPs Expr
ps <- ExpandHidden -> NAPs Expr -> Telescope -> TCM (NAPs Expr)
insertImplicitPatterns ExpandHidden
ExpandLast NAPs Expr
ps Telescope
gamma
          Telescope -> TCM Telescope
forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope -> TCM Telescope) -> Telescope -> TCM Telescope
forall a b. (a -> b) -> a -> b
$ NAPs Expr -> Telescope -> Telescope
useNamesFromPattern NAPs Expr
ps Telescope
gamma
        Pattern
_ -> TCM 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 (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 -> [Arg Term] -> Type
`piApply` [Arg Term]
pars) (Type -> Type) -> (Definition -> Type) -> Definition -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType (Definition -> Type)
-> 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
      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
30 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"  da = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
da

      VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
15 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$
        [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep [ TCM Doc
"preparing to unify"
            , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
              [ TCM Doc
"c      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ConHead -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ConHead
c TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCM Doc
":" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
b
              , TCM Doc
"d      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (QName -> Elims -> Term
Def QName
d ((Arg Term -> Elim' Term) -> [Arg Term] -> Elims
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Elim' Term
forall a. Arg a -> Elim' a
Apply [Arg Term]
pars)) TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCM Doc
":" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
da
              , TCM Doc
"gamma  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
gamma
              , TCM Doc
"pars   =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets ([TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc -> [TCM Doc] -> [TCM Doc]
forall (m :: * -> *).
(Applicative m, Semigroup (m Doc)) =>
m Doc -> [m Doc] -> [m Doc]
punctuate TCM Doc
forall (m :: * -> *). Monad m => m Doc
comma ([TCM Doc] -> [TCM Doc]) -> [TCM Doc] -> [TCM Doc]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> TCM Doc) -> [Arg Term] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Arg Term]
pars)
              , TCM Doc
"ixs    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets ([TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc -> [TCM Doc] -> [TCM Doc]
forall (m :: * -> *).
(Applicative m, Semigroup (m Doc)) =>
m Doc -> [m Doc] -> [m Doc]
punctuate TCM Doc
forall (m :: * -> *). Monad m => m Doc
comma ([TCM Doc] -> [TCM Doc]) -> [TCM Doc] -> [TCM Doc]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> TCM Doc) -> [Arg Term] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Arg Term]
ixs)
              , TCM Doc
"cixs   =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma (TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets ([TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
fsep ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc -> [TCM Doc] -> [TCM Doc]
forall (m :: * -> *).
(Applicative m, Semigroup (m Doc)) =>
m Doc -> [m Doc] -> [m Doc]
punctuate TCM Doc
forall (m :: * -> *). Monad m => m Doc
comma ([TCM Doc] -> [TCM Doc]) -> [TCM Doc] -> [TCM Doc]
forall a b. (a -> b) -> a -> b
$ (Arg Term -> TCM Doc) -> [Arg Term] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Arg Term]
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 Lens' Bool TCEnv
eMakeCase) ([IsForced] -> ExceptT TCErr tcm [IsForced]
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'  = VerboseLevel -> Type -> Type
forall t a. Subst t a => VerboseLevel -> a -> a
raise (Telescope -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
size Telescope
gamma) Type
da
          ixs' :: [Arg Term]
ixs' = VerboseLevel -> [Arg Term] -> [Arg Term]
forall t a. Subst t a => VerboseLevel -> a -> a
raise (Telescope -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
size Telescope
gamma) [Arg Term]
ixs
          -- Variables in Δ₁ are not forced, since the unifier takes care to not introduce forced
          -- variables.
          forced :: [IsForced]
forced = VerboseLevel -> IsForced -> [IsForced]
forall a. VerboseLevel -> a -> [a]
replicate (Telescope -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
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' <- 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 (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

      TCM UnificationResult -> ExceptT TCErr tcm UnificationResult
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (Telescope
-> FlexibleVars
-> Type
-> [Arg Term]
-> [Arg Term]
-> TCM UnificationResult
forall (tcm :: * -> *).
MonadTCM tcm =>
Telescope
-> FlexibleVars
-> Type
-> [Arg Term]
-> [Arg Term]
-> tcm UnificationResult
unifyIndices Telescope
delta1Gamma FlexibleVars
flex Type
da' [Arg Term]
cixs [Arg Term]
ixs') ExceptT TCErr tcm UnificationResult
-> (UnificationResult -> ExceptT TCErr tcm (LHSState a))
-> ExceptT TCErr tcm (LHSState a)
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. 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

        -- Unclear situation.  Try next split.
        DontKnow [UnificationFailure]
errs -> TypeError -> ExceptT TCErr tcm (LHSState a)
forall (m :: * -> *) a.
(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
$
          QName
-> Telescope
-> [Arg Term]
-> [Arg Term]
-> [UnificationFailure]
-> SplitError
UnificationStuck (ConHead -> QName
conName ConHead
c) (Telescope
delta1 Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
gamma) [Arg Term]
cixs [Arg Term]
ixs' [UnificationFailure]
errs

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

          VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
15 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ TCM Doc
"unification successful"
          VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
            [ TCM Doc
"delta1' =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta1'
            , TCM Doc
"rho0    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' (Substitution' DeBruijnPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho0)
            , TCM Doc
"es      =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' ([Arg (Named (WithOrigin (Ranged VerboseKey)) Term)] -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ([Arg (Named (WithOrigin (Ranged VerboseKey)) Term)] -> TCM Doc)
-> [Arg (Named (WithOrigin (Ranged VerboseKey)) Term)] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ ((NamedArg DeBruijnPattern
 -> Arg (Named (WithOrigin (Ranged VerboseKey)) Term))
-> [NamedArg DeBruijnPattern]
-> [Arg (Named (WithOrigin (Ranged VerboseKey)) Term)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((NamedArg DeBruijnPattern
  -> Arg (Named (WithOrigin (Ranged VerboseKey)) Term))
 -> [NamedArg DeBruijnPattern]
 -> [Arg (Named (WithOrigin (Ranged VerboseKey)) Term)])
-> ((DeBruijnPattern -> Term)
    -> NamedArg DeBruijnPattern
    -> Arg (Named (WithOrigin (Ranged VerboseKey)) Term))
-> (DeBruijnPattern -> Term)
-> [NamedArg DeBruijnPattern]
-> [Arg (Named (WithOrigin (Ranged VerboseKey)) Term)]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
 -> Named (WithOrigin (Ranged VerboseKey)) Term)
-> NamedArg DeBruijnPattern
-> Arg (Named (WithOrigin (Ranged VerboseKey)) Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
  -> Named (WithOrigin (Ranged VerboseKey)) Term)
 -> NamedArg DeBruijnPattern
 -> Arg (Named (WithOrigin (Ranged VerboseKey)) Term))
-> ((DeBruijnPattern -> Term)
    -> Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
    -> Named (WithOrigin (Ranged VerboseKey)) Term)
-> (DeBruijnPattern -> Term)
-> NamedArg DeBruijnPattern
-> Arg (Named (WithOrigin (Ranged VerboseKey)) Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (DeBruijnPattern -> Term)
-> Named (WithOrigin (Ranged VerboseKey)) DeBruijnPattern
-> Named (WithOrigin (Ranged VerboseKey)) Term
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm [NamedArg DeBruijnPattern]
es)
            ]

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

          VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
            [ TCM Doc
"rho1    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' DeBruijnPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho1
            , TCM Doc
"rho2    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' DeBruijnPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho2
            ]

          -- Andreas, 2010-09-09, save the type.
          -- It is relative to Δ₁, but it should be relative to Δ₁'
          let a' :: Type
a' = Substitution' DeBruijnPattern -> Type -> Type
forall a. Subst Term a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho1 Type
a
          -- Also remember if we are a record pattern.
          Maybe Defn
isRec <- QName -> ExceptT TCErr tcm (Maybe Defn)
forall (m :: * -> *). HasConstInfo m => QName -> m (Maybe Defn)
isRecord QName
d

          let cpi :: ConPatternInfo
cpi = ConPatternInfo :: PatternInfo
-> Bool -> Bool -> Maybe (Arg Type) -> Bool -> ConPatternInfo
ConPatternInfo { conPInfo :: PatternInfo
conPInfo   = PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatOCon []
                                   , conPRecord :: Bool
conPRecord = Maybe Defn -> Bool
forall a. Maybe a -> Bool
isJust Maybe Defn
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' DeBruijnPattern
-> [NamedArg DeBruijnPattern] -> [NamedArg DeBruijnPattern]
forall t a. Subst t a => Substitution' t -> a -> a
applySubst Substitution' 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 :: Substitution' DeBruijnPattern
rho3    = DeBruijnPattern
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS DeBruijnPattern
crho Substitution' DeBruijnPattern
rho1
              delta2' :: Telescope
delta2' = Substitution' DeBruijnPattern -> Telescope -> Telescope
forall a. Subst Term a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho3 Telescope
delta2
              delta' :: Telescope
delta'  = Telescope
delta1' Telescope -> Telescope -> Telescope
forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
delta2'
              rho :: Substitution' DeBruijnPattern
rho     = VerboseLevel
-> Substitution' DeBruijnPattern -> Substitution' DeBruijnPattern
forall a. VerboseLevel -> Substitution' a -> Substitution' a
liftS (Telescope -> VerboseLevel
forall a. Sized a => a -> VerboseLevel
size Telescope
delta2) Substitution' DeBruijnPattern
rho3

          VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
20 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
            [ TCM Doc
"crho    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> DeBruijnPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM DeBruijnPattern
crho
            , TCM Doc
"rho3    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' DeBruijnPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho3
            , TCM Doc
"delta2' =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta2'
            ]
          VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
70 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
            [ TCM Doc
"crho    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> DeBruijnPattern -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty DeBruijnPattern
crho
            , TCM Doc
"rho3    =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Substitution' DeBruijnPattern -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty Substitution' DeBruijnPattern
rho3
            , TCM Doc
"delta2' =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty Telescope
delta2'
            ]

          VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr tcm ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
15 (TCM Doc -> ExceptT TCErr tcm ())
-> TCM Doc -> ExceptT TCErr tcm ()
forall a b. (a -> b) -> a -> b
$ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
            [ TCM Doc
"delta'  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta'
            , TCM Doc
"rho     =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Telescope -> TCM Doc -> TCM Doc
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta' (Substitution' DeBruijnPattern -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Substitution' DeBruijnPattern
rho)
            ]

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

          -- Update the problem equations
          let eqs' :: [ProblemEq]
eqs' = Substitution' DeBruijnPattern -> [ProblemEq] -> [ProblemEq]
forall a. Subst Term a => Substitution' DeBruijnPattern -> a -> a
applyPatSubst Substitution' DeBruijnPattern
rho ([ProblemEq] -> [ProblemEq]) -> [ProblemEq] -> [ProblemEq]
forall a b. (a -> b) -> a -> b
$ Problem a
problem Problem a -> Lens' [ProblemEq] (Problem a) -> [ProblemEq]
forall o i. o -> Lens' i o -> i
^. forall a. Lens' [ProblemEq] (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 forall a. Lens' [ProblemEq] (Problem a)
Lens' [ProblemEq] (Problem a)
problemEqs [ProblemEq]
eqs' Problem a
problem

          -- 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 (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 VerboseLevel]
-> LHSState a
forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe VerboseLevel]
-> LHSState a
LHSState Telescope
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' [Maybe VerboseLevel]
psplit

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




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

noPatternMatchingOnCodata :: [NamedArg DeBruijnPattern] -> TCM ()
noPatternMatchingOnCodata :: [NamedArg DeBruijnPattern] -> TCMT IO ()
noPatternMatchingOnCodata = (NamedArg DeBruijnPattern -> TCMT IO ())
-> [NamedArg DeBruijnPattern] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (DeBruijnPattern -> TCMT IO ()
forall x. Pattern' x -> TCMT IO ()
check (DeBruijnPattern -> TCMT IO ())
-> (NamedArg DeBruijnPattern -> DeBruijnPattern)
-> NamedArg DeBruijnPattern
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg DeBruijnPattern -> DeBruijnPattern
forall a. NamedArg a -> a
namedArg)
  where
  check :: Pattern' x -> TCMT IO ()
check (VarP {})   = () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  check (DotP {})   = () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  check (ProjP{})   = () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  check (IApplyP{}) = () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
  check (LitP {})   = () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()  -- Literals are assumed not to be coinductive.
  check (DefP{})    = () -> TCMT IO ()
forall (m :: * -> *) a. Monad m => a -> m a
return () -- we assume we don't generate this for codata.
  check (ConP ConHead
con ConPatternInfo
_ [NamedArg (Pattern' x)]
ps) = do
    VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.top" VerboseLevel
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
      TCM Doc
"checking whether" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ConHead -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ConHead
con TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCM Doc
"is a coinductive constructor"
    TelV Telescope
_ Type
t <- Type -> TelV Type
telView' (Type -> TelV Type)
-> (Definition -> Type) -> Definition -> TelV Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType (Definition -> TelV Type) -> TCMT IO Definition -> TCM (TelV Type)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (QName -> TCMT IO Definition) -> QName -> TCMT IO Definition
forall a b. (a -> b) -> a -> b
$ ConHead -> QName
conName ConHead
con
    Maybe Bool
c <- Type -> TCM (Maybe Bool)
isCoinductive Type
t
    case Maybe Bool
c of
      Maybe Bool
Nothing    -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
      Just Bool
False -> (NamedArg (Pattern' x) -> TCMT IO ())
-> [NamedArg (Pattern' x)] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Pattern' x -> TCMT IO ()
check (Pattern' x -> TCMT IO ())
-> (NamedArg (Pattern' x) -> Pattern' x)
-> NamedArg (Pattern' x)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg (Pattern' x) -> Pattern' x
forall a. NamedArg a -> a
namedArg) [NamedArg (Pattern' x)]
ps
      Just Bool
True  -> TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        VerboseKey -> TypeError
GenericError VerboseKey
"Pattern matching on coinductive types is not allowed"

-- | 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 :: TCM a -> m a
suspendErrors TCM a
f = do
  Either TCErr a
ok <- TCM (Either TCErr a) -> m (Either TCErr 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 e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (Either TCErr a -> TCM (Either TCErr 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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError 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 :: (ReadTCState m, MonadError TCErr m, MonadTCEnv m) => TypeError -> m a
softTypeError :: TypeError -> m a
softTypeError TypeError
err = 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
=<< TypeError -> m TCErr
forall (m :: * -> *).
(MonadTCEnv m, ReadTCState m) =>
TypeError -> m TCErr
typeError_ 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 :: (MonadTCM m) => TypeError -> m a
hardTypeError :: TypeError -> m a
hardTypeError = 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
. TypeError -> TCM a
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError

-- | 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, MonadDebug m, ReadTCState m)
                   => Type
                   -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
isDataOrRecordType :: Type
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
isDataOrRecordType Type
a = TCM (Blocked Type) -> ExceptT TCErr m (Blocked Type)
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (Type -> TCM (Blocked Type)
forall a (m :: * -> *).
(Reduce a, MonadReduce m) =>
a -> m (Blocked a)
reduceB Type
a) ExceptT TCErr m (Blocked Type)
-> (Blocked Type
    -> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term]))
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
  NotBlocked 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 (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO Defn -> ExceptT TCErr m Defn)
-> TCMT IO Defn -> ExceptT TCErr m Defn
forall a b. (a -> b) -> a -> b
$ 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, [Arg Term], [Arg Term]))
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case

      Datatype{dataPars :: Defn -> VerboseLevel
dataPars = VerboseLevel
np} -> do

        let ([Arg Term]
pars, [Arg Term]
ixs) = VerboseLevel -> [Arg Term] -> ([Arg Term], [Arg Term])
forall a. VerboseLevel -> [a] -> ([a], [a])
splitAt VerboseLevel
np ([Arg Term] -> ([Arg Term], [Arg Term]))
-> [Arg Term] -> ([Arg Term], [Arg Term])
forall a b. (a -> b) -> a -> b
$ [Arg Term] -> Maybe [Arg Term] -> [Arg Term]
forall a. a -> Maybe a -> a
fromMaybe [Arg Term]
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe [Arg Term] -> [Arg Term]) -> Maybe [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
        (DataOrRecord, QName, [Arg Term], [Arg Term])
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a. Monad m => a -> m a
return (DataOrRecord
IsData, QName
d, [Arg Term]
pars, [Arg Term]
ixs)

      Record{} -> do
        let pars :: [Arg Term]
pars = [Arg Term] -> Maybe [Arg Term] -> [Arg Term]
forall a. a -> Maybe a -> a
fromMaybe [Arg Term]
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe [Arg Term] -> [Arg Term]) -> Maybe [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
        (DataOrRecord, QName, [Arg Term], [Arg Term])
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a. Monad m => a -> m a
return (DataOrRecord
IsRecord, QName
d, [Arg Term]
pars, [])

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

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

      -- Can't match before we have the definition
      DataOrRecSig{} -> TypeError
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a. MonadTCM m => TypeError -> m a
hardTypeError (TypeError
 -> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term]))
-> (Doc -> TypeError)
-> Doc
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc
 -> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term]))
-> ExceptT TCErr m Doc
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
        TCM Doc -> ExceptT TCErr m Doc
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCM Doc -> ExceptT TCErr m Doc) -> TCM Doc -> ExceptT TCErr m Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"Cannot split on data type" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
d TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCM 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, [Arg Term], [Arg Term])
forall (m :: * -> *) a. MonadTCM m => TypeError -> m a
hardTypeError (TypeError
 -> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

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

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

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

    -- variable or metavariable: fail softly
    Var{}      -> TypeError
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError
 -> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
    MetaV{}    -> TypeError
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError
 -> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

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

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

  -- Type is blocked on a meta or something else: fail softly
  Blocked Type
_ -> TypeError
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError
 -> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term]))
-> ExceptT TCErr m TypeError
-> ExceptT TCErr m (DataOrRecord, QName, [Arg Term], [Arg Term])
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData

  where notData :: ExceptT TCErr m TypeError
notData = TCM TypeError -> ExceptT TCErr m TypeError
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
a


-- | Get the constructor of the given record type together with its type.
--   Throws an error if the type is not a record type.
getRecordConstructor
  :: QName  -- ^ Name @d@ of the record type
  -> Args   -- ^ Parameters @pars@ of the record type
  -> Type   -- ^ The record type @Def d pars@ (for error reporting)
  -> TCM (ConHead, Type)
getRecordConstructor :: QName -> [Arg Term] -> Type -> TCM (ConHead, Type)
getRecordConstructor QName
d [Arg Term]
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 (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 (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.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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 -> [Arg Term] -> Type
`piApply` [Arg Term]
pars) (Type -> Type) -> (Definition -> Type) -> Definition -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType (Definition -> Type) -> 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 (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, Arg Type)
disambiguateProjection :: Maybe Hiding -> AmbiguousQName -> Arg Type -> TCM (QName, Arg Type)
disambiguateProjection Maybe Hiding
h ambD :: AmbiguousQName
ambD@(AmbQ NonEmpty 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, [Arg Term], Defn))
-> TCM (QName, Arg Type)
-> ((QName, [Arg Term], Defn) -> TCM (QName, Arg Type))
-> TCM (QName, Arg Type)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (TCMT IO (Maybe (QName, [Arg Term], Defn))
-> TCMT IO (Maybe (QName, [Arg Term], Defn))
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (Maybe (QName, [Arg Term], Defn))
 -> TCMT IO (Maybe (QName, [Arg Term], Defn)))
-> TCMT IO (Maybe (QName, [Arg Term], Defn))
-> TCMT IO (Maybe (QName, [Arg Term], Defn))
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO (Maybe (QName, [Arg Term], Defn))
forall (m :: * -> *).
(MonadReduce m, HasConstInfo m, HasBuiltins m) =>
Type -> m (Maybe (QName, [Arg Term], Defn))
isRecordType (Type -> TCMT IO (Maybe (QName, [Arg Term], Defn)))
-> Type -> TCMT IO (Maybe (QName, [Arg Term], Defn))
forall a b. (a -> b) -> a -> b
$ Arg Type -> Type
forall e. Arg e -> e
unArg Arg Type
b) TCM (QName, Arg Type)
forall a. TCMT IO a
notRecord (((QName, [Arg Term], Defn) -> TCM (QName, Arg Type))
 -> TCM (QName, Arg Type))
-> ((QName, [Arg Term], Defn) -> TCM (QName, Arg Type))
-> TCM (QName, Arg Type)
forall a b. (a -> b) -> a -> b
$ \(QName
r, [Arg Term]
vs, Defn
def) -> case Defn
def of
    Record{ recFields :: Defn -> [Dom' Term QName]
recFields = [Dom' Term QName]
fs } -> do
      VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
20 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
        [ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"we are of record type r  = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow QName
r
        , VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text   VerboseKey
"applied to parameters vs = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Arg Term] -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Arg Term]
vs
        , VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"and have fields       fs = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ [Arg QName] -> VerboseKey
forall a. Pretty a => a -> VerboseKey
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)
        ]
      -- Try the projection candidates.
      -- First, we try to find a disambiguation that doesn't produce
      -- any new constraints.
      Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> (([TCErr], [(QName, Arg Type)]) -> TCM (QName, Arg Type))
-> TCM (QName, Arg Type)
tryDisambiguate Bool
False [Dom' Term QName]
fs QName
r [Arg Term]
vs ((([TCErr], [(QName, Arg Type)]) -> TCM (QName, Arg Type))
 -> TCM (QName, Arg Type))
-> (([TCErr], [(QName, Arg Type)]) -> TCM (QName, Arg Type))
-> TCM (QName, Arg Type)
forall a b. (a -> b) -> a -> b
$ \ ([TCErr], [(QName, Arg Type)])
_ ->
          -- If this fails, we try again with constraints, but we require
          -- the solution to be unique.
          Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> (([TCErr], [(QName, Arg Type)]) -> TCM (QName, Arg Type))
-> TCM (QName, Arg Type)
tryDisambiguate Bool
True [Dom' Term QName]
fs QName
r [Arg Term]
vs ((([TCErr], [(QName, Arg Type)]) -> TCM (QName, Arg Type))
 -> TCM (QName, Arg Type))
-> (([TCErr], [(QName, Arg Type)]) -> TCM (QName, Arg Type))
-> TCM (QName, Arg Type)
forall a b. (a -> b) -> a -> b
$ \case
            ([]   , []      ) -> TCM (QName, Arg Type)
forall a. HasCallStack => a
__IMPOSSIBLE__
            (TCErr
err:[TCErr]
_, []      ) -> TCErr -> TCM (QName, Arg Type)
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
            ([TCErr]
_    , disambs :: [(QName, Arg Type)]
disambs@((QName
d,Arg Type
a):[(QName, Arg Type)]
_)) -> TypeError -> TCM (QName, Arg Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr m) =>
TypeError -> m a
typeError (TypeError -> TCM (QName, Arg Type))
-> (Doc -> TypeError) -> Doc -> TCM (QName, Arg Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Doc -> TypeError
GenericDocError (Doc -> TCM (QName, Arg Type)) -> TCM Doc -> TCM (QName, Arg Type)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
              [ TCM Doc
"Ambiguous projection " TCM Doc -> TCM Doc -> TCM Doc
forall a. Semigroup a => a -> a -> a
<> QName -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
d TCM Doc -> TCM Doc -> TCM Doc
forall a. Semigroup a => a -> a -> a
<> TCM Doc
"."
              , TCM Doc
"It could refer to any of"
              , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ ((QName, Arg Type) -> TCM Doc) -> [(QName, Arg Type)] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> TCM Doc
prettyDisamb (QName -> TCM Doc)
-> ((QName, Arg Type) -> QName) -> (QName, Arg Type) -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName, Arg Type) -> QName
forall a b. (a, b) -> a
fst) [(QName, Arg Type)]
disambs
              ]
    Defn
_ -> TCM (QName, Arg Type)
forall a. HasCallStack => a
__IMPOSSIBLE__

  where
    tryDisambiguate :: Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> (([TCErr], [(QName, Arg Type)]) -> TCM (QName, Arg Type))
-> TCM (QName, Arg Type)
tryDisambiguate Bool
constraintsOk [Dom' Term QName]
fs QName
r [Arg Term]
vs ([TCErr], [(QName, Arg Type)]) -> TCM (QName, Arg Type)
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))
disambiguations <- (QName -> TCM (Either TCErr (QName, Arg Type)))
-> NonEmpty QName
-> TCM (NonEmpty (Either TCErr (QName, Arg Type)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExceptT TCErr TCM (QName, Arg Type)
-> TCM (Either TCErr (QName, Arg Type))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TCErr TCM (QName, Arg Type)
 -> TCM (Either TCErr (QName, Arg Type)))
-> (QName -> ExceptT TCErr TCM (QName, Arg Type))
-> QName
-> TCM (Either TCErr (QName, Arg Type))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> QName
-> ExceptT TCErr TCM (QName, Arg Type)
tryProj Bool
constraintsOk [Dom' Term QName]
fs QName
r [Arg Term]
vs) NonEmpty QName
ds
      case [Either TCErr (QName, Arg Type)] -> ([TCErr], [(QName, Arg Type)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either TCErr (QName, Arg Type)]
 -> ([TCErr], [(QName, Arg Type)]))
-> [Either TCErr (QName, Arg Type)]
-> ([TCErr], [(QName, Arg Type)])
forall a b. (a -> b) -> a -> b
$ NonEmpty (Either TCErr (QName, Arg Type))
-> [Either TCErr (QName, Arg Type)]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Either TCErr (QName, Arg Type))
disambiguations of
        ([TCErr]
_ , (QName
d,Arg Type
a) : [(QName, Arg Type)]
disambs) | Bool
constraintsOk Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
<= [(QName, Arg Type)] -> Bool
forall a. Null a => a -> Bool
null [(QName, Arg Type)]
disambs -> do
          -- 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 (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 ()
storeDisambiguatedName QName
d
          (QName, Arg Type) -> TCM (QName, Arg Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
d,Arg Type
a)
        ([TCErr], [(QName, Arg Type)])
other -> ([TCErr], [(QName, Arg Type)]) -> TCM (QName, Arg Type)
failure ([TCErr], [(QName, Arg Type)])
other

    notRecord :: TCMT IO a
notRecord = QName -> TCMT IO a
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj (QName -> TCMT IO a) -> QName -> TCMT IO a
forall a b. (a -> b) -> a -> b
$ NonEmpty QName -> QName
forall a. NonEmpty a -> a
NonEmpty.head NonEmpty QName
ds

    wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a
    wrongProj :: QName -> m a
wrongProj QName
d = TypeError -> m a
forall (m :: * -> *) a.
(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 (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) -> TCM Doc -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
        [ TCM Doc
"Cannot eliminate type "
        , Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Arg Type -> Type
forall e. Arg e -> e
unArg Arg Type
b)
        , TCM Doc
" with projection "
        , if AmbiguousQName -> Bool
isAmbiguous AmbiguousQName
ambD then
            VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc)
-> (QName -> VerboseKey) -> QName -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow (QName -> TCM Doc) -> TCMT IO QName -> TCM Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> TCMT IO QName
dropTopLevelModule QName
d
          else
            QName -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM QName
d
        ]

    wrongHiding :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a
    wrongHiding :: QName -> m a
wrongHiding QName
d = TypeError -> m a
forall (m :: * -> *) a.
(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 (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) -> TCM Doc -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
        [ TCM Doc
"Wrong hiding used for projection " , QName -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> 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)
    tryProj :: Bool
-> [Dom' Term QName]
-> QName
-> [Arg Term]
-> QName
-> ExceptT TCErr TCM (QName, Arg Type)
tryProj Bool
constraintsOk [Dom' Term QName]
fs QName
r [Arg Term]
vs QName
d0 = QName -> ExceptT TCErr TCM (Maybe Projection)
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Maybe Projection)
isProjection QName
d0 ExceptT TCErr TCM (Maybe Projection)
-> (Maybe Projection -> ExceptT TCErr TCM (QName, Arg Type))
-> ExceptT TCErr TCM (QName, Arg Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      -- Not a projection
      Maybe Projection
Nothing -> QName -> ExceptT TCErr TCM (QName, Arg Type)
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 TCM QName
-> (QName -> ExceptT TCErr TCM QName)
-> Maybe QName
-> ExceptT TCErr TCM QName
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (QName -> ExceptT TCErr TCM QName
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d) QName -> ExceptT TCErr TCM QName
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe QName -> ExceptT TCErr TCM QName)
-> Maybe QName -> ExceptT TCErr TCM 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 TCM () -> ExceptT TCErr TCM ()
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 TCM () -> ExceptT TCErr TCM ())
-> ExceptT TCErr TCM () -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> ExceptT TCErr TCM ()
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d
        VerboseKey -> VerboseLevel -> VerboseKey -> ExceptT TCErr TCM ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> VerboseKey -> m ()
reportSLn VerboseKey
"tc.lhs.split" VerboseLevel
90 VerboseKey
"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.
        VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr TCM ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
20 (TCM Doc -> ExceptT TCErr TCM ())
-> TCM Doc -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
          [ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"proj                  d0 = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow QName
d0
          , VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"original proj         d  = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
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 TCM (Dom' Term QName)
-> (Dom' Term QName -> ExceptT TCErr TCM (Dom' Term QName))
-> Maybe (Dom' Term QName)
-> ExceptT TCErr TCM (Dom' Term QName)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (QName -> ExceptT TCErr TCM (Dom' Term QName)
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d) Dom' Term QName -> ExceptT TCErr TCM (Dom' Term QName)
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe (Dom' Term QName) -> ExceptT TCErr TCM (Dom' Term QName))
-> Maybe (Dom' Term QName) -> ExceptT TCErr TCM (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

        let ai :: ArgInfo
ai = Modality -> ArgInfo -> ArgInfo
forall a. LensModality a => Modality -> a -> a
setModality (Dom' Term QName -> Modality
forall a. LensModality a => a -> Modality
getModality Dom' Term QName
argd) (ArgInfo -> ArgInfo) -> ArgInfo -> ArgInfo
forall a b. (a -> b) -> a -> b
$ Projection -> ArgInfo
projArgInfo Projection
proj

        VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr TCM ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
20 (TCM Doc -> ExceptT TCErr TCM ())
-> TCM Doc -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
          [ VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"original proj relevance  = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Relevance -> VerboseKey
forall a. Show a => a -> VerboseKey
show (Dom' Term QName -> Relevance
forall a. LensRelevance a => a -> Relevance
getRelevance Dom' Term QName
argd)
          , VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc) -> VerboseKey -> TCM Doc
forall a b. (a -> b) -> a -> b
$ VerboseKey
"original proj quantity   = " VerboseKey -> VerboseKey -> VerboseKey
forall a. [a] -> [a] -> [a]
++ Quantity -> VerboseKey
forall a. Show a => a -> VerboseKey
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 TCM () -> ExceptT TCErr TCM ()
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
ai) (ExceptT TCErr TCM () -> ExceptT TCErr TCM ())
-> ExceptT TCErr TCM () -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> ExceptT TCErr TCM ()
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongHiding QName
d

        -- Andreas, 2016-12-31, issue #1976: Check parameters.
        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
$ Bool -> (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a. Bool -> (a -> a) -> a -> a
applyUnless Bool
constraintsOk 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
$
          QName -> QName -> [Arg Term] -> TCMT IO ()
forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> [Arg Term] -> tcm ()
checkParameters QName
qr QName
r [Arg Term]
vs

        -- Get the type of projection d applied to "self"
        Type
dType <- TCMT IO Type -> ExceptT TCErr TCM Type
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
$ 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!
        VerboseKey -> VerboseLevel -> TCM Doc -> ExceptT TCErr TCM ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
20 (TCM Doc -> ExceptT TCErr TCM ())
-> TCM Doc -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
          [ TCM Doc
"we are being projected by dType = " TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
dType
          ]
        Type
projType <- TCMT IO Type -> ExceptT TCErr TCM Type
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
$ Type
dType Type -> [Arg Term] -> TCMT IO Type
forall a (m :: * -> *).
(PiApplyM a, MonadReduce m) =>
Type -> a -> m Type
`piApplyM` [Arg Term]
vs
        (QName, Arg Type) -> ExceptT TCErr TCM (QName, Arg Type)
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)

-- | Disambiguate a constructor based on the data type it is supposed to be
--   constructing. Returns the unambiguous constructor name and its type.
--   Precondition: type should be a data/record type.
disambiguateConstructor
  :: AmbiguousQName    -- ^ The name of the constructor to be disambiguated.
  -> QName             -- ^ Name of the datatype.
  -> Args              -- ^ Parameters of the datatype
  -> TCM (ConHead, Type)
disambiguateConstructor :: AmbiguousQName -> QName -> [Arg Term] -> TCM (ConHead, Type)
disambiguateConstructor ambC :: AmbiguousQName
ambC@(AmbQ NonEmpty QName
cs) QName
d [Arg Term]
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    def :: Defn
def@Datatype{} -> [QName] -> TCMT IO [QName]
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 (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 noConstraints,
  -- if that fails, try again allowing constraint generation.
  Bool
-> [QName]
-> QName
-> (([TCErr], [(QName, ConHead, Type)]) -> TCM (ConHead, Type))
-> TCM (ConHead, Type)
tryDisambiguate Bool
False [QName]
cons QName
d ((([TCErr], [(QName, ConHead, Type)]) -> TCM (ConHead, Type))
 -> TCM (ConHead, Type))
-> (([TCErr], [(QName, ConHead, Type)]) -> TCM (ConHead, Type))
-> TCM (ConHead, Type)
forall a b. (a -> b) -> a -> b
$ \ ([TCErr], [(QName, ConHead, Type)])
_ ->
    Bool
-> [QName]
-> QName
-> (([TCErr], [(QName, ConHead, Type)]) -> TCM (ConHead, Type))
-> TCM (ConHead, Type)
tryDisambiguate Bool
True [QName]
cons QName
d ((([TCErr], [(QName, ConHead, Type)]) -> TCM (ConHead, Type))
 -> TCM (ConHead, Type))
-> (([TCErr], [(QName, ConHead, Type)]) -> 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 e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
        ([TCErr]
_    , disambs :: [(QName, ConHead, Type)]
disambs@((QName
_c0,ConHead
c,Type
_a):[(QName, ConHead, Type)]
_)) -> TypeError -> TCM (ConHead, Type)
forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m, MonadError TCErr 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)) -> TCM Doc -> TCM (ConHead, Type)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat
          [ TCM Doc
"Ambiguous constructor " TCM Doc -> TCM Doc -> TCM Doc
forall a. Semigroup a => a -> a -> a
<> Name -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (QName -> Name
qnameName (QName -> Name) -> QName -> Name
forall a b. (a -> b) -> a -> b
$ ConHead -> QName
conName ConHead
c) TCM Doc -> TCM Doc -> TCM Doc
forall a. Semigroup a => a -> a -> a
<> TCM Doc
"."
          , TCM Doc
"It could refer to any of"
          , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat ([TCM Doc] -> TCM Doc) -> [TCM Doc] -> TCM Doc
forall a b. (a -> b) -> a -> b
$ ((QName, ConHead, Type) -> TCM Doc)
-> [(QName, ConHead, Type)] -> [TCM Doc]
forall a b. (a -> b) -> [a] -> [b]
map (QName -> TCM Doc
prettyDisamb (QName -> TCM Doc)
-> ((QName, ConHead, Type) -> QName)
-> (QName, ConHead, Type)
-> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName, ConHead, Type) -> QName
forall a b c. (a, b, c) -> a
fst3) [(QName, ConHead, Type)]
disambs
          ]

  where
    tryDisambiguate :: Bool
-> [QName]
-> QName
-> (([TCErr], [(QName, ConHead, Type)]) -> TCM (ConHead, Type))
-> TCM (ConHead, Type)
tryDisambiguate Bool
constraintsOk [QName]
cons QName
d ([TCErr], [(QName, ConHead, Type)]) -> TCM (ConHead, Type)
failure = do
      NonEmpty (Either TCErr (QName, ConHead, Type))
disambiguations <- (QName -> TCM (Either TCErr (QName, ConHead, Type)))
-> NonEmpty QName
-> TCM (NonEmpty (Either TCErr (QName, ConHead, Type)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (ExceptT TCErr TCM (QName, ConHead, Type)
-> TCM (Either TCErr (QName, ConHead, Type))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT TCErr TCM (QName, ConHead, Type)
 -> TCM (Either TCErr (QName, ConHead, Type)))
-> (QName -> ExceptT TCErr TCM (QName, ConHead, Type))
-> QName
-> TCM (Either TCErr (QName, ConHead, Type))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [QName]
-> QName
-> [Arg Term]
-> QName
-> ExceptT TCErr TCM (QName, ConHead, Type)
tryCon Bool
constraintsOk [QName]
cons QName
d [Arg Term]
pars) NonEmpty QName
cs
        -- TODO: can we be more lazy, like using the ListT monad?
      case [Either TCErr (QName, ConHead, Type)]
-> ([TCErr], [(QName, ConHead, Type)])
forall a b. [Either a b] -> ([a], [b])
partitionEithers ([Either TCErr (QName, ConHead, Type)]
 -> ([TCErr], [(QName, ConHead, Type)]))
-> [Either TCErr (QName, ConHead, Type)]
-> ([TCErr], [(QName, ConHead, Type)])
forall a b. (a -> b) -> a -> b
$ NonEmpty (Either TCErr (QName, ConHead, Type))
-> [Either TCErr (QName, ConHead, Type)]
forall a. NonEmpty a -> [a]
NonEmpty.toList NonEmpty (Either TCErr (QName, ConHead, Type))
disambiguations of
        -- Andreas, 2019-10-14: The code from which I factored out 'tryDisambiguate'
        -- did allow several disambiguations in case @constraintsOk == False@.
        -- There was no comment explaining why, but "fixing" it and insisting on a
        -- single disambiguation triggers this error in the std-lib
        -- (version 4fca6541edbf5951cff5048b61235fe87d376d84):
        --
        --   Data/List/Relation/Unary/All/Properties.agda:462,15-17
        --   Ambiguous constructor []₁.
        --   It could refer to any of
        --     _._.Pointwise.[] (introduced at Data/List/Relation/Binary/Pointwise.agda:40,6-15)
        --     [] (introduced at Data/List/Relation/Binary/Pointwise.agda:40,6-15)
        --   when checking that the pattern [] has type x ≋ y
        --
        -- There are problems with this error message (reported as issue #4130):
        --
        --   * the constructor [] is printed as []₁
        --   * the two (identical) locations point to the definition of data type Pointwise
        --     - not to the constructor []
        --     - not offering a clue which imports generated the ambiguity
        --
        -- (These should be fixed at some point.)
        -- It is not entirely clear to me that the ambiguity is safe to ignore,
        -- but let's go with it for the sake of preserving the current behavior of Agda.
        -- Thus, only when 'constraintsOk' we require 'null disambs':
        -- (Note that in Haskell, boolean implication is '<=' rather than '=>'.)
        ([TCErr]
_, (QName
c0,ConHead
c,Type
a) : [(QName, ConHead, Type)]
disambs) | Bool
constraintsOk Bool -> Bool -> Bool
forall a. Ord a => a -> a -> Bool
<= [(QName, ConHead, Type)] -> Bool
forall a. Null a => a -> Bool
null [(QName, ConHead, Type)]
disambs -> do
          -- If constructor pattern was ambiguous,
          -- 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 (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 ()
storeDisambiguatedName QName
c0
          (ConHead, Type) -> TCM (ConHead, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConHead
c,Type
a)
        ([TCErr], [(QName, ConHead, Type)])
other -> ([TCErr], [(QName, ConHead, Type)]) -> TCM (ConHead, Type)
failure ([TCErr], [(QName, ConHead, Type)])
other

    abstractConstructor :: QName -> m a
abstractConstructor QName
c = TypeError -> m a
forall (m :: * -> *) a.
(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.
(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 create new constraints?
      -> [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)
    tryCon :: Bool
-> [QName]
-> QName
-> [Arg Term]
-> QName
-> ExceptT TCErr TCM (QName, ConHead, Type)
tryCon Bool
constraintsOk [QName]
cons QName
d [Arg Term]
pars QName
c = QName -> ExceptT TCErr TCM (Either SigError Definition)
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Either SigError Definition)
getConstInfo' QName
c ExceptT TCErr TCM (Either SigError Definition)
-> (Either SigError Definition
    -> ExceptT TCErr TCM (QName, ConHead, Type))
-> ExceptT TCErr TCM (QName, ConHead, Type)
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
      Left (SigUnknown VerboseKey
err) -> ExceptT TCErr TCM (QName, ConHead, Type)
forall a. HasCallStack => a
__IMPOSSIBLE__
      Left SigError
SigAbstract -> QName -> ExceptT TCErr TCM (QName, ConHead, Type)
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 TCM () -> ExceptT TCErr TCM ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ConHead -> QName
conName ConHead
con QName -> [QName] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [QName]
cons) (ExceptT TCErr TCM () -> ExceptT TCErr TCM ())
-> ExceptT TCErr TCM () -> ExceptT TCErr TCM ()
forall a b. (a -> b) -> a -> b
$ QName -> QName -> ExceptT TCErr TCM ()
forall (m :: * -> *) a.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
QName -> QName -> m a
wrongDatatype QName
c QName
d

        -- 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.
        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
$ Bool -> (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a. Bool -> (a -> a) -> a -> a
applyUnless Bool
constraintsOk 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
$
          QName -> QName -> [Arg Term] -> TCMT IO ()
forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> [Arg Term] -> tcm ()
checkConstructorParameters QName
c QName
d [Arg Term]
pars

        -- Get the type from the original constructor
        Type
cType <- (Type -> [Arg Term] -> Type
`piApply` [Arg Term]
pars) (Type -> Type) -> (Definition -> Type) -> Definition -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType (Definition -> Type)
-> ExceptT TCErr TCM Definition -> ExceptT TCErr TCM Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ConHead -> ExceptT TCErr TCM Definition
forall (m :: * -> *). HasConstInfo m => ConHead -> m Definition
getConInfo ConHead
con

        (QName, ConHead, Type) -> ExceptT TCErr TCM (QName, ConHead, Type)
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
c, ConHead
con, Type
cType)

prettyDisamb :: QName -> TCM Doc
prettyDisamb :: QName -> TCM Doc
prettyDisamb QName
x = do
  let d :: TCM Doc
d  = QName -> TCM Doc
forall (m :: * -> *) a. (Monad m, Pretty a) => a -> m Doc
pretty (QName -> TCM Doc) -> TCMT IO QName -> TCM Doc
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> TCMT IO QName
dropTopLevelModule QName
x
  let mr :: Maybe Range
mr = [Range] -> Maybe Range
forall a. [a] -> Maybe a
lastMaybe ([Range] -> Maybe Range) -> [Range] -> Maybe Range
forall a b. (a -> b) -> a -> b
$ (Range -> Bool) -> [Range] -> [Range]
forall a. (a -> Bool) -> [a] -> [a]
filter (Range
forall a. Range' a
noRange Range -> Range -> Bool
forall a. Eq a => a -> a -> Bool
/=) ([Range] -> [Range]) -> [Range] -> [Range]
forall a b. (a -> b) -> a -> b
$ (Name -> Range) -> [Name] -> [Range]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Range
nameBindingSite ([Name] -> [Range]) -> [Name] -> [Range]
forall a b. (a -> b) -> a -> b
$ ModuleName -> [Name]
mnameToList (ModuleName -> [Name]) -> ModuleName -> [Name]
forall a b. (a -> b) -> a -> b
$ QName -> ModuleName
qnameModule QName
x
  Maybe Range -> TCM Doc -> (Range -> TCM Doc) -> TCM Doc
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe Range
mr TCM Doc
d ((Range -> TCM Doc) -> TCM Doc) -> (Range -> TCM Doc) -> TCM Doc
forall a b. (a -> b) -> a -> b
$ \ Range
r -> TCM Doc
d TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (TCM Doc
"(introduced at " TCM Doc -> TCM Doc -> TCM Doc
forall a. Semigroup a => a -> a -> a
<> Range -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Range
r TCM Doc -> TCM Doc -> TCM Doc
forall a. Semigroup a => a -> a -> a
<> TCM Doc
")")


-- | @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 :: QName -> QName -> [Arg Term] -> tcm ()
checkConstructorParameters QName
c QName
d [Arg Term]
pars = do
  QName
dc <- TCMT IO QName -> tcm QName
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 -> [Arg Term] -> tcm ()
forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> [Arg Term] -> tcm ()
checkParameters QName
dc QName
d [Arg Term]
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 :: QName -> QName -> [Arg Term] -> tcm ()
checkParameters QName
dc QName
d [Arg Term]
pars = TCMT IO () -> tcm ()
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO () -> tcm ()) -> TCMT IO () -> tcm ()
forall a b. (a -> b) -> a -> b
$ do
  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 :: [Arg Term]
vs = [Arg Term] -> Maybe [Arg Term] -> [Arg Term]
forall a. a -> Maybe a -> a
fromMaybe [Arg Term]
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe [Arg Term] -> [Arg Term]) -> Maybe [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$ Elims -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
      VerboseKey -> VerboseLevel -> TCM Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
VerboseKey -> VerboseLevel -> TCM Doc -> m ()
reportSDoc VerboseKey
"tc.lhs.split" VerboseLevel
40 (TCM Doc -> TCMT IO ()) -> TCM Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
vcat [ VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"d                   =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc)
-> (QName -> VerboseKey) -> QName -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow) QName
d
             , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"d0 (should be == d) =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc)
-> (QName -> VerboseKey) -> QName -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow) QName
d0
             , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"dc                  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (VerboseKey -> TCM Doc
forall (m :: * -> *). Monad m => VerboseKey -> m Doc
text (VerboseKey -> TCM Doc)
-> (QName -> VerboseKey) -> QName -> TCM Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> VerboseKey
forall a. Pretty a => a -> VerboseKey
prettyShow) QName
dc
             , VerboseLevel -> TCM Doc -> TCM Doc
forall (m :: * -> *). Functor m => VerboseLevel -> m Doc -> m Doc
nest VerboseLevel
2 (TCM Doc -> TCM Doc) -> TCM Doc -> TCM Doc
forall a b. (a -> b) -> a -> b
$ TCM Doc
"vs                  =" TCM Doc -> TCM Doc -> TCM Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Arg Term] -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [Arg Term]
vs
             ]
      -- 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
-> [Arg Term]
-> [Arg Term]
-> TCMT IO ()
forall (m :: * -> *).
MonadConversion m =>
[Polarity]
-> [IsForced] -> Type -> Term -> [Arg Term] -> [Arg Term] -> m ()
compareArgs [] [] Type
t (QName -> Elims -> Term
Def QName
d []) [Arg Term]
vs (VerboseLevel -> [Arg Term] -> [Arg Term]
forall a. VerboseLevel -> [a] -> [a]
take ([Arg Term] -> VerboseLevel
forall (t :: * -> *) a. Foldable t => t a -> VerboseLevel
length [Arg Term]
vs) [Arg Term]
pars)
    Term
_ -> TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__

checkSortOfSplitVar :: (MonadTCM m, MonadReduce m, MonadError TCErr m, ReadTCState m, MonadDebug m,
                        LensSort a, PrettyTCM a, LensSort ty, PrettyTCM ty)
                    => DataOrRecord -> a -> Maybe ty -> m ()
checkSortOfSplitVar :: DataOrRecord -> a -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr a
a Maybe ty
mtarget = do
  Bool
infOk <- PragmaOptions -> Bool
optOmegaInOmega (PragmaOptions -> Bool) -> m PragmaOptions -> m Bool
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> m PragmaOptions
forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
  TCM (Sort' Term) -> m (Sort' Term)
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 (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
    Type{} -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Prop{}
      | DataOrRecord
IsRecord <- DataOrRecord
dr         -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
      | Just ty
target <- Maybe ty
mtarget -> m Bool -> m () -> m ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (ty -> m Bool
forall a (m :: * -> *).
(LensSort a, PrettyTCM a, MonadReduce m, MonadDebug m) =>
a -> m Bool
isPropM ty
target) m ()
forall a. m a
splitOnPropError
      | Bool
otherwise              -> m ()
forall a. m a
splitOnPropError
    Inf{} | Bool
infOk -> () -> m ()
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    Sort' Term
_      -> TypeError -> m ()
forall (m :: * -> *) a.
(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 (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) -> TCM Doc -> TCM TypeError
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [TCM Doc] -> TCM Doc
forall (m :: * -> *). Monad m => [m Doc] -> m Doc
sep
        [ TCM Doc
"Cannot split on datatype in sort" , Sort' Term -> TCM Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (a -> Sort' Term
forall a. LensSort a => a -> Sort' Term
getSort a
a) ]

  where
    splitOnPropError :: m a
splitOnPropError = TypeError -> m a
forall (m :: * -> *) a.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError (TypeError -> m a) -> TypeError -> m a
forall a b. (a -> b) -> a -> b
$ VerboseKey -> TypeError
GenericError
      VerboseKey
"Cannot split on datatype in Prop unless target is in Prop"