{-# LANGUAGE NondecreasingIndentation #-}

module Agda.TypeChecking.Rules.Application
  ( checkArguments
  , checkArguments_
  , checkApplication
  , inferApplication
  , checkProjAppToKnownPrincipalArg
  , univChecks
  , suffixToLevel
  ) where

import Prelude hiding ( null )

import Control.Applicative        ( (<|>) )
import Control.Monad.Except       ( ExceptT, runExceptT, MonadError, catchError, throwError )
import Control.Monad.Trans.Maybe

import Data.Bifunctor
import Data.Maybe
import Data.Void
import qualified Data.Foldable as Fold
import qualified Data.IntSet   as IntSet

import Agda.Interaction.Highlighting.Generate
  ( storeDisambiguatedConstructor, storeDisambiguatedProjection )

import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Pattern (patternToExpr)
import Agda.Syntax.Abstract.Views as A
import qualified Agda.Syntax.Info as A
import Agda.Syntax.Concrete.Pretty () -- only Pretty instances
import Agda.Syntax.Common
import Agda.Syntax.Internal as I
import Agda.Syntax.Position

import Agda.TypeChecking.Conversion
import Agda.TypeChecking.Constraints
import Agda.TypeChecking.Datatypes
import Agda.TypeChecking.Free
import Agda.TypeChecking.Implicit
import Agda.TypeChecking.Injectivity
import Agda.TypeChecking.InstanceArguments (postponeInstanceConstraints)
import Agda.TypeChecking.Level
import Agda.TypeChecking.MetaVars
import Agda.TypeChecking.Modalities
import Agda.TypeChecking.Names
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Primitive hiding (Nat)
import Agda.TypeChecking.Monad
import Agda.TypeChecking.Records
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Rules.Def
import Agda.TypeChecking.Rules.Term
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Warnings (warning)

import Agda.Utils.Either
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List  ( (!!!), initWithDefault )
import qualified Agda.Utils.List as List
import Agda.Utils.List1 ( List1, pattern (:|) )
import qualified Agda.Utils.List1 as List1
import Agda.Utils.Maybe
import Agda.Utils.Monad
import Agda.Utils.Null
import Agda.Syntax.Common.Pretty ( prettyShow )
import Agda.Utils.Size
import Agda.Utils.Tuple

import Agda.Utils.Impossible

---------------------------------------------------------------------------
-- * Data structures for checking arguments
---------------------------------------------------------------------------

-- | Ranges of checked arguments, where present.
type MaybeRanges = [Maybe Range]

acElims :: ArgsCheckState a -> [Elim]
acElims :: forall a. ArgsCheckState a -> Elims
acElims = (CheckedArg -> Elim) -> [CheckedArg] -> Elims
forall a b. (a -> b) -> [a] -> [b]
map CheckedArg -> Elim
caElim ([CheckedArg] -> Elims)
-> (ArgsCheckState a -> [CheckedArg]) -> ArgsCheckState a -> Elims
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgsCheckState a -> [CheckedArg]
forall a. ArgsCheckState a -> [CheckedArg]
acCheckedArgs

acRanges :: ArgsCheckState a -> MaybeRanges
acRanges :: forall a. ArgsCheckState a -> MaybeRanges
acRanges = (CheckedArg -> Maybe Range) -> [CheckedArg] -> MaybeRanges
forall a b. (a -> b) -> [a] -> [b]
map CheckedArg -> Maybe Range
caRange ([CheckedArg] -> MaybeRanges)
-> (ArgsCheckState a -> [CheckedArg])
-> ArgsCheckState a
-> MaybeRanges
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgsCheckState a -> [CheckedArg]
forall a. ArgsCheckState a -> [CheckedArg]
acCheckedArgs

setACElims :: [Elim] -> ArgsCheckState a -> ArgsCheckState a
setACElims :: forall a. Elims -> ArgsCheckState a -> ArgsCheckState a
setACElims Elims
es ArgsCheckState a
st = ArgsCheckState a
st{ acCheckedArgs = go es (acCheckedArgs st) }
  where
    go :: Elims -> [CheckedArg] -> [CheckedArg]
go [] [] = []
    go (Elim
e : Elims
es) (CheckedArg
ca : [CheckedArg]
cas) = CheckedArg
ca{ caElim = e } CheckedArg -> [CheckedArg] -> [CheckedArg]
forall a. a -> [a] -> [a]
: Elims -> [CheckedArg] -> [CheckedArg]
go Elims
es [CheckedArg]
cas
    go Elims
_ [CheckedArg]
_ = [CheckedArg]
forall a. HasCallStack => a
__IMPOSSIBLE__

-- | A checked argument without constraint or range.
defaultCheckedArg :: Elim -> CheckedArg
defaultCheckedArg :: Elim -> CheckedArg
defaultCheckedArg Elim
e = CheckedArg { caElim :: Elim
caElim = Elim
e, caRange :: Maybe Range
caRange = Maybe Range
forall a. Maybe a
Nothing, caConstraint :: Maybe (Abs Constraint)
caConstraint = Maybe (Abs Constraint)
forall a. Maybe a
Nothing }

-----------------------------------------------------------------------------
-- * Applications
-----------------------------------------------------------------------------

acHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> [Constraint]
acHeadConstraints :: forall a. (Elims -> Term) -> ArgsCheckState a -> [Constraint]
acHeadConstraints Elims -> Term
hd = (Elims -> Term) -> [CheckedArg] -> [Constraint]
go Elims -> Term
hd ([CheckedArg] -> [Constraint])
-> (ArgsCheckState a -> [CheckedArg])
-> ArgsCheckState a
-> [Constraint]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. ArgsCheckState a -> [CheckedArg]
forall a. ArgsCheckState a -> [CheckedArg]
acCheckedArgs
  where
    go :: (Elims -> Term) -> [CheckedArg] -> [Constraint]
    go :: (Elims -> Term) -> [CheckedArg] -> [Constraint]
go Elims -> Term
hd = \case
      [] -> []
      CheckedArg Elim
e Maybe Range
_ Maybe (Abs Constraint)
mc : [CheckedArg]
cas -> Maybe (Abs Constraint)
-> (Abs Constraint -> [Constraint] -> [Constraint])
-> [Constraint]
-> [Constraint]
forall b a. Maybe b -> (b -> a -> a) -> a -> a
applyWhenJust Maybe (Abs Constraint)
mc (\ Abs Constraint
c -> (Abs Constraint -> SubstArg Constraint -> Constraint
forall a. Subst a => Abs a -> SubstArg a -> a
lazyAbsApp Abs Constraint
c (Elims -> Term
hd []) Constraint -> [Constraint] -> [Constraint]
forall a. a -> [a] -> [a]
:)) ([Constraint] -> [Constraint]) -> [Constraint] -> [Constraint]
forall a b. (a -> b) -> a -> b
$
        (Elims -> Term) -> [CheckedArg] -> [Constraint]
go (Elims -> Term
hd (Elims -> Term) -> (Elims -> Elims) -> Elims -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Elim
e Elim -> Elims -> Elims
forall a. a -> [a] -> [a]
:)) [CheckedArg]
cas

checkHeadConstraints :: (Elims -> Term) -> ArgsCheckState a -> TCM Term
checkHeadConstraints :: forall a. (Elims -> Term) -> ArgsCheckState a -> TCM Term
checkHeadConstraints Elims -> Term
hd ArgsCheckState a
st = do
  (Constraint -> TCMT IO ()) -> [Constraint] -> TCMT IO ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Constraint -> TCMT IO ()
solveConstraint_ ((Elims -> Term) -> ArgsCheckState a -> [Constraint]
forall a. (Elims -> Term) -> ArgsCheckState a -> [Constraint]
acHeadConstraints Elims -> Term
hd ArgsCheckState a
st)
  Term -> TCM Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> TCM Term) -> Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ Elims -> Term
hd (ArgsCheckState a -> Elims
forall a. ArgsCheckState a -> Elims
acElims ArgsCheckState a
st)


-- | @checkApplication hd args e t@ checks an application.
--   Precondition: @Application hs args = appView e@
--
--   @checkApplication@ disambiguates constructors
--   (and continues to 'checkConstructorApplication')
--   and resolves pattern synonyms.
checkApplication :: Comparison -> A.Expr -> A.Args -> A.Expr -> Type -> TCM Term
checkApplication :: Comparison -> Expr -> [NamedArg Expr] -> Expr -> Type -> TCM Term
checkApplication Comparison
cmp Expr
hd [NamedArg Expr]
args Expr
e Type
t =
  Expr -> TCM Term -> TCM Term
forall a. Expr -> TCM a -> TCM a
turnOffExpandLastIfExistingMeta Expr
hd (TCM Term -> TCM Term) -> TCM Term -> TCM Term
forall a b. (a -> b) -> a -> b
$
  TCM Term -> TCM Term
forall a. TCM a -> TCM a
postponeInstanceConstraints (TCM Term -> TCM Term) -> TCM Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.check.app" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"checkApplication"
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"hd   = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Expr
hd
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"args = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep ((NamedArg Expr -> TCMT IO Doc) -> [NamedArg Expr] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA [NamedArg Expr]
args)
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"e    = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Expr
e
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"t    = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t
    ]
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.check.app" Nat
70 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"checkApplication (raw)"
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"hd   = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show Expr
hd
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"args = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [NamedArg Expr] -> [Char]
forall a. Show a => a -> [Char]
show ([NamedArg Expr] -> [NamedArg Expr]
forall a. ExprLike a => a -> a
deepUnscope [NamedArg Expr]
args)
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"e    = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Expr -> [Char]
forall a. Show a => a -> [Char]
show (Expr -> Expr
forall a. ExprLike a => a -> a
deepUnscope Expr
e)
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"t    = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Type -> [Char]
forall a. Show a => a -> [Char]
show Type
t
    ]
  case Expr -> Expr
unScope Expr
hd of
    -- Subcase: unambiguous projection
    A.Proj ProjOrigin
o AmbiguousQName
p | Just QName
x <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
p -> do
      Comparison
-> Expr
-> Type
-> QName
-> ProjOrigin
-> Expr
-> [NamedArg Expr]
-> TCM Term
checkUnambiguousProjectionApplication Comparison
cmp Expr
e Type
t QName
x ProjOrigin
o Expr
hd [NamedArg Expr]
args

    -- Subcase: ambiguous projection
    A.Proj ProjOrigin
o AmbiguousQName
p -> do
      Comparison
-> Expr
-> ProjOrigin
-> List1 QName
-> [NamedArg Expr]
-> Type
-> TCM Term
checkProjApp Comparison
cmp Expr
e ProjOrigin
o (AmbiguousQName -> List1 QName
unAmbQ AmbiguousQName
p) [NamedArg Expr]
args Type
t

    -- Subcase: unambiguous constructor
    A.Con AmbiguousQName
ambC | Just QName
c <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
ambC -> do
      -- augment c with record fields, but do not revert to original name
      con <-
        (SigError -> TCMT IO ConHead)
-> TCMT IO (Either SigError ConHead) -> TCMT IO ConHead
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
fromRightM
          (TCMT IO ConHead -> SigError -> TCMT IO ConHead
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
m a -> SigError -> m a
sigError (TypeError -> TCMT IO ConHead
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ConHead) -> TypeError -> TCMT IO ConHead
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
AbstractConstructorNotInScope QName
c)) (TCMT IO (Either SigError ConHead) -> TCMT IO ConHead)
-> TCMT IO (Either SigError ConHead) -> TCMT IO ConHead
forall a b. (a -> b) -> a -> b
$
          QName -> TCMT IO (Either SigError ConHead)
getOrigConHead QName
c
      checkConstructorApplication cmp e t con args

    -- Subcase: ambiguous constructor
    A.Con (AmbQ List1 QName
cs0) -> List1 QName -> [NamedArg Expr] -> Type -> DisambiguateConstructor
disambiguateConstructor List1 QName
cs0 [NamedArg Expr]
args Type
t DisambiguateConstructor
-> (Either Blocker ConHead -> TCM Term) -> TCM Term
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \ case
      Left Blocker
unblock -> TypeCheckingProblem -> Blocker -> TCM Term
postponeTypeCheckingProblem (Comparison -> Expr -> Type -> TypeCheckingProblem
CheckExpr Comparison
cmp Expr
e Type
t) Blocker
unblock
      Right ConHead
c      -> Comparison
-> Expr -> Type -> ConHead -> [NamedArg Expr] -> TCM Term
checkConstructorApplication Comparison
cmp Expr
e Type
t ConHead
c [NamedArg Expr]
args

    -- Subcase: pattern synonym
    A.PatternSyn AmbiguousQName
n -> do
      (ns, p) <- AmbiguousQName -> TCM ([WithHiding Name], Pattern' Void)
lookupPatternSyn AmbiguousQName
n
      p <- return $ setRange (getRange n) $ killRange $ vacuous p   -- Pattern' Void -> Pattern' Expr
      -- Expand the pattern synonym by substituting for
      -- the arguments we have got and lambda-lifting
      -- over the ones we haven't.
      let meta Hiding
h Range
r = MetaInfo -> Expr
A.Underscore (MetaInfo -> Expr) -> MetaInfo -> Expr
forall a b. (a -> b) -> a -> b
$ MetaInfo
A.emptyMetaInfo{ A.metaRange = r, A.metaKind = A.hidingToMetaKind h }   -- TODO: name suggestion
      case A.insertImplicitPatSynArgs meta (getRange n) ns args of
        Maybe ([(Name, Expr)], [WithHiding Name])
Nothing      -> TypeError -> TCM Term
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCM Term) -> TypeError -> TCM Term
forall a b. (a -> b) -> a -> b
$ AmbiguousQName -> TypeError
BadArgumentsToPatternSynonym AmbiguousQName
n
        Just ([(Name, Expr)]
s, [WithHiding Name]
ns) -> do
          let p' :: Expr
p' = Pattern' Expr -> Expr
patternToExpr Pattern' Expr
p
              e' :: Expr
e' = [WithHiding Name] -> Expr -> Expr
A.lambdaLiftExpr [WithHiding Name]
ns ([(Name, Expr)] -> Expr -> Expr
forall a. SubstExpr a => [(Name, Expr)] -> a -> a
A.substExpr [(Name, Expr)]
s Expr
p')
          Comparison -> Expr -> Type -> TCM Term
checkExpr' Comparison
cmp Expr
e' Type
t

    -- Subcase: macro
    A.Macro QName
x -> do
      -- First go: no parameters
      TelV tel _ <- Type -> TCMT IO (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView (Type -> TCMT IO (TelV Type))
-> (Definition -> Type) -> Definition -> TCMT IO (TelV Type)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType (Definition -> TCMT IO (TelV Type))
-> TCMT IO Definition -> TCMT IO (TelV Type)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Definition -> TCMT IO Definition
forall (m :: * -> *).
(Functor m, HasConstInfo m, HasOptions m, ReadTCState m,
 MonadTCEnv m, MonadDebug m) =>
Definition -> m Definition
instantiateDef (Definition -> TCMT IO Definition)
-> TCMT IO Definition -> TCMT IO Definition
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
x

      tTerm <- primAgdaTerm
      tName <- primQName

      -- Andreas, 2021-05-13, can we use @initWithDefault __IMPOSSIBLE__@ here?
      let argTel   = [Dom' Term ([Char], Type)] -> [Dom' Term ([Char], Type)]
forall a. HasCallStack => [a] -> [a]
init ([Dom' Term ([Char], Type)] -> [Dom' Term ([Char], Type)])
-> [Dom' Term ([Char], Type)] -> [Dom' Term ([Char], Type)]
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> [Dom' Term ([Char], Type)]
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Tele (Dom Type)
tel -- last argument is the hole term

          -- inspect macro type to figure out if arguments need to be wrapped in quote/quoteTerm
          mkArg :: Type -> NamedArg A.Expr -> NamedArg A.Expr
          mkArg Type
t NamedArg Expr
a | Type -> Term
forall t a. Type'' t a -> a
unEl Type
t Term -> Term -> Bool
forall a. Eq a => a -> a -> Bool
== Term
tTerm =
            ((Named_ Expr -> Named_ Expr) -> NamedArg Expr -> NamedArg Expr
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named_ Expr -> Named_ Expr) -> NamedArg Expr -> NamedArg Expr)
-> ((Expr -> Expr) -> Named_ Expr -> Named_ Expr)
-> (Expr -> Expr)
-> NamedArg Expr
-> NamedArg Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> Expr) -> Named_ Expr -> Named_ Expr
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap)
              (AppInfo -> Expr -> NamedArg Expr -> Expr
A.App (Range -> AppInfo
A.defaultAppInfo (NamedArg Expr -> Range
forall a. HasRange a => a -> Range
getRange NamedArg Expr
a)) (ExprInfo -> Expr
A.QuoteTerm ExprInfo
A.exprNoRange) (NamedArg Expr -> Expr) -> (Expr -> NamedArg Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> NamedArg Expr
forall a. a -> NamedArg a
defaultNamedArg) NamedArg Expr
a
          mkArg Type
t NamedArg Expr
a | Type -> Term
forall t a. Type'' t a -> a
unEl Type
t Term -> Term -> Bool
forall a. Eq a => a -> a -> Bool
== Term
tName =
            ((Named_ Expr -> Named_ Expr) -> NamedArg Expr -> NamedArg Expr
forall a b. (a -> b) -> Arg a -> Arg b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((Named_ Expr -> Named_ Expr) -> NamedArg Expr -> NamedArg Expr)
-> ((Expr -> Expr) -> Named_ Expr -> Named_ Expr)
-> (Expr -> Expr)
-> NamedArg Expr
-> NamedArg Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Expr -> Expr) -> Named_ Expr -> Named_ Expr
forall a b. (a -> b) -> Named NamedName a -> Named NamedName b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap)
              (AppInfo -> Expr -> NamedArg Expr -> Expr
A.App (Range -> AppInfo
A.defaultAppInfo (NamedArg Expr -> Range
forall a. HasRange a => a -> Range
getRange NamedArg Expr
a)) (ExprInfo -> Expr
A.Quote ExprInfo
A.exprNoRange) (NamedArg Expr -> Expr) -> (Expr -> NamedArg Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> NamedArg Expr
forall a. a -> NamedArg a
defaultNamedArg) NamedArg Expr
a
          mkArg Type
t NamedArg Expr
a | Bool
otherwise = NamedArg Expr
a

          makeArgs :: [Dom (String, Type)] -> [NamedArg A.Expr] -> ([NamedArg A.Expr], [NamedArg A.Expr])
          makeArgs [] [NamedArg Expr]
args = ([], [NamedArg Expr]
args)
          makeArgs [Dom' Term ([Char], Type)]
_  []   = ([], [])
          makeArgs tel :: [Dom' Term ([Char], Type)]
tel@(Dom' Term ([Char], Type)
d : [Dom' Term ([Char], Type)]
tel1) (NamedArg Expr
arg : [NamedArg Expr]
args) =
            case NamedArg Expr -> [Dom' Term ([Char], Type)] -> ImplicitInsertion
forall e a. NamedArg e -> [Dom a] -> ImplicitInsertion
insertImplicit NamedArg Expr
arg [Dom' Term ([Char], Type)]
tel of
              ImplicitInsertion
NoInsertNeeded -> ([NamedArg Expr] -> [NamedArg Expr])
-> ([NamedArg Expr], [NamedArg Expr])
-> ([NamedArg Expr], [NamedArg Expr])
forall a b c. (a -> b) -> (a, c) -> (b, c)
forall (p :: * -> * -> *) a b c.
Bifunctor p =>
(a -> b) -> p a c -> p b c
first (Type -> NamedArg Expr -> NamedArg Expr
mkArg (([Char], Type) -> Type
forall a b. (a, b) -> b
snd (([Char], Type) -> Type) -> ([Char], Type) -> Type
forall a b. (a -> b) -> a -> b
$ Dom' Term ([Char], Type) -> ([Char], Type)
forall t e. Dom' t e -> e
unDom Dom' Term ([Char], Type)
d) NamedArg Expr
arg NamedArg Expr -> [NamedArg Expr] -> [NamedArg Expr]
forall a. a -> [a] -> [a]
:) (([NamedArg Expr], [NamedArg Expr])
 -> ([NamedArg Expr], [NamedArg Expr]))
-> ([NamedArg Expr], [NamedArg Expr])
-> ([NamedArg Expr], [NamedArg Expr])
forall a b. (a -> b) -> a -> b
$ [Dom' Term ([Char], Type)]
-> [NamedArg Expr] -> ([NamedArg Expr], [NamedArg Expr])
makeArgs [Dom' Term ([Char], Type)]
tel1 [NamedArg Expr]
args
              ImpInsert [Dom ()]
is   -> [Dom' Term ([Char], Type)]
-> [NamedArg Expr] -> ([NamedArg Expr], [NamedArg Expr])
makeArgs (Nat -> [Dom' Term ([Char], Type)] -> [Dom' Term ([Char], Type)]
forall a. Nat -> [a] -> [a]
drop ([Dom ()] -> Nat
forall a. [a] -> Nat
forall (t :: * -> *) a. Foldable t => t a -> Nat
length [Dom ()]
is) [Dom' Term ([Char], Type)]
tel) (NamedArg Expr
arg NamedArg Expr -> [NamedArg Expr] -> [NamedArg Expr]
forall a. a -> [a] -> [a]
: [NamedArg Expr]
args)
              ImplicitInsertion
BadImplicits   -> (NamedArg Expr
arg NamedArg Expr -> [NamedArg Expr] -> [NamedArg Expr]
forall a. a -> [a] -> [a]
: [NamedArg Expr]
args, [])  -- fail later in checkHeadApplication
              NoSuchName{}   -> (NamedArg Expr
arg NamedArg Expr -> [NamedArg Expr] -> [NamedArg Expr]
forall a. a -> [a] -> [a]
: [NamedArg Expr]
args, [])  -- ditto

          (macroArgs, otherArgs) = makeArgs argTel args
          unq = AppInfo -> Expr -> NamedArg Expr -> Expr
A.App (Range -> AppInfo
A.defaultAppInfo (Range -> AppInfo) -> Range -> AppInfo
forall a b. (a -> b) -> a -> b
$ QName -> [NamedArg Expr] -> Range
forall u t. (HasRange u, HasRange t) => u -> t -> Range
fuseRange QName
x [NamedArg Expr]
args) (ExprInfo -> Expr
A.Unquote ExprInfo
A.exprNoRange) (NamedArg Expr -> Expr) -> (Expr -> NamedArg Expr) -> Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> NamedArg Expr
forall a. a -> NamedArg a
defaultNamedArg

          desugared = Expr -> [NamedArg Expr] -> Expr
A.app (Expr -> Expr
unq (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ AppView -> Expr
unAppView (AppView -> Expr) -> AppView -> Expr
forall a b. (a -> b) -> a -> b
$ Expr -> [NamedArg Expr] -> AppView
forall arg. Expr -> [NamedArg arg] -> AppView' arg
Application (QName -> Expr
A.Def QName
x) ([NamedArg Expr] -> AppView) -> [NamedArg Expr] -> AppView
forall a b. (a -> b) -> a -> b
$ [NamedArg Expr]
macroArgs) [NamedArg Expr]
otherArgs

      checkExpr' cmp desugared t

    -- Subcase: unquote
    A.Unquote ExprInfo
_
      | [NamedArg Expr
arg] <- [NamedArg Expr]
args -> do
          (_, hole) <- RunMetaOccursCheck -> Comparison -> Type -> TCMT IO (MetaId, Term)
forall (m :: * -> *).
MonadMetaSolver m =>
RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)
newValueMeta RunMetaOccursCheck
RunMetaOccursCheck Comparison
CmpLeq Type
t
          unquoteM (namedArg arg) hole t
          return hole
      | NamedArg Expr
arg : [NamedArg Expr]
args <- [NamedArg Expr]
args -> do
          -- Example: unquote v a b : A
          --  Create meta H : (x : X) (y : Y x) → Z x y for the hole
          --  Check a : X, b : Y a
          --  Run the tactic on H
          --  Check H a b : A
          tel    <- [NamedArg Expr] -> TCM (Tele (Dom Type))
forall a. [Arg a] -> TCM (Tele (Dom Type))
metaTel [NamedArg Expr]
args                    -- (x : X) (y : Y x)
          target <- addContext tel newTypeMeta_     -- Z x y
          let holeType = Tele (Dom Type) -> Type -> Type
telePi_ Tele (Dom Type)
tel Type
target         -- (x : X) (y : Y x) → Z x y
          (Just vs, EmptyTel) <- mapFst allApplyElims <$> checkArguments_ CmpLeq ExpandLast (getRange args) args tel
                                                    -- a b : (x : X) (y : Y x)
          (_, hole) <- newValueMeta RunMetaOccursCheck CmpLeq holeType
          unquoteM (namedArg arg) hole holeType
          let rho = [Term] -> [Term]
forall a. [a] -> [a]
reverse ((Arg Term -> Term) -> [Arg Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Term
forall e. Arg e -> e
unArg [Arg Term]
vs) [Term] -> Substitution' Term -> Substitution' Term
forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# Substitution' Term
forall a. Substitution' a
IdS  -- [x := a, y := b]
          coerce CmpEq (apply hole vs) (applySubst rho target) t -- H a b : A
      where
        metaTel :: [Arg a] -> TCM Telescope
        metaTel :: forall a. [Arg a] -> TCM (Tele (Dom Type))
metaTel []           = Tele (Dom Type) -> TCM (Tele (Dom Type))
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure Tele (Dom Type)
forall a. Tele a
EmptyTel
        metaTel (Arg a
arg : [Arg a]
args) = do
          a <- TCMT IO Type
newTypeMeta_
          let dom = Type
a Type -> Dom' Term a -> Dom Type
forall a b. a -> Dom' Term b -> Dom' Term a
forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ Arg a -> Dom' Term a
forall a. Arg a -> Dom a
domFromArg Arg a
arg
          ExtendTel dom . Abs "x" <$>
            addContext ("x" :: String, dom) (metaTel args)

    -- Subcase: defined symbol or variable.
    Expr
_ -> do
      v <- Comparison -> Expr -> Type -> Expr -> [NamedArg Expr] -> TCM Term
checkHeadApplication Comparison
cmp Expr
e Type
t Expr
hd [NamedArg Expr]
args
      reportSDoc "tc.term.app" 30 $ vcat
        [ "checkApplication: checkHeadApplication returned"
        , nest 2 $ "v = " <+> prettyTCM v
        ]
      return v

-- | Precondition: @Application hd args = appView e@.
inferApplication :: ExpandHidden -> A.Expr -> A.Args -> A.Expr -> TCM (Term, Type)
inferApplication :: ExpandHidden -> Expr -> [NamedArg Expr] -> Expr -> TCM (Term, Type)
inferApplication ExpandHidden
exh Expr
hd [NamedArg Expr]
args Expr
e | Bool -> Bool
not (Expr -> Bool
defOrVar Expr
hd) = do
  t <- TCMT IO Type -> TCMT IO Type
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
workOnTypes (TCMT IO Type -> TCMT IO Type) -> TCMT IO Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Type
newTypeMeta_
  v <- checkExpr' CmpEq e t
  return (v, t)
inferApplication ExpandHidden
exh Expr
hd [NamedArg Expr]
args Expr
e = TCM (Term, Type) -> TCM (Term, Type)
forall a. TCM a -> TCM a
postponeInstanceConstraints (TCM (Term, Type) -> TCM (Term, Type))
-> TCM (Term, Type) -> TCM (Term, Type)
forall a b. (a -> b) -> a -> b
$ do
  SortKit{..} <- TCMT IO SortKit
forall (m :: * -> *).
(HasBuiltins m, MonadTCError m, HasOptions m) =>
m SortKit
sortKit
  case unScope hd of
    A.Proj ProjOrigin
o AmbiguousQName
p | AmbiguousQName -> Bool
isAmbiguous AmbiguousQName
p -> Expr
-> ProjOrigin -> List1 QName -> [NamedArg Expr] -> TCM (Term, Type)
inferProjApp Expr
e ProjOrigin
o (AmbiguousQName -> List1 QName
unAmbQ AmbiguousQName
p) [NamedArg Expr]
args
    A.Def' QName
x Suffix
s | Just (UnivSize
sz, Univ
u) <- QName -> Maybe (UnivSize, Univ)
isNameOfUniv QName
x -> UnivSize
-> Univ
-> Expr
-> QName
-> Suffix
-> [NamedArg Expr]
-> TCM (Term, Type)
inferUniv UnivSize
sz Univ
u Expr
e QName
x Suffix
s [NamedArg Expr]
args
    Expr
_ -> do
      (f, t0) <- Expr -> TCM (Elims -> Term, Type)
inferHead Expr
hd
      let r = Expr -> Range
forall a. HasRange a => a -> Range
getRange Expr
hd
      res <- runExceptT $ checkArgumentsE CmpEq exh (getRange hd) args t0 Nothing
      case res of
        Right st :: ArgsCheckState CheckedTarget
st@(ACState{acType :: forall a. ArgsCheckState a -> Type
acType = Type
t1}) -> (Term -> (Term, Type)) -> TCM Term -> TCM (Term, Type)
forall a b. (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (,Type
t1) (TCM Term -> TCM (Term, Type)) -> TCM Term -> TCM (Term, Type)
forall a b. (a -> b) -> a -> b
$ Term -> TCM Term
forall (m :: * -> *). PureTCM m => Term -> m Term
unfoldInlined (Term -> TCM Term) -> TCM Term -> TCM Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Elims -> Term) -> ArgsCheckState CheckedTarget -> TCM Term
forall a. (Elims -> Term) -> ArgsCheckState a -> TCM Term
checkHeadConstraints Elims -> Term
f ArgsCheckState CheckedTarget
st
        Left ArgsCheckState [NamedArg Expr]
problem -> do
          t <- TCMT IO Type -> TCMT IO Type
forall (m :: * -> *) a.
(MonadTCEnv m, HasOptions m, MonadDebug m) =>
m a -> m a
workOnTypes (TCMT IO Type -> TCMT IO Type) -> TCMT IO Type -> TCMT IO Type
forall a b. (a -> b) -> a -> b
$ TCMT IO Type
newTypeMeta_
          v <- postponeArgs problem CmpEq exh r args t $ \ ArgsCheckState CheckedTarget
st -> Term -> TCM Term
forall (m :: * -> *). PureTCM m => Term -> m Term
unfoldInlined (Term -> TCM Term) -> TCM Term -> TCM Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< (Elims -> Term) -> ArgsCheckState CheckedTarget -> TCM Term
forall a. (Elims -> Term) -> ArgsCheckState a -> TCM Term
checkHeadConstraints Elims -> Term
f ArgsCheckState CheckedTarget
st
          return (v, t)

-----------------------------------------------------------------------------
-- * Heads
-----------------------------------------------------------------------------

inferHeadDef :: ProjOrigin -> QName -> TCM (Elims -> Term, Type)
inferHeadDef :: ProjOrigin -> QName -> TCM (Elims -> Term, Type)
inferHeadDef ProjOrigin
o QName
x = do
  -- Andreas, 2022-03-07, issue #5809: don't drop parameters of irrelevant projections.
  proj <- QName -> TCMT IO (Maybe Projection)
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Maybe Projection)
isRelevantProjection QName
x
  rel  <- getRelevance . defArgInfo <$> getConstInfo x
  let app =
        case Maybe Projection
proj of
          Maybe Projection
Nothing -> \ [Arg Term]
args -> QName -> Elims -> Term
Def QName
x (Elims -> Term) -> Elims -> Term
forall a b. (a -> b) -> a -> b
$ (Arg Term -> Elim) -> [Arg Term] -> Elims
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply [Arg Term]
args
          Just Projection
p  -> \ [Arg Term]
args -> Projection -> ProjOrigin -> Relevance -> [Arg Term] -> Term
projDropParsApply Projection
p ProjOrigin
o Relevance
rel [Arg Term]
args
  mapFst applyE <$> inferDef app x

-- | Infer the type of a head thing (variable, function symbol, or constructor).
--   We return a function that applies the head to arguments.
--   This is because in case of a constructor we want to drop the parameters.
inferHead :: A.Expr -> TCM (Elims -> Term, Type)
inferHead :: Expr -> TCM (Elims -> Term, Type)
inferHead Expr
e = do
  case Expr
e of
    A.Var Name
x -> do -- traceCall (InferVar x) $ do
      (u, a) <- Name -> TCMT IO (Term, Dom Type)
forall (m :: * -> *).
(MonadDebug m, MonadTCEnv m) =>
Name -> m (Term, Dom Type)
getVarInfo Name
x
      reportSDoc "tc.term.var" 20 $ hsep
        [ "variable" , prettyTCM x
        , "(" , text (show u) , ")"
        , "has type:" , prettyTCM a
        ]
      unless (usableRelevance a) $
        typeError $ VariableIsIrrelevant x
      -- Andreas, 2019-06-18, LAIM 2019, issue #3855:
      -- Conor McBride style quantity judgement:
      -- The available quantity for variable x must be below
      -- the required quantity to construct the term x.
      -- Note: this whole thing does not work for linearity, where we need some actual arithmetics.
      unlessM ((getQuantity a `moreQuantity`) <$> viewTC eQuantity) $
        typeError $ VariableIsErased x

      unless (usableCohesion a) $
        typeError $ VariableIsOfUnusableCohesion x (getCohesion a)

      return (applyE u, unDom a)

    A.Def QName
x  -> ProjOrigin -> QName -> TCM (Elims -> Term, Type)
inferHeadDef ProjOrigin
ProjPrefix QName
x
    A.Def'{} -> TCM (Elims -> Term, Type)
forall a. HasCallStack => a
__IMPOSSIBLE__ -- handled in checkHeadApplication and inferApplication

    A.Proj ProjOrigin
o AmbiguousQName
ambP | Just QName
d <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
ambP -> ProjOrigin -> QName -> TCM (Elims -> Term, Type)
inferHeadDef ProjOrigin
o QName
d
    A.Proj{} -> TCM (Elims -> Term, Type)
forall a. HasCallStack => a
__IMPOSSIBLE__ -- inferHead will only be called on unambiguous projections

    A.Con AmbiguousQName
ambC | Just QName
c <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
ambC -> do

      -- Constructors are polymorphic internally.
      -- So, when building the constructor term
      -- we should throw away arguments corresponding to parameters.

      -- First, inferDef will try to apply the constructor
      -- to the free parameters of the current context. We ignore that.
      con <-
        (SigError -> TCMT IO ConHead)
-> TCMT IO (Either SigError ConHead) -> TCMT IO ConHead
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> m (Either a b) -> m b
fromRightM
          (TCMT IO ConHead -> SigError -> TCMT IO ConHead
forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
m a -> SigError -> m a
sigError (TypeError -> TCMT IO ConHead
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ConHead) -> TypeError -> TCMT IO ConHead
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
AbstractConstructorNotInScope QName
c)) (TCMT IO (Either SigError ConHead) -> TCMT IO ConHead)
-> TCMT IO (Either SigError ConHead) -> TCMT IO ConHead
forall a b. (a -> b) -> a -> b
$
          QName -> TCMT IO (Either SigError ConHead)
getOrigConHead QName
c
      (u, a) <- inferDef (\ [Arg Term]
_ -> ConHead -> ConInfo -> Elims -> Term
Con ConHead
con ConInfo
ConOCon []) c

      -- Next get the number of parameters in the current context.
      Constructor{conPars = n} <- theDef <$> (instantiateDef =<< getConstInfo c)

      reportSLn "tc.term.con" 7 $ unwords [prettyShow c, "has", show n, "parameters."]

      -- So when applying the constructor throw away the parameters.
      return (applyE u . drop n, a)
    A.Con{} -> TCM (Elims -> Term, Type)
forall a. HasCallStack => a
__IMPOSSIBLE__  -- inferHead will only be called on unambiguous constructors
    A.QuestionMark MetaInfo
i InteractionId
ii -> MetaInfo
-> (Comparison -> Type -> TCMT IO (MetaId, Term))
-> TCM (Elims -> Term, Type)
inferMeta MetaInfo
i (InteractionId -> Comparison -> Type -> TCMT IO (MetaId, Term)
newQuestionMark InteractionId
ii)
    A.Underscore MetaInfo
i      -> MetaInfo
-> (Comparison -> Type -> TCMT IO (MetaId, Term))
-> TCM (Elims -> Term, Type)
inferMeta MetaInfo
i (MetaInfo
-> RunMetaOccursCheck
-> Comparison
-> Type
-> TCMT IO (MetaId, Term)
forall (m :: * -> *).
MonadMetaSolver m =>
MetaInfo
-> RunMetaOccursCheck -> Comparison -> Type -> m (MetaId, Term)
newValueMetaOfKind MetaInfo
i RunMetaOccursCheck
RunMetaOccursCheck)
    Expr
e -> do
      (term, t) <- Expr -> TCM (Term, Type)
inferExpr Expr
e
      return (applyE term, t)

inferDef :: (Args -> Term) -> QName -> TCM (Term, Type)
inferDef :: ([Arg Term] -> Term) -> QName -> TCM (Term, Type)
inferDef [Arg Term] -> Term
mkTerm QName
x =
  Call -> TCM (Term, Type) -> TCM (Term, Type)
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (QName -> Call
InferDef QName
x) (TCM (Term, Type) -> TCM (Term, Type))
-> TCM (Term, Type) -> TCM (Term, Type)
forall a b. (a -> b) -> a -> b
$ do
    -- getConstInfo retrieves the *absolute* (closed) type of x
    -- instantiateDef relativizes it to the current context
    d0 <- QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
x
    d  <- instantiateDef d0
    reportSDoc "tc.term.def" 10 $ "inferDef" <+> prettyTCM x
    reportSDoc "tc.term.def" 30 $ "  absolute type:    " <+> inTopContext (prettyTCM $ defType d0)
    reportSDoc "tc.term.def" 30 $ "  instantiated type:" <+> prettyTCM (defType d)
    -- Irrelevant defs are only allowed in irrelevant position.
    -- Erased defs are only allowed in erased position (see #3855).
    checkModality x d
    case theDef d of
      GeneralizableVar{} -> do
        -- Generalizable variables corresponds to metas created
        -- at the point where they should be generalized. Module parameters
        -- have already been applied to the meta, so we don't have to do that
        -- here.
        val <- GeneralizedValue -> Maybe GeneralizedValue -> GeneralizedValue
forall a. a -> Maybe a -> a
fromMaybe GeneralizedValue
forall a. HasCallStack => a
__IMPOSSIBLE__ (Maybe GeneralizedValue -> GeneralizedValue)
-> TCMT IO (Maybe GeneralizedValue) -> TCMT IO GeneralizedValue
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Lens' TCEnv (Maybe GeneralizedValue)
-> TCMT IO (Maybe GeneralizedValue)
forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC ((Map QName GeneralizedValue -> f (Map QName GeneralizedValue))
-> TCEnv -> f TCEnv
Lens' TCEnv (Map QName GeneralizedValue)
eGeneralizedVars ((Map QName GeneralizedValue -> f (Map QName GeneralizedValue))
 -> TCEnv -> f TCEnv)
-> ((Maybe GeneralizedValue -> f (Maybe GeneralizedValue))
    -> Map QName GeneralizedValue -> f (Map QName GeneralizedValue))
-> (Maybe GeneralizedValue -> f (Maybe GeneralizedValue))
-> TCEnv
-> f TCEnv
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName
-> Lens' (Map QName GeneralizedValue) (Maybe GeneralizedValue)
forall k v. Ord k => k -> Lens' (Map k v) (Maybe v)
key QName
x)
        sub <- checkpointSubstitution (genvalCheckpoint val)
        let (v, t) = applySubst sub (genvalTerm val, genvalType val)
        debug [] t v
        return (v, t)
      Defn
_ -> do
        -- since x is considered living in the top-level, we have to
        -- apply it to the current context
        vs <- QName -> TCMT IO [Arg Term]
forall (m :: * -> *).
(Functor m, HasConstInfo m, HasOptions m, ReadTCState m,
 MonadTCEnv m, MonadDebug m) =>
QName -> m [Arg Term]
freeVarsToApply QName
x
        reportSDoc "tc.term.def" 30 $ "  free vars:" <+> prettyList_ (map prettyTCM vs)
        let t = Definition -> Type
defType Definition
d
            v = [Arg Term] -> Term
mkTerm [Arg Term]
vs -- applies x to vs, dropping parameters

        -- Andrea 2019-07-16, Check that the supplied arguments
        -- respect the pure modalities of the current context.
        -- Pure modalities are based on left-division, so it does not
        -- rely on "position" like positional modalities.
        checkModalityArgs d0 vs

        debug vs t v
        return (v, t)
  where
    debug :: Args -> Type -> Term -> TCM ()
    debug :: [Arg Term] -> Type -> Term -> TCMT IO ()
debug [Arg Term]
vs Type
t Term
v = do
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.def" Nat
60 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
        TCMT IO Doc
"freeVarsToApply to def " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
hsep ((Arg Term -> TCMT IO Doc) -> [Arg Term] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc)
-> (Arg Term -> [Char]) -> Arg Term -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> [Char]
forall a. Show a => a -> [Char]
show) [Arg Term]
vs)
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.def" Nat
10 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"inferred def " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
x TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
hsep ((Arg Term -> TCMT IO Doc) -> [Arg Term] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Arg Term -> m Doc
prettyTCM [Arg Term]
vs)
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
":" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"-->" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM Term
v ]

-- | @checkHeadApplication e t hd args@ checks that @e@ has type @t@,
-- assuming that @e@ has the form @hd args@. The corresponding
-- type-checked term is returned.
--
-- If the head term @hd@ is a coinductive constructor, then a
-- top-level definition @fresh tel = hd args@ (where the clause is
-- delayed) is added, where @tel@ corresponds to the current
-- telescope. The returned term is @fresh tel@.
--
-- Precondition: The head @hd@ has to be unambiguous, and there should
-- not be any need to insert hidden lambdas.
checkHeadApplication :: Comparison -> A.Expr -> Type -> A.Expr -> [NamedArg A.Expr] -> TCM Term
checkHeadApplication :: Comparison -> Expr -> Type -> Expr -> [NamedArg Expr] -> TCM Term
checkHeadApplication Comparison
cmp Expr
e Type
t Expr
hd [NamedArg Expr]
args = do
  SortKit{..} <- TCMT IO SortKit
forall (m :: * -> *).
(HasBuiltins m, MonadTCError m, HasOptions m) =>
m SortKit
sortKit
  sharp <- fmap nameOfSharp <$> coinductionKit
  conId  <- getNameOfConstrained builtinConId
  pOr    <- getNameOfConstrained builtinPOr
  pComp  <- getNameOfConstrained builtinComp
  pHComp <- getNameOfConstrained builtinHComp
  pTrans <- getNameOfConstrained builtinTrans
  mglue  <- getNameOfConstrained builtin_glue
  mglueU  <- getNameOfConstrained builtin_glueU
  case hd of
    A.Def' QName
c Suffix
s | Just (UnivSize
sz, Univ
u) <- QName -> Maybe (UnivSize, Univ)
isNameOfUniv QName
c -> UnivSize
-> Univ
-> Comparison
-> Expr
-> Type
-> QName
-> Suffix
-> [NamedArg Expr]
-> TCM Term
checkUniv UnivSize
sz Univ
u Comparison
cmp Expr
e Type
t QName
c Suffix
s [NamedArg Expr]
args

    -- Type checking #. The # that the user can write will be a Def, but the
    -- sharp we generate in the body of the wrapper is a Con.
    A.Def QName
c | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
sharp -> Expr -> Type -> QName -> [NamedArg Expr] -> TCM Term
checkSharpApplication Expr
e Type
t QName
c [NamedArg Expr]
args

    -- Cubical primitives
    A.Def QName
c | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
pComp -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
defaultResult' (Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> TCM Term)
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
forall a b. (a -> b) -> a -> b
$ (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a. a -> Maybe a
Just ((MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]))
-> (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a b. (a -> b) -> a -> b
$ QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkPrimComp QName
c
    A.Def QName
c | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
pHComp -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
defaultResult' (Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> TCM Term)
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
forall a b. (a -> b) -> a -> b
$ (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a. a -> Maybe a
Just ((MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]))
-> (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a b. (a -> b) -> a -> b
$ QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkPrimHComp QName
c
    A.Def QName
c | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
pTrans -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
defaultResult' (Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> TCM Term)
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
forall a b. (a -> b) -> a -> b
$ (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a. a -> Maybe a
Just ((MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]))
-> (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a b. (a -> b) -> a -> b
$ QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkPrimTrans QName
c
    A.Def QName
c | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
conId -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
defaultResult' (Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> TCM Term)
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
forall a b. (a -> b) -> a -> b
$ (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a. a -> Maybe a
Just ((MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]))
-> (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a b. (a -> b) -> a -> b
$ QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkConId QName
c
    A.Def QName
c | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
pOr   -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
defaultResult' (Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> TCM Term)
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
forall a b. (a -> b) -> a -> b
$ (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a. a -> Maybe a
Just ((MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]))
-> (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a b. (a -> b) -> a -> b
$ QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkPOr QName
c
    A.Def QName
c | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mglue -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
defaultResult' (Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> TCM Term)
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
forall a b. (a -> b) -> a -> b
$ (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a. a -> Maybe a
Just ((MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]))
-> (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a b. (a -> b) -> a -> b
$ QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
check_glue QName
c
    A.Def QName
c | QName -> Maybe QName
forall a. a -> Maybe a
Just QName
c Maybe QName -> Maybe QName -> Bool
forall a. Eq a => a -> a -> Bool
== Maybe QName
mglueU -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
defaultResult' (Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> TCM Term)
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
forall a b. (a -> b) -> a -> b
$ (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a. a -> Maybe a
Just ((MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
 -> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]))
-> (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a b. (a -> b) -> a -> b
$ QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
check_glueU QName
c

    Expr
_ -> TCM Term
defaultResult
  where
  defaultResult :: TCM Term
  defaultResult :: TCM Term
defaultResult = Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
defaultResult' Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
forall a. Maybe a
Nothing
  defaultResult' :: Maybe (MaybeRanges -> Args -> Type -> TCM Args) -> TCM Term
  defaultResult' :: Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
-> TCM Term
defaultResult' Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
mk = do
    (f, t0) <- Expr -> TCM (Elims -> Term, Type)
inferHead Expr
hd
    expandLast <- asksTC envExpandLast
    checkArguments cmp expandLast (getRange hd) args t0 t $ \ st :: ArgsCheckState CheckedTarget
st@(ACState [CheckedArg]
cas Type
t1 CheckedTarget
checkedTarget) -> do
      let check :: Maybe (TCM Args)
          check :: Maybe (TCMT IO [Arg Term])
check = do
            k <- Maybe (MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term])
mk
            vs <- allApplyElims $ map caElim cas
            pure $ k (map caRange cas) vs t1
      st' <- case Maybe (TCMT IO [Arg Term])
check of
               Just TCMT IO [Arg Term]
ck -> (Elims
-> ArgsCheckState CheckedTarget -> ArgsCheckState CheckedTarget
forall a. Elims -> ArgsCheckState a -> ArgsCheckState a
`setACElims` ArgsCheckState CheckedTarget
st) (Elims -> ArgsCheckState CheckedTarget)
-> ([Arg Term] -> Elims)
-> [Arg Term]
-> ArgsCheckState CheckedTarget
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Arg Term -> Elim) -> [Arg Term] -> Elims
forall a b. (a -> b) -> [a] -> [b]
map Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply ([Arg Term] -> ArgsCheckState CheckedTarget)
-> TCMT IO [Arg Term] -> TCMT IO (ArgsCheckState CheckedTarget)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCMT IO [Arg Term]
ck
               Maybe (TCMT IO [Arg Term])
Nothing -> ArgsCheckState CheckedTarget
-> TCMT IO (ArgsCheckState CheckedTarget)
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ArgsCheckState CheckedTarget
st
      v <- unfoldInlined =<< checkHeadConstraints f st'
      coerce' cmp checkedTarget v t1 t

-- Issue #3019 and #4170: Don't insert trailing implicits when checking arguments to existing
-- metavariables.
turnOffExpandLastIfExistingMeta :: A.Expr -> TCM a -> TCM a
turnOffExpandLastIfExistingMeta :: forall a. Expr -> TCM a -> TCM a
turnOffExpandLastIfExistingMeta Expr
hd
  | Bool
isExistingMeta = TCM a -> TCM a
forall a. TCM a -> TCM a
reallyDontExpandLast
  | Bool
otherwise      = TCM a -> TCM a
forall a. a -> a
id
  where
    isExistingMeta :: Bool
isExistingMeta = Maybe MetaId -> Bool
forall a. Maybe a -> Bool
isJust (Maybe MetaId -> Bool) -> Maybe MetaId -> Bool
forall a b. (a -> b) -> a -> b
$ MetaInfo -> Maybe MetaId
A.metaNumber (MetaInfo -> Maybe MetaId) -> Maybe MetaInfo -> Maybe MetaId
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Expr -> Maybe MetaInfo
metaInfo Expr
hd
    metaInfo :: Expr -> Maybe MetaInfo
metaInfo (A.QuestionMark MetaInfo
i InteractionId
_) = MetaInfo -> Maybe MetaInfo
forall a. a -> Maybe a
Just MetaInfo
i
    metaInfo (A.Underscore MetaInfo
i)     = MetaInfo -> Maybe MetaInfo
forall a. a -> Maybe a
Just MetaInfo
i
    metaInfo (A.ScopedExpr ScopeInfo
_ Expr
e)   = Expr -> Maybe MetaInfo
metaInfo Expr
e
    metaInfo Expr
_                    = Maybe MetaInfo
forall a. Maybe a
Nothing

-----------------------------------------------------------------------------
-- * Spines
-----------------------------------------------------------------------------

traceCallE :: Call -> ExceptT e TCM r -> ExceptT e TCM r
traceCallE :: forall e r. Call -> ExceptT e (TCMT IO) r -> ExceptT e (TCMT IO) r
traceCallE Call
call ExceptT e (TCMT IO) r
m = do
  z <- TCM (Either e r) -> ExceptT e (TCMT IO) (Either e r)
forall (m :: * -> *) a. Monad m => m a -> ExceptT e m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM (Either e r) -> ExceptT e (TCMT IO) (Either e r))
-> TCM (Either e r) -> ExceptT e (TCMT IO) (Either e r)
forall a b. (a -> b) -> a -> b
$ Call -> TCM (Either e r) -> TCM (Either e r)
forall a. Call -> TCMT IO a -> TCMT IO a
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall Call
call (TCM (Either e r) -> TCM (Either e r))
-> TCM (Either e r) -> TCM (Either e r)
forall a b. (a -> b) -> a -> b
$ ExceptT e (TCMT IO) r -> TCM (Either e r)
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT ExceptT e (TCMT IO) r
m
  case z of
    Right r
e  -> r -> ExceptT e (TCMT IO) r
forall a. a -> ExceptT e (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return r
e
    Left e
err -> e -> ExceptT e (TCMT IO) r
forall a. e -> ExceptT e (TCMT IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError e
err

-- | If we've already checked the target type we don't have to call coerce.
coerce' :: Comparison -> CheckedTarget -> Term -> Type -> Type -> TCM Term
coerce' :: Comparison -> CheckedTarget -> Term -> Type -> Type -> TCM Term
coerce' Comparison
cmp CheckedTarget
NotCheckedTarget           Term
v Type
inferred Type
expected = Comparison -> Term -> Type -> Type -> TCM Term
forall (m :: * -> *).
(MonadConversion m, MonadTCM m) =>
Comparison -> Term -> Type -> Type -> m Term
coerce Comparison
cmp Term
v Type
inferred Type
expected
coerce' Comparison
cmp (CheckedTarget Maybe ProblemId
Nothing)    Term
v Type
_        Type
_        = Term -> TCM Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
v
coerce' Comparison
cmp (CheckedTarget (Just ProblemId
pid)) Term
v Type
_        Type
expected = Type -> Term -> ProblemId -> TCM Term
forall (m :: * -> *).
(MonadMetaSolver m, MonadFresh Nat m) =>
Type -> Term -> ProblemId -> m Term
blockTermOnProblem Type
expected Term
v ProblemId
pid

-- | Check a list of arguments: @checkArgs args t0 t1@ checks that
--   @t0 = Delta -> t0'@ and @args : Delta@. Inserts hidden arguments to
--   make this happen.  Returns the evaluated arguments @vs@, the remaining
--   type @t0'@ (which should be a subtype of @t1@) and any constraints @cs@
--   that have to be solved for everything to be well-formed.

checkArgumentsE :: Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Maybe Type ->
                   ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget)
checkArgumentsE :: Comparison
-> ExpandHidden
-> Range
-> [NamedArg Expr]
-> Type
-> Maybe Type
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
checkArgumentsE Comparison
sComp ExpandHidden
sExpand Range
sRange [NamedArg Expr]
sArgs Type
sFun Maybe Type
sApp = do
  sPathView <- ExceptT
  (ArgsCheckState [NamedArg Expr]) (TCMT IO) (Type -> PathView)
forall (m :: * -> *). HasBuiltins m => m (Type -> PathView)
pathView'
  checkArgumentsE'
    S{ sChecked       = NotCheckedTarget
     , sArgs          = zip sArgs $
                        List.suffixesSatisfying visible sArgs
     , sArgsLen       = length sArgs
     , sSizeLtChecked = False
     , sSkipCheck     = DontSkip
     , ..
     }

-- | State used by 'checkArgumentsE''.

data CheckArgumentsE'State = S
  { CheckArgumentsE'State -> CheckedTarget
sChecked :: CheckedTarget
    -- ^ Have we already checked the target?
  , CheckArgumentsE'State -> Comparison
sComp :: Comparison
    -- ^ Comparison to use if checking the target type.
  , CheckArgumentsE'State -> ExpandHidden
sExpand :: ExpandHidden
    -- ^ Insert trailing hidden arguments?
  , CheckArgumentsE'State -> Range
sRange :: Range
    -- ^ Range of the function.
  , CheckArgumentsE'State -> [(NamedArg Expr, Bool)]
sArgs :: [(NamedArg A.Expr, Bool)]
    -- ^ Arguments, along with information about whether a given
    -- argument and all remaining arguments are 'visible'.
  , CheckArgumentsE'State -> Nat
sArgsLen :: !Nat
    -- ^ The length of 'sArgs'.
  , CheckArgumentsE'State -> Type
sFun :: Type
    -- ^ The function's type.
  , CheckArgumentsE'State -> Maybe Type
sApp :: Maybe Type
    -- ^ The type of the application.
  , CheckArgumentsE'State -> Bool
sSizeLtChecked :: !Bool
    -- ^ Have we checked if 'sApp' is 'BoundedLt'?
  , CheckArgumentsE'State -> SkipCheck
sSkipCheck :: !SkipCheck
    -- ^ Should the target type check be skipped?
  , CheckArgumentsE'State -> Type -> PathView
sPathView :: Type -> PathView
    -- ^ The function returned by 'pathView''.
  }

-- | Should the target type check in 'checkArgumentsE'' be skipped?

data SkipCheck
  = Skip
  | SkipNext !Nat
    -- ^ Skip the given number of checks.
  | DontSkip

type CheckArgumentsE' = ExceptT (ArgsCheckState [NamedArg A.Expr]) TCM (ArgsCheckState CheckedTarget)

checkArgumentsE'
  :: CheckArgumentsE'State
  -> CheckArgumentsE'

-- Case: no arguments, do not insert trailing hidden arguments: We are done.
checkArgumentsE' :: CheckArgumentsE'State
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
checkArgumentsE' S{ sArgs :: CheckArgumentsE'State -> [(NamedArg Expr, Bool)]
sArgs = [], Bool
Nat
Maybe Type
Range
Type
Comparison
ExpandHidden
CheckedTarget
SkipCheck
Type -> PathView
sChecked :: CheckArgumentsE'State -> CheckedTarget
sArgsLen :: CheckArgumentsE'State -> Nat
sSizeLtChecked :: CheckArgumentsE'State -> Bool
sSkipCheck :: CheckArgumentsE'State -> SkipCheck
sPathView :: CheckArgumentsE'State -> Type -> PathView
sApp :: CheckArgumentsE'State -> Maybe Type
sFun :: CheckArgumentsE'State -> Type
sRange :: CheckArgumentsE'State -> Range
sExpand :: CheckArgumentsE'State -> ExpandHidden
sComp :: CheckArgumentsE'State -> Comparison
sChecked :: CheckedTarget
sComp :: Comparison
sExpand :: ExpandHidden
sRange :: Range
sArgsLen :: Nat
sFun :: Type
sApp :: Maybe Type
sSizeLtChecked :: Bool
sSkipCheck :: SkipCheck
sPathView :: Type -> PathView
.. }
  | ExpandHidden -> Bool
isDontExpandLast ExpandHidden
sExpand =
    ArgsCheckState CheckedTarget
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a. a -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (ArgsCheckState CheckedTarget
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> ArgsCheckState CheckedTarget
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. (a -> b) -> a -> b
$ ACState
      { acCheckedArgs :: [CheckedArg]
acCheckedArgs = []
      , acType :: Type
acType        = Type
sFun
      , acData :: CheckedTarget
acData        = CheckedTarget
sChecked
      }

-- Case: no arguments, but need to insert trailing hiddens.
checkArgumentsE' S{ sArgs :: CheckArgumentsE'State -> [(NamedArg Expr, Bool)]
sArgs = [], Bool
Nat
Maybe Type
Range
Type
Comparison
ExpandHidden
CheckedTarget
SkipCheck
Type -> PathView
sChecked :: CheckArgumentsE'State -> CheckedTarget
sArgsLen :: CheckArgumentsE'State -> Nat
sSizeLtChecked :: CheckArgumentsE'State -> Bool
sSkipCheck :: CheckArgumentsE'State -> SkipCheck
sPathView :: CheckArgumentsE'State -> Type -> PathView
sApp :: CheckArgumentsE'State -> Maybe Type
sFun :: CheckArgumentsE'State -> Type
sRange :: CheckArgumentsE'State -> Range
sExpand :: CheckArgumentsE'State -> ExpandHidden
sComp :: CheckArgumentsE'State -> Comparison
sChecked :: CheckedTarget
sComp :: Comparison
sExpand :: ExpandHidden
sRange :: Range
sArgsLen :: Nat
sFun :: Type
sApp :: Maybe Type
sSizeLtChecked :: Bool
sSkipCheck :: SkipCheck
sPathView :: Type -> PathView
.. } =
  Call
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall e r. Call -> ExceptT e (TCMT IO) r -> ExceptT e (TCMT IO) r
traceCallE (Range -> [NamedArg Expr] -> Type -> Maybe Type -> Call
CheckArguments Range
sRange [] Type
sFun Maybe Type
sApp) (ExceptT
   (ArgsCheckState [NamedArg Expr])
   (TCMT IO)
   (ArgsCheckState CheckedTarget)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. (a -> b) -> a -> b
$ TCMT IO (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (ArgsCheckState [NamedArg Expr]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO (ArgsCheckState CheckedTarget)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> TCMT IO (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. (a -> b) -> a -> b
$ do
    sApp    <- (Type -> TCM Term) -> Maybe Type -> TCMT IO (Maybe Term)
forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
forall (f :: * -> *) a b.
Applicative f =>
(a -> f b) -> Maybe a -> f (Maybe b)
traverse (Type -> Term
forall t a. Type'' t a -> a
unEl (Type -> Term) -> (Type -> TCMT IO Type) -> Type -> TCM Term
forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> Type -> TCMT IO Type
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce) Maybe Type
sApp
    (us, t) <- implicitArgs (-1) (expand sApp) sFun
    return $ ACState
      { acCheckedArgs = map (defaultCheckedArg . Apply) us
      , acType        = t
      , acData        = sChecked
      }
  where
  expand :: Maybe Term -> Hiding -> Bool
expand (Just (Pi Dom Type
dom Abs Type
_)) Hiding
Hidden     = Bool -> Bool
not (Dom Type -> Bool
forall a. LensHiding a => a -> Bool
hidden Dom Type
dom)
  expand Maybe Term
_                 Hiding
Hidden     = Bool
True
  expand (Just (Pi Dom Type
dom Abs Type
_)) Instance{} = Bool -> Bool
not (Dom Type -> Bool
forall a. LensHiding a => a -> Bool
isInstance Dom Type
dom)
  expand Maybe Term
_                 Instance{} = Bool
True
  expand Maybe Term
_                 Hiding
NotHidden  = Bool
False

-- Case: argument given.
checkArgumentsE'
  s :: CheckArgumentsE'State
s@S{ sArgs :: CheckArgumentsE'State -> [(NamedArg Expr, Bool)]
sArgs = sArgs :: [(NamedArg Expr, Bool)]
sArgs@((arg :: NamedArg Expr
arg@(Arg ArgInfo
info Named_ Expr
e), Bool
sArgsVisible) : [(NamedArg Expr, Bool)]
args), Bool
Nat
Maybe Type
Range
Type
Comparison
ExpandHidden
CheckedTarget
SkipCheck
Type -> PathView
sChecked :: CheckArgumentsE'State -> CheckedTarget
sArgsLen :: CheckArgumentsE'State -> Nat
sSizeLtChecked :: CheckArgumentsE'State -> Bool
sSkipCheck :: CheckArgumentsE'State -> SkipCheck
sPathView :: CheckArgumentsE'State -> Type -> PathView
sApp :: CheckArgumentsE'State -> Maybe Type
sFun :: CheckArgumentsE'State -> Type
sRange :: CheckArgumentsE'State -> Range
sExpand :: CheckArgumentsE'State -> ExpandHidden
sComp :: CheckArgumentsE'State -> Comparison
sChecked :: CheckedTarget
sComp :: Comparison
sExpand :: ExpandHidden
sRange :: Range
sArgsLen :: Nat
sFun :: Type
sApp :: Maybe Type
sSizeLtChecked :: Bool
sSkipCheck :: SkipCheck
sPathView :: Type -> PathView
.. } =

    Call
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall e r. Call -> ExceptT e (TCMT IO) r -> ExceptT e (TCMT IO) r
traceCallE (Range -> [NamedArg Expr] -> Type -> Maybe Type -> Call
CheckArguments Range
sRange (((NamedArg Expr, Bool) -> NamedArg Expr)
-> [(NamedArg Expr, Bool)] -> [NamedArg Expr]
forall a b. (a -> b) -> [a] -> [b]
map (NamedArg Expr, Bool) -> NamedArg Expr
forall a b. (a, b) -> a
fst [(NamedArg Expr, Bool)]
sArgs) Type
sFun Maybe Type
sApp) (ExceptT
   (ArgsCheckState [NamedArg Expr])
   (TCMT IO)
   (ArgsCheckState CheckedTarget)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. (a -> b) -> a -> b
$ do
      TCMT IO () -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (ArgsCheckState [NamedArg Expr]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO ()
 -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ())
-> TCMT IO ()
-> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.args" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
        [ TCMT IO Doc
"checkArgumentsE"
--        , "  sArgs =" <+> prettyA sArgs
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
          [ TCMT IO Doc
"e     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Named_ Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Named_ Expr
e
          , TCMT IO Doc
"sFun  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
sFun
          , TCMT IO Doc
"sApp  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc -> (Type -> TCMT IO Doc) -> Maybe Type -> TCMT IO Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO Doc
"Nothing" Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Maybe Type
sApp
          ]
        ]
      -- First, insert implicit arguments, depending on current argument @arg@.
      let hx :: Hiding
hx = ArgInfo -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding ArgInfo
info  -- hiding of current argument
          mx :: Maybe ArgName
          mx :: Maybe [Char]
mx = Named_ Expr -> Maybe [Char]
forall a. (LensNamed a, NameOf a ~ NamedName) => a -> Maybe [Char]
bareNameOf Named_ Expr
e    -- name of current argument
          -- do not insert visible arguments
          expand :: Hiding -> [Char] -> Bool
expand Hiding
NotHidden [Char]
y = Bool
False
          -- insert a hidden argument if arg is not hidden or has different name
          -- insert an instance argument if arg is not instance  or has different name
          expand Hiding
hy        [Char]
y = Bool -> Bool
not (Hiding -> Hiding -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding Hiding
hy Hiding
hx) Bool -> Bool -> Bool
|| Bool -> ([Char] -> Bool) -> Maybe [Char] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False ([Char]
y [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
/=) Maybe [Char]
mx
      [Char]
-> Nat
-> TCMT IO Doc
-> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.args" Nat
30 (TCMT IO Doc
 -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ())
-> TCMT IO Doc
-> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"calling implicitNamedArgs"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"sFun = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
sFun
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"hx   = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text (Hiding -> [Char]
forall a. Show a => a -> [Char]
show Hiding
hx)
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"mx   = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
-> ([Char] -> TCMT IO Doc) -> Maybe [Char] -> TCMT IO Doc
forall b a. b -> (a -> b) -> Maybe a -> b
maybe TCMT IO Doc
"nothing" [Char] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Char] -> m Doc
prettyTCM Maybe [Char]
mx
        ]
      (nargs, sFun) <- TCM (NamedArgs, Type)
-> ExceptT
     (ArgsCheckState [NamedArg Expr]) (TCMT IO) (NamedArgs, Type)
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (ArgsCheckState [NamedArg Expr]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM (NamedArgs, Type)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr]) (TCMT IO) (NamedArgs, Type))
-> TCM (NamedArgs, Type)
-> ExceptT
     (ArgsCheckState [NamedArg Expr]) (TCMT IO) (NamedArgs, Type)
forall a b. (a -> b) -> a -> b
$ Nat -> (Hiding -> [Char] -> Bool) -> Type -> TCM (NamedArgs, Type)
forall (m :: * -> *).
(PureTCM m, MonadMetaSolver m, MonadTCM m) =>
Nat -> (Hiding -> [Char] -> Bool) -> Type -> m (NamedArgs, Type)
implicitNamedArgs (-Nat
1) Hiding -> [Char] -> Bool
expand Type
sFun
      -- Separate names from args.
      let (mxs, us) = unzip $ map (\ (Arg ArgInfo
ai (Named Maybe NamedName
mx Term
u)) -> (Maybe NamedName
mx, Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (Arg Term -> Elim) -> Arg Term -> Elim
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
ai Term
u)) nargs
          xs        = [Maybe NamedName] -> [NamedName]
forall a. [Maybe a] -> [a]
catMaybes [Maybe NamedName]
mxs

      -- We need a function type here, but we don't know which kind
      -- (implicit/explicit). But it might be possible to use injectivity to
      -- force a pi.
      sFun <- lift $ forcePiUsingInjectivity sFun

      -- We are done inserting implicit args.  Now, try to check @arg@.
      ifBlocked sFun
        (\Blocker
_ Type
sFun -> ArgsCheckState [NamedArg Expr]
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a.
ArgsCheckState [NamedArg Expr]
-> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) a
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError (ArgsCheckState [NamedArg Expr]
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> ArgsCheckState [NamedArg Expr]
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. (a -> b) -> a -> b
$ ACState
            { acCheckedArgs :: [CheckedArg]
acCheckedArgs = (Elim -> CheckedArg) -> Elims -> [CheckedArg]
forall a b. (a -> b) -> [a] -> [b]
map Elim -> CheckedArg
defaultCheckedArg Elims
us
            , acType :: Type
acType        = Type
sFun
            , acData :: [NamedArg Expr]
acData        = ((NamedArg Expr, Bool) -> NamedArg Expr)
-> [(NamedArg Expr, Bool)] -> [NamedArg Expr]
forall a b. (a -> b) -> [a] -> [b]
map (NamedArg Expr, Bool) -> NamedArg Expr
forall a b. (a, b) -> a
fst [(NamedArg Expr, Bool)]
sArgs
            }) $ \NotBlocked
_ Type
sFun -> do

        -- What can go wrong?

        -- 1. We ran out of function types.
        let shouldBePi :: ExceptT
  (ArgsCheckState [NamedArg Expr])
  (TCMT IO)
  (ArgsCheckState CheckedTarget)
shouldBePi =
              -- a) It is an explicit argument, but we ran out of function types.
              if ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
visible ArgInfo
info then TCMT IO (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a.
TCM a -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (ArgsCheckState CheckedTarget)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> (TypeError -> TCMT IO (ArgsCheckState CheckedTarget))
-> TypeError
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeError -> TCMT IO (ArgsCheckState CheckedTarget)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> TypeError
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. (a -> b) -> a -> b
$ Type -> TypeError
ShouldBePi Type
sFun
              -- b) It is an implicit argument, and we did not insert any implicits.
              --    Thus, the type was not a function type to start with.
              else [NamedName]
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> (List1 NamedName
    -> ExceptT
         (ArgsCheckState [NamedArg Expr])
         (TCMT IO)
         (ArgsCheckState CheckedTarget))
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. [a] -> b -> (List1 a -> b) -> b
List1.ifNull [NamedName]
xs {-then-} (TCMT IO (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a.
TCM a -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (ArgsCheckState CheckedTarget)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> (TypeError -> TCMT IO (ArgsCheckState CheckedTarget))
-> TypeError
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeError -> TCMT IO (ArgsCheckState CheckedTarget)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> TypeError
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. (a -> b) -> a -> b
$ Type -> TypeError
ShouldBePi Type
sFun)
              -- c) We did insert implicits, but we ran out of implicit function types.
              --    Then, we should inform the user that we did not find his one.
              {-else-} (TCMT IO (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a.
TCM a -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (ArgsCheckState CheckedTarget)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> (List1 NamedName -> TCMT IO (ArgsCheckState CheckedTarget))
-> List1 NamedName
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeError -> TCMT IO (ArgsCheckState CheckedTarget)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (ArgsCheckState CheckedTarget))
-> (List1 NamedName -> TypeError)
-> List1 NamedName
-> TCMT IO (ArgsCheckState CheckedTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Expr -> List1 NamedName -> TypeError
WrongNamedArgument NamedArg Expr
arg)

        -- 2. We have a function type left, but it is the wrong one.
        --    Our argument must be implicit, case a) is impossible.
        --    (Otherwise we would have ran out of function types instead.)
        let wrongPi :: ExceptT
  (ArgsCheckState [NamedArg Expr])
  (TCMT IO)
  (ArgsCheckState CheckedTarget)
wrongPi = [NamedName]
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> (List1 NamedName
    -> ExceptT
         (ArgsCheckState [NamedArg Expr])
         (TCMT IO)
         (ArgsCheckState CheckedTarget))
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. [a] -> b -> (List1 a -> b) -> b
List1.ifNull [NamedName]
xs
              -- b) We have not inserted any implicits.
                {-then-} (TCMT IO (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a.
TCM a -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (ArgsCheckState CheckedTarget)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> (TypeError -> TCMT IO (ArgsCheckState CheckedTarget))
-> TypeError
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeError -> TCMT IO (ArgsCheckState CheckedTarget)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> TypeError
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. (a -> b) -> a -> b
$ Type -> TypeError
WrongHidingInApplication Type
sFun)
              -- c) We inserted implicits, but did not find his one.
                {-else-} (TCMT IO (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a.
TCM a -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) a
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO (ArgsCheckState CheckedTarget)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> (List1 NamedName -> TCMT IO (ArgsCheckState CheckedTarget))
-> List1 NamedName
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TypeError -> TCMT IO (ArgsCheckState CheckedTarget)
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO (ArgsCheckState CheckedTarget))
-> (List1 NamedName -> TypeError)
-> List1 NamedName
-> TCMT IO (ArgsCheckState CheckedTarget)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Expr -> List1 NamedName -> TypeError
WrongNamedArgument NamedArg Expr
arg)

        let (Bool
skip, SkipCheck
next) = case SkipCheck
sSkipCheck of
              SkipCheck
Skip       -> (Bool
True, SkipCheck
Skip)
              SkipCheck
DontSkip   -> (Bool
False, SkipCheck
DontSkip)
              SkipNext Nat
n -> case Nat -> Nat -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Nat
n Nat
1 of
                Ordering
LT -> (Bool
False, SkipCheck
DontSkip)
                Ordering
EQ -> (Bool
True,  SkipCheck
DontSkip)
                Ordering
GT -> (Bool
True,  Nat -> SkipCheck
SkipNext (Nat
n Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
1))

        s <- CheckArgumentsE'State
-> ExceptT
     (ArgsCheckState [NamedArg Expr]) (TCMT IO) CheckArgumentsE'State
forall a. a -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return CheckArgumentsE'State
s
          { sRange     = fuseRange sRange e
          , sArgs      = args
          , sArgsLen   = sArgsLen - 1
          , sFun       = sFun
          , sSkipCheck = next
          }

        -- Check the target type if we can get away with it.
        s <- lift $
          case (sChecked, skip, sApp) of
            (CheckedTarget
NotCheckedTarget, Bool
False, Just Type
sApp) | Bool
sArgsVisible -> do
              -- How many visible Π's (up to at most sArgsLen) does
              -- sFun start with?
              TelV tel tgt <- Nat -> (Dom Type -> Bool) -> Type -> TCMT IO (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Nat -> (Dom Type -> Bool) -> Type -> m (TelV Type)
telViewUpTo' Nat
sArgsLen Dom Type -> Bool
forall a. LensHiding a => a -> Bool
visible Type
sFun
              let visiblePis = Tele (Dom Type) -> Nat
forall a. Sized a => a -> Nat
size Tele (Dom Type)
tel

                  -- The free variables less than visiblePis in tgt.
                  freeInTgt =
                    (IntSet, IntSet) -> IntSet
forall a b. (a, b) -> a
fst ((IntSet, IntSet) -> IntSet) -> (IntSet, IntSet) -> IntSet
forall a b. (a -> b) -> a -> b
$ Nat -> IntSet -> (IntSet, IntSet)
IntSet.split Nat
visiblePis (IntSet -> (IntSet, IntSet)) -> IntSet -> (IntSet, IntSet)
forall a b. (a -> b) -> a -> b
$ Type -> IntSet
forall a c t. (IsVarSet a c, Singleton Nat c, Free t) => t -> c
freeVars Type
tgt

              rigid <- isRigid s tgt
              -- The target must be rigid.
              case rigid of
                IsNotRigid IsPermanent
reason ->
                      -- Skip the next visiblePis - 1 - k checks.
                  let skip :: Nat -> CheckArgumentsE'State
skip Nat
k   = CheckArgumentsE'State
s{ sSkipCheck =
                                    SkipNext $ visiblePis - 1 - k
                                  }
                      dontSkip :: CheckArgumentsE'State
dontSkip = CheckArgumentsE'State
s
                  in CheckArgumentsE'State -> TCM CheckArgumentsE'State
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (CheckArgumentsE'State -> TCM CheckArgumentsE'State)
-> CheckArgumentsE'State -> TCM CheckArgumentsE'State
forall a b. (a -> b) -> a -> b
$ case IsPermanent
reason of
                    IsPermanent
Permanent   -> Nat -> CheckArgumentsE'State
skip Nat
0
                    IsPermanent
Unspecified -> CheckArgumentsE'State
dontSkip
                    AVar Nat
x      ->
                      if Nat
x Nat -> IntSet -> Bool
`IntSet.member` IntSet
freeInTgt
                      then Nat -> CheckArgumentsE'State
skip Nat
x
                      else Nat -> CheckArgumentsE'State
skip Nat
0
                IsRigid
IsRigid -> do
                  -- Andreas, 2024-03-01, issue #7158 reported by Amy.
                  -- We need to check that the arity of the function type
                  -- is sufficient before checking the target,
                  -- otherwise the target is non-sensical.
                  if Nat
visiblePis Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
< Nat
sArgsLen then CheckArgumentsE'State -> TCM CheckArgumentsE'State
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CheckArgumentsE'State
s else do

                      -- Is any free variable in tgt less than
                      -- visiblePis?
                  let dep :: Bool
dep = Bool -> Bool
not (IntSet -> Bool
IntSet.null IntSet
freeInTgt)
                  -- The target must be non-dependent.
                  if Bool
dep then CheckArgumentsE'State -> TCM CheckArgumentsE'State
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CheckArgumentsE'State
s else do

                  -- Andreas, 2019-03-28, issue #3248:
                  -- If the target type is SIZELT, we need coerce, leqType is insufficient.
                  -- For example, we have i : Size <= (Size< ↑ i), but not Size <= (Size< ↑ i).
                  (isSizeLt, sApp, s) <-
                    if Bool
sSizeLtChecked
                    then (Bool, Type, CheckArgumentsE'State)
-> TCMT IO (Bool, Type, CheckArgumentsE'State)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Bool
False, Type
sApp, CheckArgumentsE'State
s)
                    else do
                      sApp     <- Type -> TCMT IO Type
forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Type
sApp
                      isSizeLt <- isSizeType sApp <&> \case
                        Just (BoundedLt Term
_) -> Bool
True
                        Maybe BoundedSize
_                  -> Bool
False
                      return ( isSizeLt
                             , sApp
                             , s{ sApp           = Just sApp
                                , sSizeLtChecked = True
                                , sSkipCheck     =
                                    if isSizeLt then Skip else DontSkip
                                }
                             )
                  if isSizeLt then return s else do

                  let tgt1 = Substitution' (SubstArg Type) -> Type -> Type
forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst
                               (Impossible -> Nat -> Substitution' Term
forall a. Impossible -> Nat -> Substitution' a
strengthenS Impossible
HasCallStack => Impossible
impossible Nat
visiblePis)
                               Type
tgt
                  reportSDoc "tc.term.args.target" 30 $ vcat
                    [ "Checking target types first"
                    , nest 2 $ "inferred =" <+> prettyTCM tgt1
                    , nest 2 $ "expected =" <+> prettyTCM sApp ]
                  chk <-
                    traceCall
                      (CheckTargetType
                         (fuseRange sRange sArgs) tgt1 sApp) $
                      CheckedTarget <$>
                        ifNoConstraints_ (compareType sComp tgt1 sApp)
                          (return Nothing) (return . Just)
                  return s{ sChecked = chk }

            (CheckedTarget, Bool, Maybe Type)
_ -> CheckArgumentsE'State -> TCM CheckArgumentsE'State
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return CheckArgumentsE'State
s

        -- sFun <- lift $ forcePi (getHiding info)
        --                  (maybe "_" rangedThing $ nameOf e) sFun
        case unEl sFun of
          Pi (Dom{domInfo :: forall t e. Dom' t e -> ArgInfo
domInfo = ArgInfo
info', domName :: forall t e. Dom' t e -> Maybe NamedName
domName = Maybe NamedName
dname, unDom :: forall t e. Dom' t e -> e
unDom = Type
a}) Abs Type
b
            | let name :: [Char]
name = [Char] -> Maybe NamedName -> [Char]
forall a.
(LensNamed a, NameOf a ~ NamedName) =>
[Char] -> a -> [Char]
bareNameWithDefault [Char]
"_" Maybe NamedName
dname,
              ArgInfo -> ArgInfo -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding ArgInfo
info ArgInfo
info'
              Bool -> Bool -> Bool
&& (ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
visible ArgInfo
info Bool -> Bool -> Bool
|| Bool -> ([Char] -> Bool) -> Maybe [Char] -> Bool
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
True ([Char]
name [Char] -> [Char] -> Bool
forall a. Eq a => a -> a -> Bool
==) Maybe [Char]
mx) -> do
                u <- TCM Term -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (ArgsCheckState [NamedArg Expr]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM Term
 -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) Term)
-> TCM Term
-> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ ArgInfo -> TCM Term -> TCM Term
forall (tcm :: * -> *) m a.
(MonadTCEnv tcm, LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext ArgInfo
info' (TCM Term -> TCM Term) -> TCM Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ do
                 -- Andreas, 2014-05-30 experiment to check non-dependent arguments
                 -- after the spine has been processed.  Allows to propagate type info
                 -- from ascribed type into extended-lambdas.  Would solve issue 1159.
                 -- However, leaves unsolved type checking problems in the test suite.
                 -- I do not know what I am doing wrong here.
                 -- Could be extreme order-sensitivity or my abuse of the postponing
                 -- mechanism.
                 -- Andreas, 2016-02-02: Ulf says unless there is actually some meta
                 -- blocking a postponed type checking problem, we might never retry,
                 -- since the trigger for retrying constraints is solving a meta.
                 -- Thus, the following naive use violates some invariant.
                 -- if not $ isBinderUsed b
                 -- then postponeTypeCheckingProblem (CheckExpr (namedThing e) a) (return True) else
                  let e' :: Named_ Expr
e' = Named_ Expr
e { nameOf = (nameOf e) <|> dname }
                  NamedArg Expr -> Type -> TCM Term
checkNamedArg (ArgInfo -> Named_ Expr -> NamedArg Expr
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info' Named_ Expr
e') Type
a

                let
                  c = case ArgInfo -> Lock
forall a. LensLock a => a -> Lock
getLock ArgInfo
info' of
                    IsLock{} -> Abs Constraint -> Maybe (Abs Constraint)
forall a. a -> Maybe a
Just (Abs Constraint -> Maybe (Abs Constraint))
-> Abs Constraint -> Maybe (Abs Constraint)
forall a b. (a -> b) -> a -> b
$ [Char] -> Constraint -> Abs Constraint
forall a. [Char] -> a -> Abs a
Abs [Char]
"t" (Constraint -> Abs Constraint) -> Constraint -> Abs Constraint
forall a b. (a -> b) -> a -> b
$
                        Term -> Type -> Arg Term -> Type -> Constraint
CheckLockedVars (Nat -> Elims -> Term
Var Nat
0 []) (Nat -> Type -> Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Type
sFun)
                          (Nat -> Arg Term -> Arg Term
forall a. Subst a => Nat -> a -> a
raise Nat
1 (Arg Term -> Arg Term) -> Arg Term -> Arg Term
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info' Term
u) (Nat -> Type -> Type
forall a. Subst a => Nat -> a -> a
raise Nat
1 Type
a)
                    Lock
_ -> Maybe (Abs Constraint)
forall a. Maybe a
Nothing
                lift $ reportSDoc "tc.term.lock" 40 $ text "lock =" <+> text (show $ getLock info')
                lift $ reportSDoc "tc.term.lock" 40 $
                  addContext (defaultDom $ sFun) $
                  maybe (text "nothing") (prettyTCM . absBody) c
                -- save relevance info' from domain in argument
                let ca = CheckedArg{ caElim :: Elim
caElim = Arg Term -> Elim
forall a. Arg a -> Elim' a
Apply (ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info' Term
u), caRange :: Maybe Range
caRange = Range -> Maybe Range
forall a. a -> Maybe a
Just (Named_ Expr -> Range
forall a. HasRange a => a -> Range
getRange Named_ Expr
e), caConstraint :: Maybe (Abs Constraint)
caConstraint = Maybe (Abs Constraint)
c }
                addCheckedArgs us ca $
                  checkArgumentsE' s{ sFun = absApp b u }
            | Bool
otherwise -> do
                [Char]
-> Nat
-> TCMT IO Doc
-> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"error" Nat
10 (TCMT IO Doc
 -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ())
-> TCMT IO Doc
-> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
                  [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"info      = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ArgInfo -> [Char]
forall a. Show a => a -> [Char]
show ArgInfo
info
                  , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"info'     = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ArgInfo -> [Char]
forall a. Show a => a -> [Char]
show ArgInfo
info'
                  , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"absName b = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Abs Type -> [Char]
forall a. Abs a -> [Char]
absName Abs Type
b
                  , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"nameOf e  = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe NamedName -> [Char]
forall a. Show a => a -> [Char]
show (Named_ Expr -> Maybe NamedName
forall name a. Named name a -> Maybe name
nameOf Named_ Expr
e)
                  ]
                ExceptT
  (ArgsCheckState [NamedArg Expr])
  (TCMT IO)
  (ArgsCheckState CheckedTarget)
wrongPi
          Term
_
            | ArgInfo -> Bool
forall a. LensHiding a => a -> Bool
visible ArgInfo
info
            , PathType Sort
sort QName
_ Arg Term
_ Arg Term
bA Arg Term
x Arg Term
y <- Type -> PathView
sPathView Type
sFun -> do
                TCMT IO () -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ()
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (ArgsCheckState [NamedArg Expr]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO ()
 -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ())
-> TCMT IO ()
-> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.args" Nat
30 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Arg Term -> [Char]
forall a. Show a => a -> [Char]
show Arg Term
bA
                u <- TCM Term -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) Term
forall (m :: * -> *) a.
Monad m =>
m a -> ExceptT (ArgsCheckState [NamedArg Expr]) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCM Term
 -> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) Term)
-> TCM Term
-> ExceptT (ArgsCheckState [NamedArg Expr]) (TCMT IO) Term
forall a b. (a -> b) -> a -> b
$ Expr -> Type -> TCM Term
checkExpr (Named_ Expr -> Expr
forall name a. Named name a -> a
namedThing Named_ Expr
e) (Type -> TCM Term) -> TCMT IO Type -> TCM Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCMT IO Type
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
                let ca = CheckedArg
                     { caElim :: Elim
caElim       = Term -> Term -> Term -> Elim
forall a. a -> a -> a -> Elim' a
IApply (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
x) (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
y) Term
u
                     , caRange :: Maybe Range
caRange      = Range -> Maybe Range
forall a. a -> Maybe a
Just (Named_ Expr -> Range
forall a. HasRange a => a -> Range
getRange Named_ Expr
e)
                     , caConstraint :: Maybe (Abs Constraint)
caConstraint = Maybe (Abs Constraint)
forall a. Maybe a
Nothing
                     }
                addCheckedArgs us ca $
                  checkArgumentsE'
                    s{ sChecked = NotCheckedTarget
                     , sFun     = El sort $ unArg bA `apply` [argN u]
                     }
          Term
_ -> ExceptT
  (ArgsCheckState [NamedArg Expr])
  (TCMT IO)
  (ArgsCheckState CheckedTarget)
shouldBePi
  where
    -- Andrea: Here one would add constraints too.
    addCheckedArgs ::
         Elims
      -> CheckedArg
      -> CheckArgumentsE'
      -> CheckArgumentsE'
    addCheckedArgs :: Elims
-> CheckedArg
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
addCheckedArgs Elims
us CheckedArg
ca ExceptT
  (ArgsCheckState [NamedArg Expr])
  (TCMT IO)
  (ArgsCheckState CheckedTarget)
cont = do
      let upd :: ArgsCheckState a -> ArgsCheckState a
          upd :: forall a. ArgsCheckState a -> ArgsCheckState a
upd ArgsCheckState a
st = ArgsCheckState a
st{ acCheckedArgs = map defaultCheckedArg us ++ ca : acCheckedArgs st }
      -- Add checked arguments to both regular and exceptional result of @cont@.
      (ArgsCheckState [NamedArg Expr] -> ArgsCheckState [NamedArg Expr])
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall e (m :: * -> *) a. MonadError e m => (e -> e) -> m a -> m a
withError ArgsCheckState [NamedArg Expr] -> ArgsCheckState [NamedArg Expr]
forall a. ArgsCheckState a -> ArgsCheckState a
upd (ExceptT
   (ArgsCheckState [NamedArg Expr])
   (TCMT IO)
   (ArgsCheckState CheckedTarget)
 -> ExceptT
      (ArgsCheckState [NamedArg Expr])
      (TCMT IO)
      (ArgsCheckState CheckedTarget))
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall a b. (a -> b) -> a -> b
$ ArgsCheckState CheckedTarget -> ArgsCheckState CheckedTarget
forall a. ArgsCheckState a -> ArgsCheckState a
upd (ArgsCheckState CheckedTarget -> ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ExceptT
  (ArgsCheckState [NamedArg Expr])
  (TCMT IO)
  (ArgsCheckState CheckedTarget)
cont

-- | The result of 'isRigid'.

data IsRigid
  = IsRigid
    -- ^ The type is rigid.
  | IsNotRigid !IsPermanent
    -- ^ The type is not rigid. If the argument is 'Nothing', then
    -- this will not change. If the argument is @'Just' reason@, then
    -- this might change for the given @reason@.

-- | Is the result of 'isRigid' \"permanent\"?

data IsPermanent
  = Permanent
    -- ^ Yes.
  | AVar !Nat
    -- ^ The result does not change unless the given variable is
    -- instantiated.
  | Unspecified
    -- ^ Maybe, maybe not.

-- | Is the type \"rigid\"?

isRigid :: CheckArgumentsE'State -> Type -> TCM IsRigid
isRigid :: CheckArgumentsE'State -> Type -> TCM IsRigid
isRigid CheckArgumentsE'State
s Type
t | PathType{} <- CheckArgumentsE'State -> Type -> PathView
sPathView CheckArgumentsE'State
s Type
t =
  -- Path is not rigid.
  IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid IsPermanent
Permanent
isRigid CheckArgumentsE'State
_ (El Sort
_ Term
t) = case Term
t of
  Var Nat
x Elims
_    -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid (Nat -> IsPermanent
AVar Nat
x)
  Lam{}      -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid IsPermanent
Permanent
  Lit{}      -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid IsPermanent
Permanent
  Con{}      -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid IsPermanent
Permanent
  Pi Dom Type
dom Abs Type
_   -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$
                if Dom Type -> Bool
forall a. LensHiding a => a -> Bool
visible Dom Type
dom then IsRigid
IsRigid else IsPermanent -> IsRigid
IsNotRigid IsPermanent
Permanent
  Sort{}     -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid IsPermanent
Permanent
  Level{}    -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid IsPermanent
Permanent
  MetaV{}    -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid IsPermanent
Unspecified
  DontCare{} -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid IsPermanent
Permanent
  Dummy{}    -> IsRigid -> TCM IsRigid
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (IsRigid -> TCM IsRigid) -> IsRigid -> TCM IsRigid
forall a b. (a -> b) -> a -> b
$ IsPermanent -> IsRigid
IsNotRigid IsPermanent
Permanent
  Def QName
d Elims
_    -> QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d TCMT IO Definition -> (Definition -> Defn) -> TCMT IO Defn
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> Definition -> Defn
theDef TCMT IO Defn -> (Defn -> IsRigid) -> TCM IsRigid
forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \case
    Axiom{}                   -> IsRigid
IsRigid
    DataOrRecSig{}            -> IsRigid
IsRigid
    AbstractDefn{}            -> IsRigid
IsRigid
    Function{funClauses :: Defn -> [Clause]
funClauses = [Clause]
cs} -> if [Clause] -> Bool
forall a. Null a => a -> Bool
null [Clause]
cs
                                 then IsRigid
IsRigid
                                 else IsPermanent -> IsRigid
IsNotRigid IsPermanent
Unspecified
                                      -- This Reason could perhaps be
                                      -- more precise (in some cases).
    Datatype{}                -> IsRigid
IsRigid
    Record{}                  -> IsRigid
IsRigid
    Constructor{}             -> IsRigid
forall a. HasCallStack => a
__IMPOSSIBLE__
    GeneralizableVar{}        -> IsRigid
forall a. HasCallStack => a
__IMPOSSIBLE__
    Primitive{}               -> IsPermanent -> IsRigid
IsNotRigid IsPermanent
Unspecified
    PrimitiveSort{}           -> IsPermanent -> IsRigid
IsNotRigid IsPermanent
Unspecified

-- | Check that a list of arguments fits a telescope.
--   Inserts hidden arguments as necessary.
--   Returns the type-checked arguments and the remaining telescope.
checkArguments_
  :: Comparison           -- ^ Comparison for target
  -> ExpandHidden         -- ^ Eagerly insert trailing hidden arguments?
  -> Range                -- ^ Range of application.
  -> [NamedArg A.Expr]    -- ^ Arguments to check.
  -> Telescope            -- ^ Telescope to check arguments against.
  -> TCM (Elims, Telescope)
     -- ^ Checked arguments and remaining telescope if successful.
checkArguments_ :: Comparison
-> ExpandHidden
-> Range
-> [NamedArg Expr]
-> Tele (Dom Type)
-> TCMT IO (Elims, Tele (Dom Type))
checkArguments_ Comparison
cmp ExpandHidden
exh Range
r [NamedArg Expr]
args Tele (Dom Type)
tel = TCMT IO (Elims, Tele (Dom Type))
-> TCMT IO (Elims, Tele (Dom Type))
forall a. TCM a -> TCM a
postponeInstanceConstraints (TCMT IO (Elims, Tele (Dom Type))
 -> TCMT IO (Elims, Tele (Dom Type)))
-> TCMT IO (Elims, Tele (Dom Type))
-> TCMT IO (Elims, Tele (Dom Type))
forall a b. (a -> b) -> a -> b
$ do
    z <- ExceptT
  (ArgsCheckState [NamedArg Expr])
  (TCMT IO)
  (ArgsCheckState CheckedTarget)
-> TCM
     (Either
        (ArgsCheckState [NamedArg Expr]) (ArgsCheckState CheckedTarget))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   (ArgsCheckState [NamedArg Expr])
   (TCMT IO)
   (ArgsCheckState CheckedTarget)
 -> TCM
      (Either
         (ArgsCheckState [NamedArg Expr]) (ArgsCheckState CheckedTarget)))
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> TCM
     (Either
        (ArgsCheckState [NamedArg Expr]) (ArgsCheckState CheckedTarget))
forall a b. (a -> b) -> a -> b
$
      Comparison
-> ExpandHidden
-> Range
-> [NamedArg Expr]
-> Type
-> Maybe Type
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
checkArgumentsE Comparison
cmp ExpandHidden
exh Range
r [NamedArg Expr]
args (Tele (Dom Type) -> Type -> Type
telePi Tele (Dom Type)
tel Type
HasCallStack => Type
__DUMMY_TYPE__) Maybe Type
forall a. Maybe a
Nothing
    case z of
      Right (ACState [CheckedArg]
cas Type
t CheckedTarget
_) -> do
        Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless ((CheckedArg -> Bool) -> [CheckedArg] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (Maybe (Abs Constraint) -> Bool
forall a. Maybe a -> Bool
isNothing (Maybe (Abs Constraint) -> Bool)
-> (CheckedArg -> Maybe (Abs Constraint)) -> CheckedArg -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckedArg -> Maybe (Abs Constraint)
caConstraint) [CheckedArg]
cas) do
          TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
NotSupported ([Char] -> TypeError) -> [Char] -> TypeError
forall a b. (a -> b) -> a -> b
$
            [Char]
"Head constraints are not (yet) supported in this position."
        let TelV Tele (Dom Type)
tel' Type
_ = Type -> TelV Type
telView' Type
t
        (Elims, Tele (Dom Type)) -> TCMT IO (Elims, Tele (Dom Type))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return ((CheckedArg -> Elim) -> [CheckedArg] -> Elims
forall a b. (a -> b) -> [a] -> [b]
map CheckedArg -> Elim
caElim [CheckedArg]
cas, Tele (Dom Type)
tel')
      Left ArgsCheckState [NamedArg Expr]
_ -> TCMT IO (Elims, Tele (Dom Type))
forall a. HasCallStack => a
__IMPOSSIBLE__  -- type cannot be blocked as it is generated by telePi

-- | @checkArguments cmp exph r args t0 t k@ tries @checkArgumentsE exph args t0 t@.
-- If it succeeds, it continues @k@ with the returned results.  If it fails,
-- it registers a postponed typechecking problem and returns the resulting new
-- meta variable.
--
-- Checks @e := ((_ : t0) args) : t@.
checkArguments ::
  Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type -> Type ->
  (ArgsCheckState CheckedTarget -> TCM Term) -> TCM Term
checkArguments :: Comparison
-> ExpandHidden
-> Range
-> [NamedArg Expr]
-> Type
-> Type
-> (ArgsCheckState CheckedTarget -> TCM Term)
-> TCM Term
checkArguments Comparison
cmp ExpandHidden
exph Range
r [NamedArg Expr]
args Type
t0 Type
t ArgsCheckState CheckedTarget -> TCM Term
k = TCM Term -> TCM Term
forall a. TCM a -> TCM a
postponeInstanceConstraints (TCM Term -> TCM Term) -> TCM Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ do
  z <- ExceptT
  (ArgsCheckState [NamedArg Expr])
  (TCMT IO)
  (ArgsCheckState CheckedTarget)
-> TCM
     (Either
        (ArgsCheckState [NamedArg Expr]) (ArgsCheckState CheckedTarget))
forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ExceptT
   (ArgsCheckState [NamedArg Expr])
   (TCMT IO)
   (ArgsCheckState CheckedTarget)
 -> TCM
      (Either
         (ArgsCheckState [NamedArg Expr]) (ArgsCheckState CheckedTarget)))
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
-> TCM
     (Either
        (ArgsCheckState [NamedArg Expr]) (ArgsCheckState CheckedTarget))
forall a b. (a -> b) -> a -> b
$ Comparison
-> ExpandHidden
-> Range
-> [NamedArg Expr]
-> Type
-> Maybe Type
-> ExceptT
     (ArgsCheckState [NamedArg Expr])
     (TCMT IO)
     (ArgsCheckState CheckedTarget)
checkArgumentsE Comparison
cmp ExpandHidden
exph Range
r [NamedArg Expr]
args Type
t0 (Type -> Maybe Type
forall a. a -> Maybe a
Just Type
t)
  case z of
    Right ArgsCheckState CheckedTarget
st -> ArgsCheckState CheckedTarget -> TCM Term
k ArgsCheckState CheckedTarget
st
      -- vs = evaluated args
      -- t1 = remaining type (needs to be subtype of t)
    Left ArgsCheckState [NamedArg Expr]
problem -> ArgsCheckState [NamedArg Expr]
-> Comparison
-> ExpandHidden
-> Range
-> [NamedArg Expr]
-> Type
-> (ArgsCheckState CheckedTarget -> TCM Term)
-> TCM Term
postponeArgs ArgsCheckState [NamedArg Expr]
problem Comparison
cmp ExpandHidden
exph Range
r [NamedArg Expr]
args Type
t ArgsCheckState CheckedTarget -> TCM Term
k
      -- if unsuccessful, postpone checking until t0 unblocks

postponeArgs :: (ArgsCheckState [NamedArg A.Expr]) -> Comparison -> ExpandHidden -> Range -> [NamedArg A.Expr] -> Type ->
                (ArgsCheckState CheckedTarget -> TCM Term) -> TCM Term
postponeArgs :: ArgsCheckState [NamedArg Expr]
-> Comparison
-> ExpandHidden
-> Range
-> [NamedArg Expr]
-> Type
-> (ArgsCheckState CheckedTarget -> TCM Term)
-> TCM Term
postponeArgs (ACState [CheckedArg]
cas Type
t0 [NamedArg Expr]
es) Comparison
cmp ExpandHidden
exph Range
r [NamedArg Expr]
args Type
t ArgsCheckState CheckedTarget -> TCM Term
k = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.expr.args" Nat
80 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"postponed checking arguments"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
4 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
prettyList ((NamedArg Expr -> TCMT IO Doc) -> [NamedArg Expr] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA (Expr -> TCMT IO Doc)
-> (NamedArg Expr -> Expr) -> NamedArg Expr -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named_ Expr -> Expr
forall name a. Named name a -> a
namedThing (Named_ Expr -> Expr)
-> (NamedArg Expr -> Named_ Expr) -> NamedArg Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Expr -> Named_ Expr
forall e. Arg e -> e
unArg) [NamedArg Expr]
args)
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"against"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
4 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t0 ] TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
$$
    [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"progress:"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"checked" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
prettyList ((CheckedArg -> TCMT IO Doc) -> [CheckedArg] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Elim -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Elim -> m Doc
prettyTCM (Elim -> TCMT IO Doc)
-> (CheckedArg -> Elim) -> CheckedArg -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. CheckedArg -> Elim
caElim) [CheckedArg]
cas)
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"remaining" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
prettyList ((NamedArg Expr -> TCMT IO Doc) -> [NamedArg Expr] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Expr -> TCMT IO Doc
forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA (Expr -> TCMT IO Doc)
-> (NamedArg Expr -> Expr) -> NamedArg Expr -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Named_ Expr -> Expr
forall name a. Named name a -> a
namedThing (Named_ Expr -> Expr)
-> (NamedArg Expr -> Named_ Expr) -> NamedArg Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Expr -> Named_ Expr
forall e. Arg e -> e
unArg) [NamedArg Expr]
es)
                                            , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
":" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t0 ] ]
  TypeCheckingProblem -> TCM Term
postponeTypeCheckingProblem_ (TypeCheckingProblem -> TCM Term)
-> TypeCheckingProblem -> TCM Term
forall a b. (a -> b) -> a -> b
$
    Comparison
-> ExpandHidden
-> Range
-> [NamedArg Expr]
-> Type
-> Type
-> (ArgsCheckState CheckedTarget -> TCM Term)
-> TypeCheckingProblem
CheckArgs Comparison
cmp ExpandHidden
exph Range
r [NamedArg Expr]
es Type
t0 Type
t ((ArgsCheckState CheckedTarget -> TCM Term) -> TypeCheckingProblem)
-> (ArgsCheckState CheckedTarget -> TCM Term)
-> TypeCheckingProblem
forall a b. (a -> b) -> a -> b
$ \ (ACState [CheckedArg]
cas' Type
t CheckedTarget
pid) ->
      ArgsCheckState CheckedTarget -> TCM Term
k (ArgsCheckState CheckedTarget -> TCM Term)
-> ArgsCheckState CheckedTarget -> TCM Term
forall a b. (a -> b) -> a -> b
$ [CheckedArg]
-> Type -> CheckedTarget -> ArgsCheckState CheckedTarget
forall a. [CheckedArg] -> Type -> a -> ArgsCheckState a
ACState ([CheckedArg]
cas [CheckedArg] -> [CheckedArg] -> [CheckedArg]
forall a. [a] -> [a] -> [a]
++ [CheckedArg]
cas') Type
t CheckedTarget
pid

-----------------------------------------------------------------------------
-- * Constructors
-----------------------------------------------------------------------------

-- | Check the type of a constructor application. This is easier than
--   a general application since the implicit arguments can be inserted
--   without looking at the arguments to the constructor.
checkConstructorApplication :: Comparison -> A.Expr -> Type -> ConHead -> [NamedArg A.Expr] -> TCM Term
checkConstructorApplication :: Comparison
-> Expr -> Type -> ConHead -> [NamedArg Expr] -> TCM Term
checkConstructorApplication Comparison
cmp Expr
org Type
t ConHead
c [NamedArg Expr]
args = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"entering checkConstructorApplication"
    , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
      [ TCMT IO Doc
"org  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Expr -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Expr -> m Doc
prettyTCM Expr
org
      , TCMT IO Doc
"t    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t
      , TCMT IO Doc
"c    =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ConHead -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ConHead -> m Doc
prettyTCM ConHead
c
      , TCMT IO Doc
"args =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [NamedArg Expr] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [NamedArg Expr] -> m Doc
prettyTCM [NamedArg Expr]
args
    ] ]

  cdef  <- ConHead -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => ConHead -> m Definition
getConInfo ConHead
c

  checkModality (conName c) cdef

  let paramsGiven = [NamedArg Expr] -> Bool
checkForParams [NamedArg Expr]
args
  if paramsGiven then fallback else do
    reportSDoc "tc.term.con" 50 $ "checkConstructorApplication: no parameters explicitly supplied, continuing..."

    let Constructor{conData = d, conPars = npars} = theDef cdef
    reportSDoc "tc.term.con" 50 $ nest 2 $ "d    =" <+> prettyTCM d
    -- Issue 661: t maybe an evaluated form of d .., so we evaluate d
    -- as well and then check wether we deal with the same datatype
    t0 <- reduce (Def d [])
    tReduced <- reduce t
    case (t0, unEl tReduced) of -- Only fully applied constructors get special treatment
      (Def QName
d0 Elims
_, Def QName
d' Elims
es) -> do
        let ~(Just [Arg Term]
vs) = Elims -> Maybe [Arg Term]
forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"d0   =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
d0
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"d'   =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> QName -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => QName -> m Doc
prettyTCM QName
d'
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"vs   =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Arg Term] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Arg Term] -> m Doc
prettyTCM [Arg Term]
vs
        if QName
d' QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
/= QName
d0 then TCM Term
fallback else do
         -- Issue 661: d' may take more parameters than d, in particular
         -- these additional parameters could be a module parameter telescope.
         -- Since we get the constructor type ctype from d but the parameters
         -- from t = Def d' vs, we drop the additional parameters.
         npars' <- QName -> TCMT IO (Maybe Nat)
forall (m :: * -> *). HasConstInfo m => QName -> m (Maybe Nat)
getNumberOfParameters QName
d'
         caseMaybe (sequenceA $ Pair (Just npars) npars') fallback $ \ (Pair Nat
n Nat
n') -> do
           [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"n    = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Nat -> [Char]
forall a. Show a => a -> [Char]
show Nat
n
           [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"n'   = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Nat -> [Char]
forall a. Show a => a -> [Char]
show Nat
n'
           Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
when (Nat
n Nat -> Nat -> Bool
forall a. Ord a => a -> a -> Bool
> Nat
n')  -- preprocessor does not like ', so put on next line
             TCMT IO ()
forall a. HasCallStack => a
__IMPOSSIBLE__
           let ps :: [Arg Term]
ps    = Nat -> [Arg Term] -> [Arg Term]
forall a. Nat -> [a] -> [a]
take Nat
n ([Arg Term] -> [Arg Term]) -> [Arg Term] -> [Arg Term]
forall a b. (a -> b) -> a -> b
$ Nat -> [Arg Term] -> [Arg Term]
forall a. Nat -> [a] -> [a]
drop (Nat
n' Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
- Nat
n) [Arg Term]
vs
               ctype :: Type
ctype = Definition -> Type
defType Definition
cdef
           [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
             [ TCMT IO Doc
"special checking of constructor application of" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ConHead -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => ConHead -> m Doc
prettyTCM ConHead
c
             , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat [ TCMT IO Doc
"ps     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [Arg Term] -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => [Arg Term] -> m Doc
prettyTCM [Arg Term]
ps
                             , TCMT IO Doc
"ctype  =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
ctype ] ]
           let ctype' :: Type
ctype' = Type
ctype Type -> [Arg Term] -> Type
`piApply` [Arg Term]
ps
           [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"ctype' =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
ctype'
           -- get the parameter names
           let TelV Tele (Dom Type)
ptel Type
_ = Nat -> Type -> TelV Type
telView'UpTo Nat
n Type
ctype
           let pnames :: [Dom' Term [Char]]
pnames = (Dom' Term ([Char], Type) -> Dom' Term [Char])
-> [Dom' Term ([Char], Type)] -> [Dom' Term [Char]]
forall a b. (a -> b) -> [a] -> [b]
map ((([Char], Type) -> [Char])
-> Dom' Term ([Char], Type) -> Dom' Term [Char]
forall a b. (a -> b) -> Dom' Term a -> Dom' Term b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ([Char], Type) -> [Char]
forall a b. (a, b) -> a
fst) ([Dom' Term ([Char], Type)] -> [Dom' Term [Char]])
-> [Dom' Term ([Char], Type)] -> [Dom' Term [Char]]
forall a b. (a -> b) -> a -> b
$ Tele (Dom Type) -> [Dom' Term ([Char], Type)]
forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Tele (Dom Type)
ptel
           -- drop the parameter arguments
               args' :: [NamedArg Expr]
args' = [Dom' Term [Char]] -> [NamedArg Expr] -> [NamedArg Expr]
dropArgs [Dom' Term [Char]]
pnames [NamedArg Expr]
args
           -- check the non-parameter arguments
           expandLast <- (TCEnv -> ExpandHidden) -> TCMT IO ExpandHidden
forall (m :: * -> *) a. MonadTCEnv m => (TCEnv -> a) -> m a
asksTC TCEnv -> ExpandHidden
envExpandLast
           checkArguments cmp expandLast (getRange c) args' ctype' t $ \ st :: ArgsCheckState CheckedTarget
st@(ACState [CheckedArg]
_ Type
t' CheckedTarget
targetCheck) -> do
             [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
               [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"es     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Elims -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Elims -> m Doc
prettyTCM Elims
es
               , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"t'     =" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
t' ]
             v <- (Elims -> Term) -> ArgsCheckState CheckedTarget -> TCM Term
forall a. (Elims -> Term) -> ArgsCheckState a -> TCM Term
checkHeadConstraints (ConHead -> ConInfo -> Elims -> Term
Con ConHead
c ConInfo
ConOCon) ArgsCheckState CheckedTarget
st
             coerce' cmp targetCheck v t' t
      (Term, Term)
_ -> do
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.term.con" Nat
50 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"we are not at a datatype, falling back"
        TCM Term
fallback
  where
    fallback :: TCM Term
fallback = Comparison -> Expr -> Type -> Expr -> [NamedArg Expr] -> TCM Term
checkHeadApplication Comparison
cmp Expr
org Type
t (AmbiguousQName -> Expr
A.Con (QName -> AmbiguousQName
unambiguous (QName -> AmbiguousQName) -> QName -> AmbiguousQName
forall a b. (a -> b) -> a -> b
$ ConHead -> QName
conName ConHead
c)) [NamedArg Expr]
args

    -- Check if there are explicitly given hidden arguments,
    -- in which case we fall back to default type checking.
    -- We could work harder, but let's not for now.
    --
    -- Andreas, 2012-04-18: if all inital args are underscores, ignore them
    checkForParams :: [NamedArg Expr] -> Bool
checkForParams [NamedArg Expr]
args =
      let ([NamedArg Expr]
hargs, [NamedArg Expr]
rest) = (NamedArg Expr -> Bool)
-> [NamedArg Expr] -> ([NamedArg Expr], [NamedArg Expr])
forall a. (a -> Bool) -> [a] -> ([a], [a])
break NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
visible [NamedArg Expr]
args
          notUnderscore :: Expr -> Bool
notUnderscore A.Underscore{} = Bool
False
          notUnderscore Expr
_              = Bool
True
      in  (NamedArg Expr -> Bool) -> [NamedArg Expr] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Expr -> Bool
notUnderscore (Expr -> Bool) -> (NamedArg Expr -> Expr) -> NamedArg Expr -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> Expr
unScope (Expr -> Expr) -> (NamedArg Expr -> Expr) -> NamedArg Expr -> Expr
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg) [NamedArg Expr]
hargs

    -- Drop the constructor arguments that correspond to parameters.
    dropArgs :: [Dom' Term [Char]] -> [NamedArg Expr] -> [NamedArg Expr]
dropArgs [] [NamedArg Expr]
args                = [NamedArg Expr]
args
    dropArgs [Dom' Term [Char]]
ps []                  = [NamedArg Expr]
args
    dropArgs [Dom' Term [Char]]
ps args :: [NamedArg Expr]
args@(NamedArg Expr
arg : [NamedArg Expr]
args')
      | Just [Char]
p   <- Maybe [Char]
name,
        Just [Dom' Term [Char]]
ps' <- [Char] -> [Dom' Term [Char]] -> Maybe [Dom' Term [Char]]
forall {b} {t}. Eq b => b -> [Dom' t b] -> Maybe [Dom' t b]
namedPar [Char]
p [Dom' Term [Char]]
ps   = [Dom' Term [Char]] -> [NamedArg Expr] -> [NamedArg Expr]
dropArgs [Dom' Term [Char]]
ps' [NamedArg Expr]
args'
      | Maybe [Char]
Nothing  <- Maybe [Char]
name,
        Just [Dom' Term [Char]]
ps' <- Hiding -> [Dom' Term [Char]] -> Maybe [Dom' Term [Char]]
forall {a} {t}.
(LensHiding a, LensHiding t) =>
a -> [t] -> Maybe [t]
unnamedPar Hiding
h [Dom' Term [Char]]
ps = [Dom' Term [Char]] -> [NamedArg Expr] -> [NamedArg Expr]
dropArgs [Dom' Term [Char]]
ps' [NamedArg Expr]
args'
      | Bool
otherwise                   = [NamedArg Expr]
args
      where
        name :: Maybe [Char]
name = NamedArg Expr -> Maybe [Char]
forall a. (LensNamed a, NameOf a ~ NamedName) => a -> Maybe [Char]
bareNameOf NamedArg Expr
arg
        h :: Hiding
h    = NamedArg Expr -> Hiding
forall a. LensHiding a => a -> Hiding
getHiding NamedArg Expr
arg

        namedPar :: b -> [Dom' t b] -> Maybe [Dom' t b]
namedPar   b
x = (Dom' t b -> Bool) -> [Dom' t b] -> Maybe [Dom' t b]
forall {t}. (t -> Bool) -> [t] -> Maybe [t]
dropPar ((b
x b -> b -> Bool
forall a. Eq a => a -> a -> Bool
==) (b -> Bool) -> (Dom' t b -> b) -> Dom' t b -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom' t b -> b
forall t e. Dom' t e -> e
unDom)
        unnamedPar :: a -> [t] -> Maybe [t]
unnamedPar a
h = (t -> Bool) -> [t] -> Maybe [t]
forall {t}. (t -> Bool) -> [t] -> Maybe [t]
dropPar (a -> t -> Bool
forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding a
h)

        dropPar :: (t -> Bool) -> [t] -> Maybe [t]
dropPar t -> Bool
this (t
p : [t]
ps) | t -> Bool
this t
p    = [t] -> Maybe [t]
forall a. a -> Maybe a
Just [t]
ps
                              | Bool
otherwise = (t -> Bool) -> [t] -> Maybe [t]
dropPar t -> Bool
this [t]
ps
        dropPar t -> Bool
_ [] = Maybe [t]
forall a. Maybe a
Nothing

-- | Return an unblocking action in case of failure.
type DisambiguateConstructor = TCM (Either Blocker ConHead)

-- | Returns an unblocking action in case of failure.
disambiguateConstructor :: List1 QName -> A.Args -> Type -> DisambiguateConstructor
disambiguateConstructor :: List1 QName -> [NamedArg Expr] -> Type -> DisambiguateConstructor
disambiguateConstructor List1 QName
cs0 [NamedArg Expr]
args Type
t = do
  [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.check.term.con" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"Ambiguous constructor: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ List1 QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow List1 QName
cs0
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.check.term.con" Nat
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Arguments:" TCMT IO Doc -> [TCMT IO Doc] -> [TCMT IO Doc]
forall a. a -> [a] -> [a]
: (NamedArg Expr -> TCMT IO Doc) -> [NamedArg Expr] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map (Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc)
-> (NamedArg Expr -> TCMT IO Doc) -> NamedArg Expr -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. NamedArg Expr -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => NamedArg Expr -> m Doc
prettyTCM) [NamedArg Expr]
args

  -- Get the datatypes of the various constructors
  let getData :: Defn -> QName
getData Constructor{conData :: Defn -> QName
conData = QName
d} = QName
d
      getData Defn
_                        = QName
forall a. HasCallStack => a
__IMPOSSIBLE__
  [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.check.term.con" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  ranges before: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Range -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (List1 QName -> Range
forall a. HasRange a => a -> Range
getRange List1 QName
cs0)
  -- We use the reduced constructor when disambiguating, but
  -- the original constructor for type checking. This is important
  -- since they may have different types (different parameters).
  -- See issue 279.
  -- Andreas, 2017-08-13, issue #2686: ignore abstract constructors
  ccons  <- List1 (Either SigError (QName, ConHead)) -> [(QName, ConHead)]
forall a b. List1 (Either a b) -> [b]
List1.rights (List1 (Either SigError (QName, ConHead)) -> [(QName, ConHead)])
-> TCMT IO (List1 (Either SigError (QName, ConHead)))
-> TCMT IO [(QName, ConHead)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
     List1 QName
-> (QName -> TCMT IO (Either SigError (QName, ConHead)))
-> TCMT IO (List1 (Either SigError (QName, ConHead)))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM List1 QName
cs0 ((QName -> TCMT IO (Either SigError (QName, ConHead)))
 -> TCMT IO (List1 (Either SigError (QName, ConHead))))
-> (QName -> TCMT IO (Either SigError (QName, ConHead)))
-> TCMT IO (List1 (Either SigError (QName, ConHead)))
forall a b. (a -> b) -> a -> b
$ \ QName
c -> (ConHead -> (QName, ConHead))
-> Either SigError ConHead -> Either SigError (QName, ConHead)
forall b d a. (b -> d) -> Either a b -> Either a d
mapRight (QName
c,) (Either SigError ConHead -> Either SigError (QName, ConHead))
-> TCMT IO (Either SigError ConHead)
-> TCMT IO (Either SigError (QName, ConHead))
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO (Either SigError ConHead)
getConForm QName
c
  reportSLn "tc.check.term.con" 40 $ "  reduced: " ++ prettyShow (map snd ccons)
  case ccons of
    []    -> TypeError -> DisambiguateConstructor
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> DisambiguateConstructor)
-> TypeError -> DisambiguateConstructor
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
AbstractConstructorNotInScope (QName -> TypeError) -> QName -> TypeError
forall a b. (a -> b) -> a -> b
$ List1 QName -> QName
forall a. NonEmpty a -> a
List1.head List1 QName
cs0
    [(QName
c0,ConHead
con)] -> do
      let c :: ConHead
c = QName -> ConHead -> ConHead
forall a. LensConName a => QName -> a -> a
setConName QName
c0 ConHead
con
      [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.check.term.con" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  only one non-abstract constructor: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ConHead -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ConHead
c
      ConHead -> DisambiguateConstructor
decideOn ConHead
c
    (QName
c0,ConHead
_):[(QName, ConHead)]
_   -> do
      dcs :: [(QName, Type, ConHead)] <- [(QName, ConHead)]
-> ((QName, ConHead) -> TCMT IO (QName, Type, ConHead))
-> TCMT IO [(QName, Type, ConHead)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(QName, ConHead)]
ccons (((QName, ConHead) -> TCMT IO (QName, Type, ConHead))
 -> TCMT IO [(QName, Type, ConHead)])
-> ((QName, ConHead) -> TCMT IO (QName, Type, ConHead))
-> TCMT IO [(QName, Type, ConHead)]
forall a b. (a -> b) -> a -> b
$ \ (QName
c, ConHead
con) -> do
        t   <- Definition -> Type
defType (Definition -> Type) -> TCMT IO Definition -> TCMT IO Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
c
        def <- getConInfo con
        pure (getData (theDef def), t, setConName c con)
      -- Type error
      let badCon Type
t = TypeError -> DisambiguateConstructor
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> DisambiguateConstructor)
-> TypeError -> DisambiguateConstructor
forall a b. (a -> b) -> a -> b
$ QName -> Type -> TypeError
ConstructorDoesNotTargetGivenType QName
c0 Type
t

      -- Lets look at the target type at this point
      TelV tel t1 <- telViewPath t
      addContext tel $ do
       reportSDoc "tc.check.term.con" 40 $ nest 2 $
         "target type: " <+> prettyTCM t1
       -- If we don't have a target type yet, try to look at the argument types.
       ifBlocked t1 (\ Blocker
b Type
_ -> [(QName, Type, ConHead)]
-> DisambiguateConstructor -> DisambiguateConstructor
disambiguateByArgs [(QName, Type, ConHead)]
dcs (DisambiguateConstructor -> DisambiguateConstructor)
-> DisambiguateConstructor -> DisambiguateConstructor
forall a b. (a -> b) -> a -> b
$ Either Blocker ConHead -> DisambiguateConstructor
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Blocker ConHead -> DisambiguateConstructor)
-> Either Blocker ConHead -> DisambiguateConstructor
forall a b. (a -> b) -> a -> b
$ Blocker -> Either Blocker ConHead
forall a b. a -> Either a b
Left Blocker
b) $ \ NotBlocked
_ Type
t' ->
         TCMT IO (Maybe (QName, DataOrRecord))
-> DisambiguateConstructor
-> ((QName, DataOrRecord) -> DisambiguateConstructor)
-> DisambiguateConstructor
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Term -> TCMT IO (Maybe (QName, DataOrRecord))
isDataOrRecord (Term -> TCMT IO (Maybe (QName, DataOrRecord)))
-> Term -> TCMT IO (Maybe (QName, DataOrRecord))
forall a b. (a -> b) -> a -> b
$ Type -> Term
forall t a. Type'' t a -> a
unEl Type
t') (Type -> DisambiguateConstructor
badCon Type
t') (((QName, DataOrRecord) -> DisambiguateConstructor)
 -> DisambiguateConstructor)
-> ((QName, DataOrRecord) -> DisambiguateConstructor)
-> DisambiguateConstructor
forall a b. (a -> b) -> a -> b
$ \ (QName
d, DataOrRecord
_) -> do
           let dcs' :: [(QName, Type, ConHead)]
dcs' = ((QName, Type, ConHead) -> Bool)
-> [(QName, Type, ConHead)] -> [(QName, Type, ConHead)]
forall a. (a -> Bool) -> [a] -> [a]
filter ((QName
d QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
==) (QName -> Bool)
-> ((QName, Type, ConHead) -> QName)
-> (QName, Type, ConHead)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (QName, Type, ConHead) -> QName
forall a b c. (a, b, c) -> a
fst3) [(QName, Type, ConHead)]
dcs
           case ((QName, Type, ConHead) -> ConHead)
-> [(QName, Type, ConHead)] -> [ConHead]
forall a b. (a -> b) -> [a] -> [b]
map (QName, Type, ConHead) -> ConHead
forall a b c. (a, b, c) -> c
thd3 [(QName, Type, ConHead)]
dcs' of
             [ConHead
c] -> ConHead -> DisambiguateConstructor
decideOn ConHead
c
             []  -> Type -> DisambiguateConstructor
badCon (Type -> DisambiguateConstructor)
-> Type -> DisambiguateConstructor
forall a b. (a -> b) -> a -> b
$ Type
t' Type -> Term -> Type
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$> QName -> Elims -> Term
Def QName
d []
             -- If the information from the target type did not eliminate ambiguity fully,
             -- try to further eliminate alternatives by looking at the arguments.
             ConHead
c:[ConHead]
cs-> [(QName, Type, ConHead)]
-> DisambiguateConstructor -> DisambiguateConstructor
disambiguateByArgs [(QName, Type, ConHead)]
dcs' (DisambiguateConstructor -> DisambiguateConstructor)
-> DisambiguateConstructor -> DisambiguateConstructor
forall a b. (a -> b) -> a -> b
$
                      TypeError -> DisambiguateConstructor
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> DisambiguateConstructor)
-> TypeError -> DisambiguateConstructor
forall a b. (a -> b) -> a -> b
$ QName -> List1 QName -> TypeError
CantResolveOverloadedConstructorsTargetingSameDatatype QName
d (List1 QName -> TypeError) -> List1 QName -> TypeError
forall a b. (a -> b) -> a -> b
$
                        (ConHead -> QName) -> NonEmpty ConHead -> List1 QName
forall a b. (a -> b) -> NonEmpty a -> NonEmpty b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ConHead -> QName
conName (NonEmpty ConHead -> List1 QName)
-> NonEmpty ConHead -> List1 QName
forall a b. (a -> b) -> a -> b
$ ConHead
c ConHead -> [ConHead] -> NonEmpty ConHead
forall a. a -> [a] -> NonEmpty a
:| [ConHead]
cs
  where
  decideOn :: ConHead -> DisambiguateConstructor
  decideOn :: ConHead -> DisambiguateConstructor
decideOn ConHead
c = do
    [Char] -> Nat -> [Char] -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> [Char] -> m ()
reportSLn [Char]
"tc.check.term.con" Nat
40 ([Char] -> TCMT IO ()) -> [Char] -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [Char]
"  decided on: " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ ConHead -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow ConHead
c
    Induction -> QName -> TCMT IO ()
storeDisambiguatedConstructor (ConHead -> Induction
conInductive ConHead
c) (ConHead -> QName
conName ConHead
c)
    Either Blocker ConHead -> DisambiguateConstructor
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Blocker ConHead -> DisambiguateConstructor)
-> Either Blocker ConHead -> DisambiguateConstructor
forall a b. (a -> b) -> a -> b
$ ConHead -> Either Blocker ConHead
forall a b. b -> Either a b
Right ConHead
c

  -- Look at simple visible arguments (variables (bound and generalizable ones) and defined names).
  -- From these we can compute an approximate type effortlessly:
  -- 1. Throw away hidden domains (needed for generalizable variables).
  -- 2. If the remainder is a defined name that is not blocked on anything, we take this name as
  --    approximate type of the argument.
  -- This gives us a skeleton @[Maybe QName]@.  Compute the same from the constructor types
  -- of the candidates and see if we find any mismatches that allow us to rule out the candidate.
  disambiguateByArgs :: [(QName, Type, ConHead)] -> DisambiguateConstructor -> DisambiguateConstructor
  disambiguateByArgs :: [(QName, Type, ConHead)]
-> DisambiguateConstructor -> DisambiguateConstructor
disambiguateByArgs [(QName, Type, ConHead)]
dcs DisambiguateConstructor
fallback = do

    -- Look for visible arguments that are just variables,
    -- so that we can get their type directly from the context
    -- without full-fledged type inference.
    askel <- TCM [Maybe QName]
visibleVarArgs
    reportSDoc "tc.check.term.con" 40 $ hsep $
      "trying disambiguation by arguments" : map prettyTCM askel
    reportSDoc "tc.check.term.con" 80 $ hsep $
      "trying disambiguation by arguments" : map pretty askel

    -- Filter out candidates with definitive mismatches.
    cands <- filterM (\ (QName
_d, Type
t, ConHead
_c) -> [Maybe QName] -> [Maybe QName] -> TCMT IO Bool
matchSkel [Maybe QName]
askel ([Maybe QName] -> TCMT IO Bool)
-> TCM [Maybe QName] -> TCMT IO Bool
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Type -> TCM [Maybe QName]
visibleConDoms Type
t) dcs
    case cands of
      [(QName
_d, Type
_t, ConHead
c)] -> ConHead -> DisambiguateConstructor
decideOn ConHead
c
      [(QName, Type, ConHead)]
_ -> DisambiguateConstructor
fallback
    where

    -- @match@ is successful if there no name conflict (q ≠ q')
    -- and the argument skeleton is not longer thatn the constructor skeleton.
    match ::
          [Maybe QName]   -- Specification (argument skeleton).
       -> [Maybe QName]   -- Candidate (constructor skeleton).
       -> Bool
    match :: [Maybe QName] -> [Maybe QName] -> Bool
match = (([Maybe QName], [Maybe QName]) -> Bool)
-> [Maybe QName] -> [Maybe QName] -> Bool
forall a b c. ((a, b) -> c) -> a -> b -> c
curry ((([Maybe QName], [Maybe QName]) -> Bool)
 -> [Maybe QName] -> [Maybe QName] -> Bool)
-> (([Maybe QName], [Maybe QName]) -> Bool)
-> [Maybe QName]
-> [Maybe QName]
-> Bool
forall a b. (a -> b) -> a -> b
$ \case
      ([], [Maybe QName]
_ ) -> Bool
True
      ([Maybe QName]
_ , []) -> Bool
False
      (Just QName
q : [Maybe QName]
ms, Just QName
q' : [Maybe QName]
ms') -> QName
q QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
== QName
q' Bool -> Bool -> Bool
&& [Maybe QName] -> [Maybe QName] -> Bool
match [Maybe QName]
ms [Maybe QName]
ms'
      (Maybe QName
_ : [Maybe QName]
ms, Maybe QName
_ : [Maybe QName]
ms') -> [Maybe QName] -> [Maybe QName] -> Bool
match [Maybe QName]
ms [Maybe QName]
ms'

    -- @match@ with debug printing.
    matchSkel :: [Maybe QName] -> [Maybe QName] -> TCM Bool
    matchSkel :: [Maybe QName] -> [Maybe QName] -> TCMT IO Bool
matchSkel [Maybe QName]
argsSkel [Maybe QName]
conSkel = do
      let res :: Bool
res = [Maybe QName] -> [Maybe QName] -> Bool
match [Maybe QName]
argsSkel [Maybe QName]
conSkel
      [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.check.term.con" Nat
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
        [ TCMT IO Doc
"matchSkel returns" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Bool -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Bool
res TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
"on:"
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Maybe QName] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [Maybe QName]
argsSkel
        , Nat -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Functor m => Nat -> m Doc -> m Doc
nest Nat
2 (TCMT IO Doc -> TCMT IO Doc) -> TCMT IO Doc -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Maybe QName] -> TCMT IO Doc
forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [Maybe QName]
conSkel
        ]
      Bool -> TCMT IO Bool
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
res

    -- Only look at visible arguments that are variables or similar identifiers.
    -- For variables/symbols @Just getTypeHead@ else @Nothing@.
    visibleVarArgs :: TCM [Maybe QName]
    visibleVarArgs :: TCM [Maybe QName]
visibleVarArgs = [NamedArg Expr]
-> (NamedArg Expr -> TCMT IO (Maybe QName)) -> TCM [Maybe QName]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM ((NamedArg Expr -> Bool) -> [NamedArg Expr] -> [NamedArg Expr]
forall a. (a -> Bool) -> [a] -> [a]
filter NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
visible [NamedArg Expr]
args) ((NamedArg Expr -> TCMT IO (Maybe QName)) -> TCM [Maybe QName])
-> (NamedArg Expr -> TCMT IO (Maybe QName)) -> TCM [Maybe QName]
forall a b. (a -> b) -> a -> b
$ \ (NamedArg Expr
arg :: NamedArg A.Expr) -> do
        let v :: Expr
v = Expr -> Expr
unScope (Expr -> Expr) -> Expr -> Expr
forall a b. (a -> b) -> a -> b
$ NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
arg
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.check.term.con" Nat
40 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"is this a variable? :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Expr -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Expr -> m Doc
prettyTCM Expr
v
        [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.check.term.con" Nat
90 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"is this a variable? :" TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> ([Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> (Expr -> [Char]) -> Expr -> TCMT IO Doc
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Expr -> [Char]
forall a. Show a => a -> [Char]
show) Expr
v
        case Expr
v of

          -- We can readly grab the type of a variable from the context.
          A.Var Name
x -> do
            t <- Dom Type -> Type
forall t e. Dom' t e -> e
unDom (Dom Type -> Type)
-> ((Term, Dom Type) -> Dom Type) -> (Term, Dom Type) -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Term, Dom Type) -> Dom Type
forall a b. (a, b) -> b
snd ((Term, Dom Type) -> Type)
-> TCMT IO (Term, Dom Type) -> TCMT IO Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Name -> TCMT IO (Term, Dom Type)
forall (m :: * -> *).
(MonadDebug m, MonadTCEnv m) =>
Name -> m (Term, Dom Type)
getVarInfo Name
x
            reportSDoc "tc.check.term.con" 40 $ "type of variable:" <+> prettyTCM t
            -- Just keep the name @D@ of type @D vs@
            getTypeHead t

          -- We can also grab the type of defined symbols if we find them in the signature.
          A.Def QName
x -> do
            QName -> TCMT IO (Either SigError Definition)
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Either SigError Definition)
getConstInfo' QName
x TCMT IO (Either SigError Definition)
-> (Either SigError Definition -> TCMT IO (Maybe QName))
-> TCMT IO (Maybe QName)
forall a b. TCMT IO a -> (a -> TCMT IO b) -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
              Right Definition
def -> Type -> TCMT IO (Maybe QName)
getTypeHead (Type -> TCMT IO (Maybe QName)) -> Type -> TCMT IO (Maybe QName)
forall a b. (a -> b) -> a -> b
$ Definition -> Type
defType Definition
def
              Left{} -> Maybe QName -> TCMT IO (Maybe QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QName
forall a. Maybe a
Nothing
          Expr
_ -> Maybe QName -> TCMT IO (Maybe QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QName
forall a. Maybe a
Nothing

    -- List of visible arguments of the constructor candidate.
    -- E.g. vcons : {A : Set} {n : Nat} (x : A) (xs : Vec A n) → Vec A (suc n)
    -- becomes vcons : ? → Vec → .
    visibleConDoms :: Type -> TCM [Maybe QName]
    visibleConDoms :: Type -> TCM [Maybe QName]
visibleConDoms Type
t = do
      TelV tel _ <- Type -> TCMT IO (TelV Type)
forall (m :: * -> *). PureTCM m => Type -> m (TelV Type)
telViewPath Type
t
      mapM (getTypeHead . snd . unDom) $ filter visible $ telToList tel

-- | If type is of the form @F vs@ and not blocked in any way, return @F@.
getTypeHead :: Type -> TCM (Maybe QName)
getTypeHead :: Type -> TCMT IO (Maybe QName)
getTypeHead Type
t = do
  res <- Type
-> (Blocker -> Type -> TCMT IO (Maybe QName))
-> (NotBlocked -> Type -> TCMT IO (Maybe QName))
-> TCMT IO (Maybe QName)
forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked Type
t (\ Blocker
_ Type
_ -> Maybe QName -> TCMT IO (Maybe QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QName
forall a. Maybe a
Nothing) ((NotBlocked -> Type -> TCMT IO (Maybe QName))
 -> TCMT IO (Maybe QName))
-> (NotBlocked -> Type -> TCMT IO (Maybe QName))
-> TCMT IO (Maybe QName)
forall a b. (a -> b) -> a -> b
$ \ NotBlocked
nb Type
t -> do
    case NotBlocked
nb of
      NotBlocked
ReallyNotBlocked -> do
        -- Drop initial hidden domains (only needed for generalizable variables).
        TelV _ core <- Nat -> (Dom Type -> Bool) -> Type -> TCMT IO (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Nat -> (Dom Type -> Bool) -> Type -> m (TelV Type)
telViewUpTo' (Nat -> Nat
forall a. Num a => a -> a
negate Nat
1) (Bool -> Bool
not (Bool -> Bool) -> (Dom Type -> Bool) -> Dom Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Bool
forall a. LensHiding a => a -> Bool
visible) Type
t
        case unEl core of
          Def QName
q Elims
_ -> Maybe QName -> TCMT IO (Maybe QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe QName -> TCMT IO (Maybe QName))
-> Maybe QName -> TCMT IO (Maybe QName)
forall a b. (a -> b) -> a -> b
$ QName -> Maybe QName
forall a. a -> Maybe a
Just QName
q
          Term
_ -> Maybe QName -> TCMT IO (Maybe QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QName
forall a. Maybe a
Nothing
      -- In the other cases, we do not get the data name.
      NotBlocked
_ -> Maybe QName -> TCMT IO (Maybe QName)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe QName
forall a. Maybe a
Nothing
  reportSDoc "tc.check.term.con" 80 $ hcat $ "getTypeHead(" : prettyTCM t : ") = " : pretty res : []
  return res


---------------------------------------------------------------------------
-- * Projections
---------------------------------------------------------------------------

checkUnambiguousProjectionApplication :: Comparison -> A.Expr -> Type -> QName -> ProjOrigin -> A.Expr -> [NamedArg A.Expr] -> TCM Term
checkUnambiguousProjectionApplication :: Comparison
-> Expr
-> Type
-> QName
-> ProjOrigin
-> Expr
-> [NamedArg Expr]
-> TCM Term
checkUnambiguousProjectionApplication Comparison
cmp Expr
e Type
t QName
x ProjOrigin
o Expr
hd [NamedArg Expr]
args = do
  let fallback :: TCM Term
fallback = Comparison -> Expr -> Type -> Expr -> [NamedArg Expr] -> TCM Term
checkHeadApplication Comparison
cmp Expr
e Type
t Expr
hd [NamedArg Expr]
args
  -- Andreas, 2021-02-19, issue #3289
  -- If a postfix projection was moved to the head by appView,
  -- we have to patch the first argument with the correct hiding info.
  case (ProjOrigin
o, [NamedArg Expr]
args) of
    (ProjOrigin
ProjPostfix, NamedArg Expr
arg : [NamedArg Expr]
rest) -> do
      -- Andreas, 2021-11-19, issue #5657:
      -- If @x@ has been brought into scope by e.g. @open R r@, it is no longer
      -- a projection even though the scope checker labels it so.
      -- Thus, @isProjection@ may fail.
      TCMT IO (Maybe Projection)
-> TCM Term -> (Projection -> TCM Term) -> TCM Term
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (QName -> TCMT IO (Maybe Projection)
forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Maybe Projection)
isProjection QName
x) TCM Term
fallback ((Projection -> TCM Term) -> TCM Term)
-> (Projection -> TCM Term) -> TCM Term
forall a b. (a -> b) -> a -> b
$ \ Projection
pr -> do
        Comparison -> Expr -> Type -> Expr -> [NamedArg Expr] -> TCM Term
checkHeadApplication Comparison
cmp Expr
e Type
t Expr
hd (ArgInfo -> NamedArg Expr -> NamedArg Expr
forall a. LensArgInfo a => ArgInfo -> a -> a
setArgInfo (Projection -> ArgInfo
projArgInfo Projection
pr) NamedArg Expr
arg NamedArg Expr -> [NamedArg Expr] -> [NamedArg Expr]
forall a. a -> [a] -> [a]
: [NamedArg Expr]
rest)
    (ProjOrigin, [NamedArg Expr])
_ -> TCM Term
fallback

-- | Inferring the type of an overloaded projection application.
--   See 'inferOrCheckProjApp'.

inferProjApp :: A.Expr -> ProjOrigin -> List1 QName -> A.Args -> TCM (Term, Type)
inferProjApp :: Expr
-> ProjOrigin -> List1 QName -> [NamedArg Expr] -> TCM (Term, Type)
inferProjApp Expr
e ProjOrigin
o List1 QName
ds [NamedArg Expr]
args0 = do
  (v, t, _) <- Expr
-> ProjOrigin
-> List1 QName
-> [NamedArg Expr]
-> Maybe (Comparison, Type)
-> TCM (Term, Type, CheckedTarget)
inferOrCheckProjApp Expr
e ProjOrigin
o List1 QName
ds [NamedArg Expr]
args0 Maybe (Comparison, Type)
forall a. Maybe a
Nothing
  return (v, t)

-- | Checking the type of an overloaded projection application.
--   See 'inferOrCheckProjApp'.

checkProjApp  :: Comparison -> A.Expr -> ProjOrigin -> List1 QName -> A.Args -> Type -> TCM Term
checkProjApp :: Comparison
-> Expr
-> ProjOrigin
-> List1 QName
-> [NamedArg Expr]
-> Type
-> TCM Term
checkProjApp Comparison
cmp Expr
e ProjOrigin
o List1 QName
ds [NamedArg Expr]
args0 Type
t = do
  (v, ti, targetCheck) <- Expr
-> ProjOrigin
-> List1 QName
-> [NamedArg Expr]
-> Maybe (Comparison, Type)
-> TCM (Term, Type, CheckedTarget)
inferOrCheckProjApp Expr
e ProjOrigin
o List1 QName
ds [NamedArg Expr]
args0 ((Comparison, Type) -> Maybe (Comparison, Type)
forall a. a -> Maybe a
Just (Comparison
cmp, Type
t))
  coerce' cmp targetCheck v ti t

-- | Checking the type of an overloaded projection application.
--   See 'inferOrCheckProjAppToKnownPrincipalArg'.

checkProjAppToKnownPrincipalArg  :: Comparison -> A.Expr -> ProjOrigin -> List1 QName -> A.Args -> Type -> Int -> Term -> Type -> PrincipalArgTypeMetas -> TCM Term
checkProjAppToKnownPrincipalArg :: Comparison
-> Expr
-> ProjOrigin
-> List1 QName
-> [NamedArg Expr]
-> Type
-> Nat
-> Term
-> Type
-> PrincipalArgTypeMetas
-> TCM Term
checkProjAppToKnownPrincipalArg Comparison
cmp Expr
e ProjOrigin
o List1 QName
ds [NamedArg Expr]
args0 Type
t Nat
k Term
v0 Type
pt PrincipalArgTypeMetas
patm = do
  (v, ti, targetCheck) <- Expr
-> ProjOrigin
-> List1 QName
-> [NamedArg Expr]
-> Maybe (Comparison, Type)
-> Nat
-> Term
-> Type
-> Maybe PrincipalArgTypeMetas
-> TCM (Term, Type, CheckedTarget)
inferOrCheckProjAppToKnownPrincipalArg Expr
e ProjOrigin
o List1 QName
ds [NamedArg Expr]
args0 ((Comparison, Type) -> Maybe (Comparison, Type)
forall a. a -> Maybe a
Just (Comparison
cmp, Type
t)) Nat
k Term
v0 Type
pt (PrincipalArgTypeMetas -> Maybe PrincipalArgTypeMetas
forall a. a -> Maybe a
Just PrincipalArgTypeMetas
patm)
  coerce' cmp targetCheck v ti t

-- | Inferring or Checking an overloaded projection application.
--
--   The overloaded projection is disambiguated by inferring the type of its
--   principal argument, which is the first visible argument.

inferOrCheckProjApp
  :: A.Expr
     -- ^ The whole expression which constitutes the application.
  -> ProjOrigin
     -- ^ The origin of the projection involved in this projection application.
  -> List1 QName
     -- ^ The projection name (potentially ambiguous).
  -> A.Args
     -- ^ The arguments to the projection.
  -> Maybe (Comparison, Type)
     -- ^ The expected type of the expression (if 'Nothing', infer it).
  -> TCM (Term, Type, CheckedTarget)
     -- ^ The type-checked expression and its type (if successful).
inferOrCheckProjApp :: Expr
-> ProjOrigin
-> List1 QName
-> [NamedArg Expr]
-> Maybe (Comparison, Type)
-> TCM (Term, Type, CheckedTarget)
inferOrCheckProjApp Expr
e ProjOrigin
o List1 QName
ds [NamedArg Expr]
args Maybe (Comparison, Type)
mt = do
  [Char] -> Nat -> TCMT IO Doc -> TCMT IO ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.proj.amb" Nat
20 (TCMT IO Doc -> TCMT IO ()) -> TCMT IO Doc -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
    [ TCMT IO Doc
"checking ambiguous projection"
    , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"  ds   = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ List1 QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow List1 QName
ds
    , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"  args = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep ((NamedArg Expr -> TCMT IO Doc) -> [NamedArg Expr] -> [TCMT IO Doc]
forall a b. (a -> b) -> [a] -> [b]
map NamedArg Expr -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => NamedArg Expr -> m Doc
prettyTCM [NamedArg Expr]
args)
    , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text   [Char]
"  t    = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> Maybe (Comparison, Type)
-> TCMT IO Doc
-> ((Comparison, Type) -> TCMT IO Doc)
-> TCMT IO Doc
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Comparison, Type)
mt TCMT IO Doc
"Nothing" (Comparison, Type) -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => (Comparison, Type) -> m Doc
prettyTCM
    ]

  let cmp :: Comparison
cmp = Maybe (Comparison, Type)
-> Comparison -> ((Comparison, Type) -> Comparison) -> Comparison
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Comparison, Type)
mt Comparison
CmpEq (Comparison, Type) -> Comparison
forall a b. (a, b) -> a
fst

      -- Postpone the whole type checking problem
      -- if type of principal argument (or the type where we get it from)
      -- is blocked by meta m.
      postpone :: Blocker -> TCM (Term, Type, CheckedTarget)
postpone Blocker
b = do
        tc <- Maybe (Comparison, Type)
-> TCMT IO Type
-> ((Comparison, Type) -> TCMT IO Type)
-> TCMT IO Type
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Comparison, Type)
mt TCMT IO Type
newTypeMeta_ (Type -> TCMT IO Type
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TCMT IO Type)
-> ((Comparison, Type) -> Type)
-> (Comparison, Type)
-> TCMT IO Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comparison, Type) -> Type
forall a b. (a, b) -> b
snd)
        v <- postponeTypeCheckingProblem (CheckExpr cmp e tc) b
        return (v, tc, NotCheckedTarget)

  -- The following cases need to be considered:
  -- 1. No arguments to the projection.
  -- 2. Arguments (parameters), but not the principal argument.
  -- 3. Argument(s) including the principal argument.

  -- For now, we only allow ambiguous projections if the first visible
  -- argument is the record value.

  case ((Nat, NamedArg Expr) -> Bool)
-> [(Nat, NamedArg Expr)] -> [(Nat, NamedArg Expr)]
forall a. (a -> Bool) -> [a] -> [a]
filter (NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
visible (NamedArg Expr -> Bool)
-> ((Nat, NamedArg Expr) -> NamedArg Expr)
-> (Nat, NamedArg Expr)
-> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Nat, NamedArg Expr) -> NamedArg Expr
forall a b. (a, b) -> b
snd) ([(Nat, NamedArg Expr)] -> [(Nat, NamedArg Expr)])
-> [(Nat, NamedArg Expr)] -> [(Nat, NamedArg Expr)]
forall a b. (a -> b) -> a -> b
$ [Nat] -> [NamedArg Expr] -> [(Nat, NamedArg Expr)]
forall a b. [a] -> [b] -> [(a, b)]
zip [Nat
0..] [NamedArg Expr]
args of

    -- Case: we have no visible argument to the projection.
    -- In inference mode, we really need the visible argument, postponing does not help
    [] -> Maybe (Comparison, Type)
-> TCM (Term, Type, CheckedTarget)
-> ((Comparison, Type) -> TCM (Term, Type, CheckedTarget))
-> TCM (Term, Type, CheckedTarget)
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Comparison, Type)
mt (List1 QName -> TCM (Term, Type, CheckedTarget)
forall a. List1 QName -> TCM a
refuseProjNotApplied List1 QName
ds) (((Comparison, Type) -> TCM (Term, Type, CheckedTarget))
 -> TCM (Term, Type, CheckedTarget))
-> ((Comparison, Type) -> TCM (Term, Type, CheckedTarget))
-> TCM (Term, Type, CheckedTarget)
forall a b. (a -> b) -> a -> b
$ \ (Comparison
cmp , Type
t) -> do
      -- If we have the type, we can try to get the type of the principal argument.
      -- It is the first visible argument.
      TelV _ptel core <- Nat -> (Dom Type -> Bool) -> Type -> TCMT IO (TelV Type)
forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Nat -> (Dom Type -> Bool) -> Type -> m (TelV Type)
telViewUpTo' (-Nat
1) (Bool -> Bool
not (Bool -> Bool) -> (Dom Type -> Bool) -> Dom Type -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Dom Type -> Bool
forall a. LensHiding a => a -> Bool
visible) Type
t
      ifBlocked core (\ Blocker
m Type
_ -> Blocker -> TCM (Term, Type, CheckedTarget)
postpone Blocker
m) $ {-else-} \ NotBlocked
_ Type
core -> do
      Type
-> (Type -> TCM (Term, Type, CheckedTarget))
-> (Dom Type -> Abs Type -> TCM (Term, Type, CheckedTarget))
-> TCM (Term, Type, CheckedTarget)
forall (m :: * -> *) a.
MonadReduce m =>
Type -> (Type -> m a) -> (Dom Type -> Abs Type -> m a) -> m a
ifNotPiType Type
core (\ Type
_ -> List1 QName -> TCM (Term, Type, CheckedTarget)
forall a. List1 QName -> TCM a
refuseProjNotApplied List1 QName
ds) ((Dom Type -> Abs Type -> TCM (Term, Type, CheckedTarget))
 -> TCM (Term, Type, CheckedTarget))
-> (Dom Type -> Abs Type -> TCM (Term, Type, CheckedTarget))
-> TCM (Term, Type, CheckedTarget)
forall a b. (a -> b) -> a -> b
$ {-else-} \ Dom Type
dom Abs Type
_b -> do
      Type
-> (Blocker -> Type -> TCM (Term, Type, CheckedTarget))
-> (NotBlocked -> Type -> TCM (Term, Type, CheckedTarget))
-> TCM (Term, Type, CheckedTarget)
forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked (Dom Type -> Type
forall t e. Dom' t e -> e
unDom Dom Type
dom) (\ Blocker
m Type
_ -> Blocker -> TCM (Term, Type, CheckedTarget)
postpone Blocker
m) ((NotBlocked -> Type -> TCM (Term, Type, CheckedTarget))
 -> TCM (Term, Type, CheckedTarget))
-> (NotBlocked -> Type -> TCM (Term, Type, CheckedTarget))
-> TCM (Term, Type, CheckedTarget)
forall a b. (a -> b) -> a -> b
$ {-else-} \ NotBlocked
_ Type
ta -> do
      TCMT IO (Maybe (QName, [Arg Term], RecordData))
-> TCM (Term, Type, CheckedTarget)
-> ((QName, [Arg Term], RecordData)
    -> TCM (Term, Type, CheckedTarget))
-> TCM (Term, Type, CheckedTarget)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Type -> TCMT IO (Maybe (QName, [Arg Term], RecordData))
forall (m :: * -> *).
PureTCM m =>
Type -> m (Maybe (QName, [Arg Term], RecordData))
isRecordType Type
ta) (List1 QName
-> Maybe Term -> Type -> TCM (Term, Type, CheckedTarget)
forall a. List1 QName -> Maybe Term -> Type -> TCM a
refuseProjNotRecordType List1 QName
ds Maybe Term
forall a. Maybe a
Nothing Type
ta)
        \ (QName
_q, [Arg Term]
_pars, RecordData{ _recFields :: RecordData -> [Dom QName]
_recFields = [Dom QName]
fs }) -> do
          case [Dom QName] -> (Dom QName -> Maybe QName) -> [QName]
forall a b. [a] -> (a -> Maybe b) -> [b]
forMaybe [Dom QName]
fs ((Dom QName -> Maybe QName) -> [QName])
-> (Dom QName -> Maybe QName) -> [QName]
forall a b. (a -> b) -> a -> b
$ \ Dom QName
f -> (QName -> Bool) -> List1 QName -> Maybe QName
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
Fold.find (Dom QName -> QName
forall t e. Dom' t e -> e
unDom Dom QName
f QName -> QName -> Bool
forall a. Eq a => a -> a -> Bool
==) List1 QName
ds of
            [] -> List1 QName -> TCM (Term, Type, CheckedTarget)
forall a. List1 QName -> TCM a
refuseProjNoMatching List1 QName
ds
            [QName
d] -> do
              QName -> TCMT IO ()
storeDisambiguatedProjection QName
d
              -- checkHeadApplication will check the target type
              (, Type
t, Maybe ProblemId -> CheckedTarget
CheckedTarget Maybe ProblemId
forall a. Maybe a
Nothing) (Term -> (Term, Type, CheckedTarget))
-> TCM Term -> TCM (Term, Type, CheckedTarget)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                Comparison -> Expr -> Type -> Expr -> [NamedArg Expr] -> TCM Term
checkHeadApplication Comparison
cmp Expr
e Type
t (ProjOrigin -> AmbiguousQName -> Expr
A.Proj ProjOrigin
o (AmbiguousQName -> Expr) -> AmbiguousQName -> Expr
forall a b. (a -> b) -> a -> b
$ QName -> AmbiguousQName
unambiguous QName
d) [NamedArg Expr]
args
            [QName]
_ -> TCM (Term, Type, CheckedTarget)
forall a. HasCallStack => a
__IMPOSSIBLE__

    -- Case: we have a visible argument
    ((Nat
k, NamedArg Expr
arg) : [(Nat, NamedArg Expr)]
_) -> do
      (v0, ta) <- Expr -> TCM (Term, Type)
inferExpr (Expr -> TCM (Term, Type)) -> Expr -> TCM (Term, Type)
forall a b. (a -> b) -> a -> b
$ NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
arg
      reportSDoc "tc.proj.amb" 25 $ vcat
        [ "  principal arg " <+> prettyTCM arg
        , "  has type "      <+> prettyTCM ta
        ]
      inferOrCheckProjAppToKnownPrincipalArg e o ds args mt k v0 ta Nothing

-- | Same arguments 'inferOrCheckProjApp' above but also gets the position,
--   value and type of the principal argument.
inferOrCheckProjAppToKnownPrincipalArg
  :: A.Expr
     -- ^ The whole expression which constitutes the application.
  -> ProjOrigin
     -- ^ The origin of the projection involved in this projection application.
  -> List1 QName
     -- ^ The projection name (potentially ambiguous).
  -> A.Args
     -- ^ The arguments to the projection.
  -> Maybe (Comparison, Type)
     -- ^ The expected type of the expression (if 'Nothing', infer it).
  -> Int
     -- ^ The position of the principal argument.
  -> Term
     -- ^ The value of the principal argument.
  -> Type
     -- ^ The type of the principal argument.
  -> Maybe PrincipalArgTypeMetas
     -- ^ The metas previously created for the principal argument's type, when
     --   picking up a postponed problem. 'Nothing', otherwise.
  -> TCM (Term, Type, CheckedTarget)
     -- ^ The type-checked expression and its type (if successful).
inferOrCheckProjAppToKnownPrincipalArg :: Expr
-> ProjOrigin
-> List1 QName
-> [NamedArg Expr]
-> Maybe (Comparison, Type)
-> Nat
-> Term
-> Type
-> Maybe PrincipalArgTypeMetas
-> TCM (Term, Type, CheckedTarget)
inferOrCheckProjAppToKnownPrincipalArg Expr
e ProjOrigin
o List1 QName
ds [NamedArg Expr]
args Maybe (Comparison, Type)
mt Nat
k Term
v0 Type
ta Maybe PrincipalArgTypeMetas
mpatm = do
  let cmp :: Comparison
cmp = Maybe (Comparison, Type)
-> Comparison -> ((Comparison, Type) -> Comparison) -> Comparison
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Comparison, Type)
mt Comparison
CmpEq (Comparison, Type) -> Comparison
forall a b. (a, b) -> a
fst
      postpone :: Blocker -> PrincipalArgTypeMetas -> TCM (Term, Type, CheckedTarget)
postpone Blocker
b PrincipalArgTypeMetas
patm = do
        tc <- Maybe (Comparison, Type)
-> TCMT IO Type
-> ((Comparison, Type) -> TCMT IO Type)
-> TCMT IO Type
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Comparison, Type)
mt TCMT IO Type
newTypeMeta_ (Type -> TCMT IO Type
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TCMT IO Type)
-> ((Comparison, Type) -> Type)
-> (Comparison, Type)
-> TCMT IO Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comparison, Type) -> Type
forall a b. (a, b) -> b
snd)
        v <- postponeTypeCheckingProblem (CheckProjAppToKnownPrincipalArg cmp e o ds args tc k v0 ta patm) b
        return (v, tc, NotCheckedTarget)
  -- ta should be a record type (after introducing the hidden args in v0)
  patm@(PrincipalArgTypeMetas vargs ta) <- case Maybe PrincipalArgTypeMetas
mpatm of
    -- keep using the previously created metas, when picking up a postponed
    -- problem - see #4924
    Just PrincipalArgTypeMetas
patm -> PrincipalArgTypeMetas -> TCMT IO PrincipalArgTypeMetas
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return PrincipalArgTypeMetas
patm
    -- create fresh metas
    Maybe PrincipalArgTypeMetas
Nothing -> ([Arg Term] -> Type -> PrincipalArgTypeMetas)
-> ([Arg Term], Type) -> PrincipalArgTypeMetas
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry [Arg Term] -> Type -> PrincipalArgTypeMetas
PrincipalArgTypeMetas (([Arg Term], Type) -> PrincipalArgTypeMetas)
-> TCMT IO ([Arg Term], Type) -> TCMT IO PrincipalArgTypeMetas
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Nat -> (Hiding -> Bool) -> Type -> TCMT IO ([Arg Term], Type)
forall (m :: * -> *).
(PureTCM m, MonadMetaSolver m, MonadTCM m) =>
Nat -> (Hiding -> Bool) -> Type -> m ([Arg Term], Type)
implicitArgs (-Nat
1) (Bool -> Bool
not (Bool -> Bool) -> (Hiding -> Bool) -> Hiding -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Hiding -> Bool
forall a. LensHiding a => a -> Bool
visible) Type
ta
  let v = Term
v0 Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Arg Term]
vargs
  ifBlocked ta (\ Blocker
m Type
_ -> Blocker -> PrincipalArgTypeMetas -> TCM (Term, Type, CheckedTarget)
postpone Blocker
m PrincipalArgTypeMetas
patm) {-else-} $ \ NotBlocked
_ Type
ta -> do
  TCMT IO (Maybe (QName, [Arg Term], RecordData))
-> TCM (Term, Type, CheckedTarget)
-> ((QName, [Arg Term], RecordData)
    -> TCM (Term, Type, CheckedTarget))
-> TCM (Term, Type, CheckedTarget)
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (Type -> TCMT IO (Maybe (QName, [Arg Term], RecordData))
forall (m :: * -> *).
PureTCM m =>
Type -> m (Maybe (QName, [Arg Term], RecordData))
isRecordType Type
ta) (List1 QName
-> Maybe Term -> Type -> TCM (Term, Type, CheckedTarget)
forall a. List1 QName -> Maybe Term -> Type -> TCM a
refuseProjNotRecordType List1 QName
ds (Term -> Maybe Term
forall a. a -> Maybe a
Just Term
v0) Type
ta) (((QName, [Arg Term], RecordData)
  -> TCM (Term, Type, CheckedTarget))
 -> TCM (Term, Type, CheckedTarget))
-> ((QName, [Arg Term], RecordData)
    -> TCM (Term, Type, CheckedTarget))
-> TCM (Term, Type, CheckedTarget)
forall a b. (a -> b) -> a -> b
$ \ (QName
q, [Arg Term]
_pars0, RecordData
_) -> do

      -- try to project it with all of the possible projections
      let try :: QName
-> MaybeT
     (TCMT IO) (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))
try QName
d = do
            [Char] -> Nat -> TCMT IO Doc -> MaybeT (TCMT IO) ()
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Nat -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.proj.amb" Nat
30 (TCMT IO Doc -> MaybeT (TCMT IO) ())
-> TCMT IO Doc -> MaybeT (TCMT IO) ()
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
              [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"trying projection " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
d
              , TCMT IO Doc
"  td  = " TCMT IO Doc -> TCMT IO Doc -> TCMT IO Doc
forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO (Maybe Type)
-> TCMT IO Doc -> (Type -> TCMT IO Doc) -> TCMT IO Doc
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (QName -> Type -> TCMT IO (Maybe Type)
forall (m :: * -> *). PureTCM m => QName -> Type -> m (Maybe Type)
getDefType QName
d Type
ta) TCMT IO Doc
"Nothing" Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM
              ]

            -- get the original projection name
            def <- TCMT IO Definition -> MaybeT (TCMT IO) Definition
forall (m :: * -> *) a. Monad m => m a -> MaybeT m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TCMT IO Definition -> MaybeT (TCMT IO) Definition)
-> TCMT IO Definition -> MaybeT (TCMT IO) Definition
forall a b. (a -> b) -> a -> b
$ QName -> TCMT IO Definition
forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
            let isP = Defn -> Maybe Projection
isProjection_ (Defn -> Maybe Projection) -> Defn -> Maybe Projection
forall a b. (a -> b) -> a -> b
$ Definition -> Defn
theDef Definition
def
            reportSDoc "tc.proj.amb" 40 $ vcat $
              text ( "  isProjection = " ++ caseMaybe isP "no" (const "yes")
                   ) : caseMaybe isP [] (\ Projection{ projProper :: Projection -> Maybe QName
projProper = Maybe QName
proper, projOrig :: Projection -> QName
projOrig = QName
orig } ->
              [ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"  proper       = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Maybe QName -> [Char]
forall a. Show a => a -> [Char]
show Maybe QName
proper
              , [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
text ([Char] -> TCMT IO Doc) -> [Char] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$ [Char]
"  orig         = " [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ QName -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow QName
orig
              ])

            -- Andreas, 2017-01-21, issue #2422
            -- The scope checker considers inherited projections (from nested records)
            -- as projections and allows overloading.  However, since they are defined
            -- as *composition* of projections, the type checker does *not* recognize them,
            -- and @isP@ will be @Nothing@.
            -- However, we can ignore this, as we only need the @orig@inal projection name
            -- for removing false ambiguity.  Thus, we skip these checks:

            -- Projection{ projProper = proper, projOrig = orig } <- MaybeT $ return isP
            -- guard $ isJust proper
            let orig = Maybe Projection -> QName -> (Projection -> QName) -> QName
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe Projection
isP QName
d Projection -> QName
projOrig

            -- try to eliminate
            (dom, u, tb) <- MaybeT (projectTyped v ta o d `catchError` \ TCErr
_ -> Maybe (Dom Type, Term, Type)
-> TCMT IO (Maybe (Dom Type, Term, Type))
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe (Dom Type, Term, Type)
forall a. Maybe a
Nothing)
            reportSDoc "tc.proj.amb" 30 $ vcat
              [ "  dom = " <+> prettyTCM dom
              , "  u   = " <+> prettyTCM u
              , "  tb  = " <+> prettyTCM tb
              ]
            (q', pars, _) <- MaybeT $ isRecordType $ unDom dom
            reportSDoc "tc.proj.amb" 30 $ vcat
              [ "  q   = " <+> prettyTCM q
              , "  q'  = " <+> prettyTCM q'
              ]
            guard (q == q')
            -- Get the type of the projection and check
            -- that the first visible argument is the record value.
            let tfull = Definition -> Type
defType Definition
def
            TelV tel _ <- lift $ telViewUpTo' (-1) (not . visible) tfull
            reportSDoc "tc.proj.amb" 30 $ vcat
              [ text $ "  size tel  = " ++ show (size tel)
              , text $ "  size pars = " ++ show (size pars)
              ]
            -- See issue 1960 for when the following assertion fails for
            -- the correct disambiguation.
            -- guard (natSize tel == natSize pars)

            guard =<< do isNothing <$> do lift $ checkModality' d def
            return (orig, (d, (pars, (dom, u, tb))))

      cands <- ((QName, (QName, ([Arg Term], (Dom Type, Term, Type)))) -> QName)
-> [(QName, (QName, ([Arg Term], (Dom Type, Term, Type))))]
-> [List1 (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))]
forall b a. Ord b => (a -> b) -> [a] -> [List1 a]
List1.groupOn (QName, (QName, ([Arg Term], (Dom Type, Term, Type)))) -> QName
forall a b. (a, b) -> a
fst ([(QName, (QName, ([Arg Term], (Dom Type, Term, Type))))]
 -> [List1 (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))])
-> (List1
      (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type)))))
    -> [(QName, (QName, ([Arg Term], (Dom Type, Term, Type))))])
-> List1
     (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type)))))
-> [List1 (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1
  (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type)))))
-> [(QName, (QName, ([Arg Term], (Dom Type, Term, Type))))]
forall a. List1 (Maybe a) -> [a]
List1.catMaybes (List1
   (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type)))))
 -> [List1 (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))])
-> TCMT
     IO
     (List1
        (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))))
-> TCMT
     IO [List1 (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (QName
 -> TCMT
      IO (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))))
-> List1 QName
-> TCMT
     IO
     (List1
        (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))))
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b.
Monad m =>
(a -> m b) -> NonEmpty a -> m (NonEmpty b)
mapM (MaybeT
  (TCMT IO) (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))
-> TCMT
     IO (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type)))))
forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (MaybeT
   (TCMT IO) (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))
 -> TCMT
      IO (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))))
-> (QName
    -> MaybeT
         (TCMT IO) (QName, (QName, ([Arg Term], (Dom Type, Term, Type)))))
-> QName
-> TCMT
     IO (Maybe (QName, (QName, ([Arg Term], (Dom Type, Term, Type)))))
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName
-> MaybeT
     (TCMT IO) (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))
try) List1 QName
ds
      case cands of
        [] -> List1 QName -> TCM (Term, Type, CheckedTarget)
forall a. List1 QName -> TCM a
refuseProjNoMatching List1 QName
ds
        (List1 (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))
_:List1 (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))
_:[List1 (QName, (QName, ([Arg Term], (Dom Type, Term, Type))))]
_) -> List1 QName -> TCMT IO Doc -> TCM (Term, Type, CheckedTarget)
forall a. List1 QName -> TCMT IO Doc -> TCM a
refuseProj List1 QName
ds (TCMT IO Doc -> TCM (Term, Type, CheckedTarget))
-> TCMT IO Doc -> TCM (Term, Type, CheckedTarget)
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
fwords [Char]
"several matching candidates can be applied."
        -- case: just one matching projection d
        -- the term u = d v
        -- the type tb is the type of this application
        [ (QName
_orig, (QName
d, ([Arg Term]
pars, (Dom Type
_dom,Term
u,Type
tb)))) :| [(QName, (QName, ([Arg Term], (Dom Type, Term, Type))))]
_ ] -> do
          QName -> TCMT IO ()
storeDisambiguatedProjection QName
d

          -- Check parameters
          tfull <- QName -> TCMT IO Type
forall (m :: * -> *).
(HasConstInfo m, ReadTCState m) =>
QName -> m Type
typeOfConst QName
d
          (_,_) <- checkKnownArguments (take k args) pars tfull

          -- Check remaining arguments
          let r     = Expr -> Range
forall a. HasRange a => a -> Range
getRange Expr
e
              args' = Nat -> [NamedArg Expr] -> [NamedArg Expr]
forall a. Nat -> [a] -> [a]
drop (Nat
k Nat -> Nat -> Nat
forall a. Num a => a -> a -> a
+ Nat
1) [NamedArg Expr]
args
          z <- runExceptT $ checkArgumentsE cmp ExpandLast r args' tb (snd <$> mt)
          case z of
            Right st :: ArgsCheckState CheckedTarget
st@(ACState [CheckedArg]
_ Type
trest CheckedTarget
targetCheck) -> do
              v <- (Elims -> Term) -> ArgsCheckState CheckedTarget -> TCM Term
forall a. (Elims -> Term) -> ArgsCheckState a -> TCM Term
checkHeadConstraints (Term
u Term -> Elims -> Term
forall t. Apply t => t -> Elims -> t
`applyE`) ArgsCheckState CheckedTarget
st
              return (v, trest, targetCheck)
            Left ArgsCheckState [NamedArg Expr]
problem -> do
              -- In the inference case:
              -- To create a postponed type checking problem,
              -- we do not use typeDontCare, but create a meta.
              tc <- Maybe (Comparison, Type)
-> TCMT IO Type
-> ((Comparison, Type) -> TCMT IO Type)
-> TCMT IO Type
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe (Comparison, Type)
mt TCMT IO Type
newTypeMeta_ (Type -> TCMT IO Type
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Type -> TCMT IO Type)
-> ((Comparison, Type) -> Type)
-> (Comparison, Type)
-> TCMT IO Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Comparison, Type) -> Type
forall a b. (a, b) -> b
snd)
              v  <- postponeArgs problem cmp ExpandLast r args' tc $ \ st :: ArgsCheckState CheckedTarget
st@(ACState [CheckedArg]
_ Type
trest CheckedTarget
targetCheck) -> do
                      v <- (Elims -> Term) -> ArgsCheckState CheckedTarget -> TCM Term
forall a. (Elims -> Term) -> ArgsCheckState a -> TCM Term
checkHeadConstraints (Term
u Term -> Elims -> Term
forall t. Apply t => t -> Elims -> t
`applyE`) ArgsCheckState CheckedTarget
st
                      coerce' cmp targetCheck v trest tc

              return (v, tc, NotCheckedTarget)

-- | Throw 'AmbiguousOverloadedProjection' with additional explanation.
refuseProj :: List1 QName -> TCM Doc -> TCM a
refuseProj :: forall a. List1 QName -> TCMT IO Doc -> TCM a
refuseProj List1 QName
ds TCMT IO Doc
reason = TypeError -> TCMT IO a
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO a) -> (Doc -> TypeError) -> Doc -> TCMT IO a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. List1 QName -> Doc -> TypeError
AmbiguousOverloadedProjection List1 QName
ds (Doc -> TCMT IO a) -> TCMT IO Doc -> TCMT IO a
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< TCMT IO Doc
reason

refuseProjNotApplied, refuseProjNoMatching :: List1 QName -> TCM a
refuseProjNotApplied :: forall a. List1 QName -> TCM a
refuseProjNotApplied    List1 QName
ds = List1 QName -> TCMT IO Doc -> TCM a
forall a. List1 QName -> TCMT IO Doc -> TCM a
refuseProj List1 QName
ds (TCMT IO Doc -> TCM a) -> TCMT IO Doc -> TCM a
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
fwords [Char]
"it is not applied to a visible argument"
refuseProjNoMatching :: forall a. List1 QName -> TCM a
refuseProjNoMatching    List1 QName
ds = List1 QName -> TCMT IO Doc -> TCM a
forall a. List1 QName -> TCMT IO Doc -> TCM a
refuseProj List1 QName
ds (TCMT IO Doc -> TCM a) -> TCMT IO Doc -> TCM a
forall a b. (a -> b) -> a -> b
$ [Char] -> TCMT IO Doc
forall (m :: * -> *). Applicative m => [Char] -> m Doc
fwords [Char]
"no matching candidate found"
refuseProjNotRecordType :: List1 QName -> Maybe Term -> Type -> TCM a
refuseProjNotRecordType :: forall a. List1 QName -> Maybe Term -> Type -> TCM a
refuseProjNotRecordType List1 QName
ds Maybe Term
pValue Type
pType = do
  let dType :: TCMT IO Doc
dType = Type -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Type -> m Doc
prettyTCM Type
pType
  let dValue :: TCMT IO Doc
dValue = Maybe Term -> TCMT IO Doc -> (Term -> TCMT IO Doc) -> TCMT IO Doc
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe Term
pValue (Doc -> TCMT IO Doc
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return Doc
forall a. Null a => a
empty) Term -> TCMT IO Doc
forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
forall (m :: * -> *). MonadPretty m => Term -> m Doc
prettyTCM
  List1 QName -> TCMT IO Doc -> TCM a
forall a. List1 QName -> TCMT IO Doc -> TCM a
refuseProj List1 QName
ds (TCMT IO Doc -> TCM a) -> TCMT IO Doc -> TCM a
forall a b. (a -> b) -> a -> b
$ [TCMT IO Doc] -> TCMT IO Doc
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep ([TCMT IO Doc] -> TCMT IO Doc) -> [TCMT IO Doc] -> TCMT IO Doc
forall a b. (a -> b) -> a -> b
$
    [TCMT IO Doc
"principal argument", TCMT IO Doc
dValue, TCMT IO Doc
"has type", TCMT IO Doc
dType, TCMT IO Doc
"while it should be of record type"]

-----------------------------------------------------------------------------
-- * Sorts
-----------------------------------------------------------------------------

checkUniv
  :: UnivSize -> Univ -> Comparison -> A.Expr -> Type
  -> QName -> Suffix -> [NamedArg A.Expr] -> TCM Term
checkUniv :: UnivSize
-> Univ
-> Comparison
-> Expr
-> Type
-> QName
-> Suffix
-> [NamedArg Expr]
-> TCM Term
checkUniv UnivSize
sz Univ
u Comparison
cmp Expr
e Type
t QName
q Suffix
suffix [NamedArg Expr]
args = do
  (v, t0) <- UnivSize
-> Univ
-> Expr
-> QName
-> Suffix
-> [NamedArg Expr]
-> TCM (Term, Type)
inferUniv UnivSize
sz Univ
u Expr
e QName
q Suffix
suffix [NamedArg Expr]
args
  coerce cmp v t0 t

inferUniv :: UnivSize -> Univ -> A.Expr -> QName -> Suffix -> [NamedArg A.Expr] -> TCM (Term, Type)
inferUniv :: UnivSize
-> Univ
-> Expr
-> QName
-> Suffix
-> [NamedArg Expr]
-> TCM (Term, Type)
inferUniv UnivSize
sz Univ
u Expr
e QName
q Suffix
s [NamedArg Expr]
args = do
  Univ -> TCMT IO ()
univChecks Univ
u
  case UnivSize
sz of
    UnivSize
USmall -> Univ -> QName -> Suffix -> [NamedArg Expr] -> TCM (Term, Type)
inferLeveledSort Univ
u QName
q Suffix
s [NamedArg Expr]
args
    UnivSize
ULarge -> Univ -> QName -> Suffix -> [NamedArg Expr] -> TCM (Term, Type)
inferUnivOmega Univ
u QName
q Suffix
s [NamedArg Expr]
args

univChecks :: Univ -> TCM ()
univChecks :: Univ -> TCMT IO ()
univChecks = \case
  Univ
UProp -> TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM TCMT IO Bool
forall (m :: * -> *). HasOptions m => m Bool
isPropEnabled (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
NeedOptionProp
  Univ
UType -> () -> TCMT IO ()
forall a. a -> TCMT IO a
forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
  Univ
USSet -> TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM TCMT IO Bool
forall (m :: * -> *). HasOptions m => m Bool
isTwoLevelEnabled (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
NeedOptionTwoLevel

suffixToLevel :: Suffix -> Integer
suffixToLevel :: Suffix -> Integer
suffixToLevel = \case
  Suffix
NoSuffix -> Integer
0
  Suffix Integer
n -> Integer
n

inferLeveledSort ::
     Univ                -- ^ The universe type.
  -> QName               -- ^ Name of the universe, for error reporting.
  -> Suffix              -- ^ Level of the universe given via suffix (optional).
  -> [NamedArg A.Expr]   -- ^ Level of the universe given via argument (absent if suffix).
  -> TCM (Term, Type)    -- ^ Universe and its sort.
inferLeveledSort :: Univ -> QName -> Suffix -> [NamedArg Expr] -> TCM (Term, Type)
inferLeveledSort Univ
u QName
q Suffix
suffix = \case
  [] -> do
    let n :: Integer
n = Suffix -> Integer
suffixToLevel Suffix
suffix
    (Term, Type) -> TCM (Term, Type)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort -> Term
Sort (Univ -> Level' Term -> Sort
forall t. Univ -> Level' t -> Sort' t
Univ Univ
u (Level' Term -> Sort) -> Level' Term -> Sort
forall a b. (a -> b) -> a -> b
$ Integer -> Level' Term
ClosedLevel Integer
n) , Sort -> Type
sort (Univ -> Level' Term -> Sort
forall t. Univ -> Level' t -> Sort' t
Univ (Univ -> Univ
univUniv Univ
u) (Level' Term -> Sort) -> Level' Term -> Sort
forall a b. (a -> b) -> a -> b
$ Integer -> Level' Term
ClosedLevel (Integer -> Level' Term) -> Integer -> Level' Term
forall a b. (a -> b) -> a -> b
$ Integer
n Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
1))
  NamedArg Expr
arg : [NamedArg Expr]
args -> do
    Bool -> TCMT IO () -> TCMT IO ()
forall b (m :: * -> *). (IsBool b, Monad m) => b -> m () -> m ()
unless (NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Expr
arg) (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO ()) -> TypeError -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Type -> TypeError
WrongHidingInApplication (Type -> TypeError) -> Type -> TypeError
forall a b. (a -> b) -> a -> b
$ Sort -> Type
sort (Sort -> Type) -> Sort -> Type
forall a b. (a -> b) -> a -> b
$ Univ -> Level' Term -> Sort
forall t. Univ -> Level' t -> Sort' t
Univ Univ
u (Level' Term -> Sort) -> Level' Term -> Sort
forall a b. (a -> b) -> a -> b
$ Integer -> Level' Term
ClosedLevel Integer
0
    TCMT IO Bool -> TCMT IO () -> TCMT IO ()
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM TCMT IO Bool
forall (m :: * -> *). HasOptions m => m Bool
hasUniversePolymorphism (TCMT IO () -> TCMT IO ()) -> TCMT IO () -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ TypeError -> TCMT IO ()
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
NeedOptionUniversePolymorphism
    [NamedArg Expr]
-> (List1 (NamedArg Expr) -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a.
Applicative m =>
[a] -> (List1 a -> m ()) -> m ()
List1.unlessNull [NamedArg Expr]
args ((List1 (NamedArg Expr) -> TCMT IO ()) -> TCMT IO ())
-> (List1 (NamedArg Expr) -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ())
-> (List1 (NamedArg Expr) -> Warning)
-> List1 (NamedArg Expr)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> List1 (NamedArg Expr) -> Warning
TooManyArgumentsToSort QName
q
    l <- Relevance -> TCMT IO (Level' Term) -> TCMT IO (Level' Term)
forall (tcm :: * -> *) r a.
(MonadTCEnv tcm, LensRelevance r) =>
r -> tcm a -> tcm a
applyRelevanceToContext Relevance
shapeIrrelevant (TCMT IO (Level' Term) -> TCMT IO (Level' Term))
-> TCMT IO (Level' Term) -> TCMT IO (Level' Term)
forall a b. (a -> b) -> a -> b
$ NamedArg Expr -> TCMT IO (Level' Term)
checkLevel NamedArg Expr
arg
    return (Sort $ Univ u l , sort (Univ (univUniv u) $ levelSuc l))

inferUnivOmega ::
     Univ                -- ^ The universe type.
  -> QName               -- ^ Name of the universe, for error reporting.
  -> Suffix              -- ^ Level of the universe given via suffix (optional).
  -> [NamedArg A.Expr]   -- ^ Level of the universe given via argument (should be absent).
  -> TCM (Term, Type)    -- ^ Universe and its sort.
inferUnivOmega :: Univ -> QName -> Suffix -> [NamedArg Expr] -> TCM (Term, Type)
inferUnivOmega Univ
u QName
q Suffix
suffix [NamedArg Expr]
args = do
    [NamedArg Expr]
-> (List1 (NamedArg Expr) -> TCMT IO ()) -> TCMT IO ()
forall (m :: * -> *) a.
Applicative m =>
[a] -> (List1 a -> m ()) -> m ()
List1.unlessNull [NamedArg Expr]
args ((List1 (NamedArg Expr) -> TCMT IO ()) -> TCMT IO ())
-> (List1 (NamedArg Expr) -> TCMT IO ()) -> TCMT IO ()
forall a b. (a -> b) -> a -> b
$ Warning -> TCMT IO ()
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning (Warning -> TCMT IO ())
-> (List1 (NamedArg Expr) -> Warning)
-> List1 (NamedArg Expr)
-> TCMT IO ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> List1 (NamedArg Expr) -> Warning
TooManyArgumentsToSort QName
q
    let n :: Integer
n = Suffix -> Integer
suffixToLevel Suffix
suffix
    (Term, Type) -> TCM (Term, Type)
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Sort -> Term
Sort (Univ -> Integer -> Sort
forall t. Univ -> Integer -> Sort' t
Inf Univ
u Integer
n) , Sort -> Type
sort (Univ -> Integer -> Sort
forall t. Univ -> Integer -> Sort' t
Inf (Univ -> Univ
univUniv Univ
u) (Integer -> Sort) -> Integer -> Sort
forall a b. (a -> b) -> a -> b
$ Integer
1 Integer -> Integer -> Integer
forall a. Num a => a -> a -> a
+ Integer
n))

-----------------------------------------------------------------------------
-- * Coinduction
-----------------------------------------------------------------------------

checkSharpApplication :: A.Expr -> Type -> QName -> [NamedArg A.Expr] -> TCM Term
checkSharpApplication :: Expr -> Type -> QName -> [NamedArg Expr] -> TCM Term
checkSharpApplication Expr
e Type
t QName
c [NamedArg Expr]
args = do
  arg <- case [NamedArg Expr]
args of
           [NamedArg Expr
a] | NamedArg Expr -> Bool
forall a. LensHiding a => a -> Bool
visible NamedArg Expr
a -> Expr -> TCMT IO Expr
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Expr -> TCMT IO Expr) -> Expr -> TCMT IO Expr
forall a b. (a -> b) -> a -> b
$ NamedArg Expr -> Expr
forall a. NamedArg a -> a
namedArg NamedArg Expr
a
           [NamedArg Expr]
_ -> TypeError -> TCMT IO Expr
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO Expr) -> TypeError -> TCMT IO Expr
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
WrongSharpArity QName
c

  -- The name of the fresh function.
  i <- fresh :: TCM Int
  let name = (Char -> Bool) -> [Char] -> [Char]
forall a. (a -> Bool) -> [a] -> [a]
filter (Char -> Char -> Bool
forall a. Eq a => a -> a -> Bool
/= Char
'_') (Name -> [Char]
forall a. Pretty a => a -> [Char]
prettyShow (Name -> [Char]) -> Name -> [Char]
forall a b. (a -> b) -> a -> b
$ Name -> Name
A.nameConcrete (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ QName -> Name
A.qnameName QName
c) [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ [Char]
"-" [Char] -> [Char] -> [Char]
forall a. [a] -> [a] -> [a]
++ Nat -> [Char]
forall a. Show a => a -> [Char]
show Nat
i

  kit <- coinductionKit'
  let flat = CoinductionKit -> QName
nameOfFlat CoinductionKit
kit
      inf  = CoinductionKit -> QName
nameOfInf  CoinductionKit
kit

  -- Add the type signature of the fresh function to the
  -- signature.
  -- To make sure we can type check the generated function we have to make
  -- sure that its type is \inf. The reason for this is that we don't yet
  -- postpone checking of patterns when we don't know their types (Issue480).
  forcedType <- do
    lvl <- levelType
    (_, l) <- newValueMeta RunMetaOccursCheck CmpLeq lvl
    lv  <- levelView l
    (_, a) <- newValueMeta RunMetaOccursCheck CmpEq (sort $ Type lv)
    return $ El (Type lv) $ Def inf [Apply $ setHiding Hidden $ defaultArg l, Apply $ defaultArg a]

  wrapper <- inFreshModuleIfFreeParams $
             setRunTimeModeUnlessInHardCompileTimeMode $ do
    -- Andreas, 2019-10-12: create helper functions in non-erased mode.
    -- Otherwise, they are not usable in meta-solutions in the term world.
    -- #4743: Except if hard compile-time mode is enabled.
    c' <- setRange (getRange c) <$>
            liftM2 qualify (killRange <$> currentModule)
                           (freshName_ name)

    -- Define and type check the fresh function.
    mod <- currentModality
    abs <- asksTC (^. lensIsAbstract)
    let info   = Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' Expr
forall t.
Name -> Fixity' -> Access -> IsAbstract -> Range -> DefInfo' t
A.mkDefInfo (Name -> Name
A.nameConcrete (Name -> Name) -> Name -> Name
forall a b. (a -> b) -> a -> b
$ QName -> Name
A.qnameName QName
c') Fixity'
noFixity'
                             Access
PublicAccess IsAbstract
abs Range
forall a. Range' a
noRange
        core   = A.LHSProj { lhsDestructor :: AmbiguousQName
A.lhsDestructor = QName -> AmbiguousQName
unambiguous QName
flat
                           , lhsFocus :: NamedArg (LHSCore' Expr)
A.lhsFocus      = LHSCore' Expr -> NamedArg (LHSCore' Expr)
forall a. a -> NamedArg a
defaultNamedArg (LHSCore' Expr -> NamedArg (LHSCore' Expr))
-> LHSCore' Expr -> NamedArg (LHSCore' Expr)
forall a b. (a -> b) -> a -> b
$ QName -> [NamedArg (Pattern' Expr)] -> LHSCore' Expr
forall e. QName -> [NamedArg (Pattern' e)] -> LHSCore' e
A.LHSHead QName
c' []
                           , lhsPats :: [NamedArg (Pattern' Expr)]
A.lhsPats       = [] }
        clause = LHS
-> [ProblemEq] -> RHS -> WhereDeclarations -> Bool -> Clause' LHS
forall lhs.
lhs
-> [ProblemEq] -> RHS -> WhereDeclarations -> Bool -> Clause' lhs
A.Clause (LHSInfo -> LHSCore' Expr -> LHS
A.LHS LHSInfo
forall a. Null a => a
empty LHSCore' Expr
core) []
                          (Expr -> Maybe Expr -> RHS
A.RHS Expr
arg Maybe Expr
forall a. Maybe a
Nothing)
                          WhereDeclarations
A.noWhereDecls Bool
False

    i <- currentOrFreshMutualBlock

    -- If we are in irrelevant position, add definition irrelevantly.
    -- If we are in erased position, add definition as erased.
    -- TODO: is this sufficient?
    addConstant c' =<< do
      let ai = Modality -> ArgInfo -> ArgInfo
forall a. LensModality a => Modality -> a -> a
setModality Modality
mod ArgInfo
defaultArgInfo
      lang <- getLanguage
      fun  <- emptyFunction
      useTerPragma $
        (defaultDefn ai c' forcedType lang fun)
        { defMutual = i }

    checkFunDef info c' [clause]

    reportSDoc "tc.term.expr.coind" 15 $ do
      def <- theDef <$> getConstInfo c'
      vcat $
        [ "The coinductive wrapper"
        , nest 2 $ prettyTCM mod <> (prettyTCM c' <+> ":")
        , nest 4 $ prettyTCM t
        , nest 2 $ prettyA clause
        ]
    return c'

  -- The application of the fresh function to the relevant
  -- arguments.
  e' <- Def wrapper . map Apply <$> getContextArgs

  reportSDoc "tc.term.expr.coind" 15 $ vcat $
      [ "The coinductive constructor application"
      , nest 2 $ prettyTCM e
      , "was translated into the application"
      , nest 2 $ prettyTCM e'
      ]

  blockTerm t $ e' <$ workOnTypes (leqType forcedType t)

-----------------------------------------------------------------------------
-- * Cubical
-----------------------------------------------------------------------------

-- | "pathAbs (PathView s _ l a x y) t" builds "(\ t) : pv"
--   Preconditions: PathView is PathType, and t[i0] = x, t[i1] = y
pathAbs :: PathView -> Abs Term -> TCM Term
pathAbs :: PathView -> Abs Term -> TCM Term
pathAbs (OType Type
_) Abs Term
t = TCM Term
forall a. HasCallStack => a
__IMPOSSIBLE__
pathAbs (PathType Sort
s QName
path Arg Term
l Arg Term
a Arg Term
x Arg Term
y) Abs Term
t = do
  Term -> TCM Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> TCM Term) -> Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultArgInfo Abs Term
t

-- | @primComp : ∀ {ℓ} (A : (i : I) → Set (ℓ i)) (φ : I) (u : ∀ i → Partial φ (A i)) (a : A i0) → A i1@
--
--   Check:  @u i0 = (λ _ → a) : Partial φ (A i0)@.
--
checkPrimComp :: QName -> MaybeRanges -> Args -> Type -> TCM Args
checkPrimComp :: QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkPrimComp QName
c MaybeRanges
rs [Arg Term]
vs Type
_ = do
  case [Arg Term]
vs of
    -- WAS: [l, a, phi, u, a0] -> do
    Arg Term
l : Arg Term
a : Arg Term
phi : Arg Term
u : Arg Term
a0 : [Arg Term]
rest -> do
      iz <- ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo (Term -> Arg Term) -> TCM Term -> TCMT IO (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntervalView -> TCM Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
IZero
      let lz = Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
l Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Arg Term
iz]
          az = Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a Term -> [Arg Term] -> Term
forall t. Apply t => t -> [Arg Term] -> t
`apply` [Arg Term
iz]
      ty <- el's (pure (unArg l `apply` [iz])) $ primPartial <#> pure (unArg l `apply` [iz]) <@> pure (unArg phi) <@> pure (unArg a `apply` [iz])
      bAz <- el' (pure $ lz) (pure $ az)
      a0 <- blockArg bAz (rs !!! 4) a0 $ do
        equalTerm ty -- (El (getSort t1) (apply (unArg a) [iz]))
          (Lam defaultArgInfo $ NoAbs "_" $ unArg a0)
          (apply (unArg u) [iz])
      return $ l : a : phi : u : a0 : rest
    [Arg Term]
_ -> TypeError -> TCMT IO [Arg Term]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO [Arg Term])
-> TypeError -> TCMT IO [Arg Term]
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
CubicalPrimitiveNotFullyApplied QName
c

-- | @primHComp : ∀ {ℓ} {A : Set ℓ} {φ : I} (u : ∀ i → Partial φ A) (a : A) → A@
--
--   Check:  @u i0 = (λ _ → a) : Partial φ A@.
--
checkPrimHComp :: QName -> MaybeRanges -> Args -> Type -> TCM Args
checkPrimHComp :: QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkPrimHComp QName
c MaybeRanges
rs [Arg Term]
vs Type
_ = do
  case [Arg Term]
vs of
    -- WAS: [l, a, phi, u, a0] -> do
    Arg Term
l : Arg Term
a : Arg Term
phi : Arg Term
u : Arg Term
a0 : [Arg Term]
rest -> do
      -- iz = i0
      iz <- ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo (Term -> Arg Term) -> TCM Term -> TCMT IO (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntervalView -> TCM Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
IZero
      -- ty = Partial φ A
      ty <- el's (pure (unArg l)) $ primPartial <#> pure (unArg l) <@> pure (unArg phi) <@> pure (unArg a)
      -- (λ _ → a) = u i0 : ty
      bA <- el' (pure $ unArg l) (pure $ unArg a)
      a0 <- blockArg bA (rs !!! 4) a0 $ do
        equalTerm ty -- (El (getSort t1) (apply (unArg a) [iz]))
            (Lam defaultArgInfo $ NoAbs "_" $ unArg a0)
            (apply (unArg u) [iz])
      return $ l : a : phi : u : a0 : rest
    [Arg Term]
_ -> TypeError -> TCMT IO [Arg Term]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO [Arg Term])
-> TypeError -> TCMT IO [Arg Term]
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
CubicalPrimitiveNotFullyApplied QName
c

-- | @transp : ∀{ℓ} (A : (i : I) → Set (ℓ i)) (φ : I) (a0 : A i0) → A i1@
--
--   Check:  If φ, then @A i = A i0 : Set (ℓ i)@ must hold for all @i : I@.
--
checkPrimTrans :: QName -> MaybeRanges -> Args -> Type -> TCM Args
checkPrimTrans :: QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkPrimTrans QName
c MaybeRanges
rs [Arg Term]
vs Type
_ = do
  case [Arg Term]
vs of
    -- Andreas, 2019-03-02, issue #3601, why exactly 4 arguments?
    -- Only 3 are needed to check the side condition.
    -- WAS:
    -- [l, a, phi, a0] -> do
    Arg Term
l : Arg Term
a : Arg Term
phi : [Arg Term]
rest -> do
      iz <- ArgInfo -> Term -> Arg Term
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo (Term -> Arg Term) -> TCM Term -> TCMT IO (Arg Term)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> IntervalView -> TCM Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview IntervalView
IZero
      -- ty = (i : I) -> Set (l i)
      ty <- runNamesT [] $ do
        l <- open $ unArg l
        nPi' "i" primIntervalType $ \ NamesT (TCMT IO) Term
i -> (Sort -> Type
sort (Sort -> Type) -> (Term -> Sort) -> Term -> Type
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Sort
tmSort (Term -> Type) -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (NamesT (TCMT IO) Term
l NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i))
      a <- blockArg ty (rs !!! 1) a $ do
        equalTermOnFace (unArg phi) ty
          (unArg a)
          (Lam defaultArgInfo $ NoAbs "_" $ apply (unArg a) [iz])
      return $ l : a : phi : rest
    [Arg Term]
_ -> TypeError -> TCMT IO [Arg Term]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO [Arg Term])
-> TypeError -> TCMT IO [Arg Term]
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
CubicalPrimitiveNotFullyApplied QName
c

blockArg :: HasRange r => Type -> r -> Arg Term -> TCM () -> TCM (Arg Term)
blockArg :: forall r.
HasRange r =>
Type -> r -> Arg Term -> TCMT IO () -> TCMT IO (Arg Term)
blockArg Type
t r
r Arg Term
a TCMT IO ()
m =
  Range -> TCMT IO (Arg Term) -> TCMT IO (Arg Term)
forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange (r -> Range
forall a. HasRange a => a -> Range
getRange (r -> Range) -> r -> Range
forall a b. (a -> b) -> a -> b
$ r
r) (TCMT IO (Arg Term) -> TCMT IO (Arg Term))
-> TCMT IO (Arg Term) -> TCMT IO (Arg Term)
forall a b. (a -> b) -> a -> b
$ (Term -> Arg Term) -> TCM Term -> TCMT IO (Arg Term)
forall a b. (a -> b) -> TCMT IO a -> TCMT IO b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Arg Term
a Arg Term -> Term -> Arg Term
forall (f :: * -> *) a b. Functor f => f a -> b -> f b
$>) (TCM Term -> TCMT IO (Arg Term)) -> TCM Term -> TCMT IO (Arg Term)
forall a b. (a -> b) -> a -> b
$ Type -> TCM Term -> TCM Term
forall (m :: * -> *).
(MonadMetaSolver m, MonadConstraint m, MonadFresh Nat m,
 MonadFresh ProblemId m) =>
Type -> m Term -> m Term
blockTerm Type
t (TCM Term -> TCM Term) -> TCM Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ TCMT IO ()
m TCMT IO () -> TCM Term -> TCM Term
forall a b. TCMT IO a -> TCMT IO b -> TCMT IO b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Term -> TCM Term
forall a. a -> TCMT IO a
forall (m :: * -> *) a. Monad m => a -> m a
return (Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a)

checkConId :: QName -> MaybeRanges -> Args -> Type -> TCM Args
checkConId :: QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkConId QName
c MaybeRanges
rs [Arg Term]
vs Type
t1 = do
  case [Arg Term]
vs of
   args :: [Arg Term]
args@[Arg Term
_, Arg Term
_, Arg Term
_, Arg Term
_, Arg Term
phi, Arg Term
p] -> do
      iv@(PathType s _ l a x y) <- Type -> TCMT IO PathView
forall (m :: * -> *). HasBuiltins m => Type -> m PathView
idViewAsPath Type
t1
      let ty = PathView -> Type
pathUnview PathView
iv
      -- the following duplicates reduction of phi
      const_x <- blockTerm ty $ do
          equalTermOnFace (unArg phi) (El s (unArg a)) (unArg x) (unArg y)
          pathAbs iv (NoAbs (stringToArgName "_") (unArg x))
      p <- blockArg ty (rs !!! 5) p $ do
        equalTermOnFace (unArg phi) ty (unArg p) const_x   -- G, phi |- p = \ i . x
      return $ initWithDefault __IMPOSSIBLE__ args ++ [p]
      -- phi <- reduce phi
      -- forallFaceMaps (unArg phi) $ \ alpha -> do
      --   iv@(PathType s _ l a x y) <- idViewAsPath (applySubst alpha t1)
      --   let ty = pathUnview iv
      --   equalTerm (El s (unArg a)) (unArg x) (unArg y) -- precondition for cx being well-typed at ty
      --   cx <- pathAbs iv (NoAbs (stringToArgName "_") (applySubst alpha (unArg x)))
      --   equalTerm ty (applySubst alpha (unArg p)) cx   -- G, phi |- p = \ i . x
   [Arg Term]
_ -> TypeError -> TCMT IO [Arg Term]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO [Arg Term])
-> TypeError -> TCMT IO [Arg Term]
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
CubicalPrimitiveNotFullyApplied QName
c


-- The following comment contains silly ' escapes to calm CPP about ∨ (\vee).
-- May not be haddock-parseable.

-- ' @primPOr : ∀ {ℓ} (φ₁ φ₂ : I) {A : Partial (φ₁ ∨ φ₂) (Set ℓ)}
-- '         → (u : PartialP φ₁ (λ (o : IsOne φ₁) → A (IsOne1 φ₁ φ₂ o)))
-- '         → (v : PartialP φ₂ (λ (o : IsOne φ₂) → A (IsOne2 φ₁ φ₂ o)))
-- '         → PartialP (φ₁ ∨ φ₂) A@
-- '
-- ' Checks: @u = v : PartialP (φ₁ ∨ φ₂) A@ whenever @IsOne (φ₁ ∧ φ₂)@.
checkPOr :: QName -> MaybeRanges -> Args -> Type -> TCM Args
checkPOr :: QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
checkPOr QName
c MaybeRanges
rs [Arg Term]
vs Type
_ = do
  case [Arg Term]
vs of
   Arg Term
l : Arg Term
phi1 : Arg Term
phi2 : Arg Term
a : Arg Term
u : Arg Term
v : [Arg Term]
rest -> do
      phi <- IntervalView -> TCM Term
forall (m :: * -> *). HasBuiltins m => IntervalView -> m Term
intervalUnview (Arg Term -> Arg Term -> IntervalView
IMin Arg Term
phi1 Arg Term
phi2)
      reportSDoc "tc.term.por" 10 $ text (show phi)
      t1 <- runNamesT [] $ do
             l <- open . unArg $ l
             a <- open . unArg $ a
             psi <- open =<< intervalUnview (IMax phi1 phi2)
             pPi' "o" psi $ \ NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
l (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o)
      tv <- runNamesT [] $ do
             l    <- open . unArg $ l
             a    <- open . unArg $ a
             phi1 <- open . unArg $ phi1
             phi2 <- open . unArg $ phi2
             pPi' "o" phi2 $ \ NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
l (NamesT (TCMT IO) Term
a NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> (TCM Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIsOne2 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi1 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
phi2 NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
o))
      v <- blockArg tv (rs !!! 5) v $ do
        -- ' φ₁ ∧ φ₂  ⊢ u , v : PartialP (φ₁ ∨ φ₂) \ o → a o
        equalTermOnFace phi t1 (unArg u) (unArg v)
      return $ l : phi1 : phi2 : a : u : v : rest
   [Arg Term]
_ -> TypeError -> TCMT IO [Arg Term]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO [Arg Term])
-> TypeError -> TCMT IO [Arg Term]
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
CubicalPrimitiveNotFullyApplied QName
c

-- | @prim^glue : ∀ {ℓ ℓ'} {A : Set ℓ} {φ : I}
--              → {T : Partial φ (Set ℓ')} → {e : PartialP φ (λ o → T o ≃ A)}
--              → (t : PartialP φ T) → (a : A) → primGlue A T e@
--
--   Check   @φ ⊢ a = e 1=1 (t 1=1)@  or actually the equivalent:  @(\ _ → a) = (\ o -> e o (t o)) : PartialP φ A@
check_glue :: QName -> MaybeRanges -> Args -> Type -> TCM Args
check_glue :: QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
check_glue QName
c MaybeRanges
rs [Arg Term]
vs Type
_ = do
  case [Arg Term]
vs of
   -- WAS: [la, lb, bA, phi, bT, e, t, a] -> do
   Arg Term
la : Arg Term
lb : Arg Term
bA : Arg Term
phi : Arg Term
bT : Arg Term
e : Arg Term
t : Arg Term
a : [Arg Term]
rest -> do
      v <- [[Char]] -> NamesT (TCMT IO) Term -> TCM Term
forall (m :: * -> *) a. [[Char]] -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Term -> TCM Term)
-> NamesT (TCMT IO) Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ do
            lb  <- Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall a b. (a -> b) -> a -> b
$ Arg Term
lb
            la  <- open . unArg $ la
            bA  <- open . unArg $ bA
            phi <- open . unArg $ phi
            bT  <- open . unArg $ bT
            e   <- open . unArg $ e
            t   <- open . unArg $ t
            let f NamesT (TCMT IO) Term
o = TCM Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primEquivFun NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
lb NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
la NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> (NamesT (TCMT IO) Term
bT NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o) NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> NamesT (TCMT IO) Term
bA NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
e NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o)
            glam defaultIrrelevantArgInfo "o" $ \ NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
f NamesT (TCMT IO) Term
o NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
t NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o)
      ty <- runNamesT [] $ do
            lb  <- open . unArg $ lb
            phi <- open . unArg $ phi
            bA  <- open . unArg $ bA
            el's lb $ cl primPartialP <#> lb <@> phi <@> glam defaultIrrelevantArgInfo "o" (\ NamesT (TCMT IO) Term
_ -> NamesT (TCMT IO) Term
bA)
      let a' = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultIrrelevantArgInfo ([Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
NoAbs [Char]
"o" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a)
      ta <- el' (pure $ unArg la) (pure $ unArg bA)
      a <- blockArg ta (rs !!! 7) a $ equalTerm ty a' v
      return $ la : lb : bA : phi : bT : e : t : a : rest
   [Arg Term]
_ -> TypeError -> TCMT IO [Arg Term]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO [Arg Term])
-> TypeError -> TCMT IO [Arg Term]
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
CubicalPrimitiveNotFullyApplied QName
c


-- | @prim^glueU : ∀ {ℓ} {φ : I}
--              → {T : I → Partial φ (Set ℓ)} → {A : Set ℓ [ φ ↦ T i0 ]}
--              → (t : PartialP φ (T i1)) → (a : outS A) → hcomp T (outS A)@
--
--   Check   @φ ⊢ a = transp (\ i -> T 1=1 (~ i)) i0 (t 1=1)@  or actually the equivalent:
--           @(\ _ → a) = (\o -> transp (\ i -> T o (~ i)) i0 (t o)) : PartialP φ (T i0)@
check_glueU :: QName -> MaybeRanges -> Args -> Type -> TCM Args
check_glueU :: QName -> MaybeRanges -> [Arg Term] -> Type -> TCMT IO [Arg Term]
check_glueU QName
c MaybeRanges
rs [Arg Term]
vs Type
_ = do
  case [Arg Term]
vs of
   -- WAS: [la, lb, bA, phi, bT, e, t, a] -> do
   Arg Term
la : Arg Term
phi : Arg Term
bT : Arg Term
bA : Arg Term
t : Arg Term
a : [Arg Term]
rest -> do
      v <- [[Char]] -> NamesT (TCMT IO) Term -> TCM Term
forall (m :: * -> *) a. [[Char]] -> NamesT m a -> m a
runNamesT [] (NamesT (TCMT IO) Term -> TCM Term)
-> NamesT (TCMT IO) Term -> TCM Term
forall a b. (a -> b) -> a -> b
$ do
            la  <- Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall (m :: * -> *) a.
(Monad m, Subst a) =>
a -> NamesT m (NamesT m a)
open (Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> (Arg Term -> Term)
-> Arg Term
-> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Arg Term -> Term
forall e. Arg e -> e
unArg (Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term))
-> Arg Term -> NamesT (TCMT IO) (NamesT (TCMT IO) Term)
forall a b. (a -> b) -> a -> b
$ Arg Term
la
            phi <- open . unArg $ phi
            bT  <- open . unArg $ bT
            bA  <- open . unArg $ bA
            t   <- open . unArg $ t
            let f NamesT (TCMT IO) Term
o = TCM Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primTrans NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<#> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall a b. a -> b -> a
const NamesT (TCMT IO) Term
la) NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> [Char]
-> (NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term)
-> NamesT (TCMT IO) Term
forall (m :: * -> *).
Monad m =>
[Char] -> (NamesT m Term -> NamesT m Term) -> NamesT m Term
lam [Char]
"i" (\ NamesT (TCMT IO) Term
i -> NamesT (TCMT IO) Term
bT NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (TCM Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> NamesT (TCMT IO) Term
i) NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o) NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCM Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero
            glam defaultIrrelevantArgInfo "o" $ \ NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
f NamesT (TCMT IO) Term
o NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> (NamesT (TCMT IO) Term
t NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o)
      ty <- runNamesT [] $ do
            la  <- open . unArg $ la
            phi <- open . unArg $ phi
            bT  <- open . unArg $ bT
            pPi' "o" phi $ \ NamesT (TCMT IO) Term
o -> NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Type
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Type
el' NamesT (TCMT IO) Term
la (NamesT (TCMT IO) Term
bT NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCM Term -> NamesT (TCMT IO) Term
forall (m :: * -> *) a. Monad m => m a -> NamesT m a
cl TCM Term
forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIZero NamesT (TCMT IO) Term
-> NamesT (TCMT IO) Term -> NamesT (TCMT IO) Term
forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<..> NamesT (TCMT IO) Term
o)
      let a' = ArgInfo -> Abs Term -> Term
Lam ArgInfo
defaultIrrelevantArgInfo ([Char] -> Term -> Abs Term
forall a. [Char] -> a -> Abs a
NoAbs [Char]
"o" (Term -> Abs Term) -> Term -> Abs Term
forall a b. (a -> b) -> a -> b
$ Arg Term -> Term
forall e. Arg e -> e
unArg Arg Term
a)
      ta <- runNamesT [] $ do
            la  <- open . unArg $ la
            phi <- open . unArg $ phi
            bT  <- open . unArg $ bT
            bA  <- open . unArg $ bA
            el' la (cl primSubOut <#> (cl primLevelSuc <@> la) <#> (Sort . tmSort <$> la) <#> phi <#> (bT <@> cl primIZero) <@> bA)
      a <- blockArg ta (rs !!! 5) a $ equalTerm ty a' v
      return $ la : phi : bT : bA : t : a : rest
   [Arg Term]
_ -> TypeError -> TCMT IO [Arg Term]
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError (TypeError -> TCMT IO [Arg Term])
-> TypeError -> TCMT IO [Arg Term]
forall a b. (a -> b) -> a -> b
$ QName -> TypeError
CubicalPrimitiveNotFullyApplied QName
c