{-# LANGUAGE NondecreasingIndentation #-}
module Agda.TypeChecking.Rules.LHS
( checkLeftHandSide
, LHSResult(..)
, bindAsPatterns
, IsFlexiblePattern(..)
, DataOrRecord
, checkSortOfSplitVar
) where
import Prelude hiding ( null )
import Data.Function (on)
import Data.Maybe
import Control.Arrow (left)
import Control.Monad
import Control.Monad.Except
import Control.Monad.Reader
import Control.Monad.Writer ( MonadWriter(..), runWriterT )
import Control.Monad.Trans.Maybe
import Data.IntSet (IntSet)
import qualified Data.IntSet as IntSet
import Data.List (findIndex)
import qualified Data.List as List
import Data.Semigroup ( Semigroup )
import qualified Data.Semigroup as Semigroup
import Data.Map (Map)
import qualified Data.Map as Map
import Agda.Interaction.Highlighting.Generate
( storeDisambiguatedConstructor, storeDisambiguatedProjection, disambiguateRecordFields)
import Agda.Interaction.Options
import Agda.Interaction.Options.Lenses
import Agda.Syntax.Internal as I hiding (DataOrRecord)
import Agda.Syntax.Internal.Pattern
import qualified Agda.Syntax.Abstract as A
import Agda.Syntax.Abstract.Views (asView, deepUnscope)
import Agda.Syntax.Concrete (FieldAssignment'(..),LensInScope(..))
import Agda.Syntax.Common as Common
import Agda.Syntax.Info as A
import Agda.Syntax.Literal
import Agda.Syntax.Position
import Agda.TypeChecking.Monad
import qualified Agda.TypeChecking.Monad.Benchmark as Bench
import Agda.TypeChecking.Conversion
import Agda.TypeChecking.Constraints
import Agda.TypeChecking.CheckInternal (checkInternal)
import Agda.TypeChecking.Datatypes hiding (isDataOrRecordType)
import Agda.TypeChecking.Errors (dropTopLevelModule)
import Agda.TypeChecking.Irrelevance
import {-# SOURCE #-} Agda.TypeChecking.Empty (ensureEmptyType)
import Agda.TypeChecking.Patterns.Abstract
import Agda.TypeChecking.Pretty
import Agda.TypeChecking.Records hiding (getRecordConstructor)
import Agda.TypeChecking.Reduce
import Agda.TypeChecking.Substitute
import Agda.TypeChecking.Telescope
import Agda.TypeChecking.Telescope.Path
import Agda.TypeChecking.Primitive hiding (Nat)
import Agda.TypeChecking.Warnings (warning)
import {-# SOURCE #-} Agda.TypeChecking.Rules.Term (checkExpr, isType_)
import Agda.TypeChecking.Rules.LHS.Problem
import Agda.TypeChecking.Rules.LHS.ProblemRest
import Agda.TypeChecking.Rules.LHS.Unify
import Agda.TypeChecking.Rules.LHS.Implicit
import Agda.Utils.CallStack ( HasCallStack, withCallerCallStack )
import Agda.Utils.Function
import Agda.Utils.Functor
import Agda.Utils.Lens
import Agda.Utils.List
import Agda.Utils.List1 (List1, pattern (:|))
import 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.Singleton
import Agda.Utils.Size
import Agda.Utils.Tuple
import Agda.Utils.Impossible
import Agda.TypeChecking.Free (freeIn)
class IsFlexiblePattern a where
maybeFlexiblePattern :: (HasConstInfo m, MonadDebug m) => a -> MaybeT m FlexibleVarKind
isFlexiblePattern :: (HasConstInfo m, MonadDebug m) => a -> m Bool
isFlexiblePattern a
p =
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Bool
False FlexibleVarKind -> Bool
notOtherFlex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT (forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern a
p)
where
notOtherFlex :: FlexibleVarKind -> Bool
notOtherFlex = \case
RecordFlex [FlexibleVarKind]
fls -> forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all FlexibleVarKind -> Bool
notOtherFlex [FlexibleVarKind]
fls
FlexibleVarKind
ImplicitFlex -> Bool
True
FlexibleVarKind
DotFlex -> Bool
True
FlexibleVarKind
OtherFlex -> Bool
False
instance IsFlexiblePattern A.Pattern where
maybeFlexiblePattern :: forall (m :: * -> *).
(HasConstInfo m, MonadDebug m) =>
Pattern -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern
p = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.flex" Int
30 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"maybeFlexiblePattern" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
p
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.flex" Int
60 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"maybeFlexiblePattern (raw) " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. ExprLike a => a -> a
deepUnscope) Pattern
p
case Pattern
p of
A.DotP{} -> forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
DotFlex
A.VarP{} -> forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
ImplicitFlex
A.WildP{} -> forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
ImplicitFlex
A.AsP PatInfo
_ BindName
_ Pattern
p -> forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern
p
A.ConP ConPatInfo
_ AmbiguousQName
cs [NamedArg Pattern]
qs | Just QName
c <- AmbiguousQName -> Maybe QName
getUnambiguous AmbiguousQName
cs ->
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall a. Maybe a -> Bool
isNothing forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Maybe (QName, Defn))
isRecordConstructor QName
c) (forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
OtherFlex)
(forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [NamedArg Pattern]
qs)
A.LitP{} -> forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
OtherFlex
A.AnnP PatInfo
_ Expr
_ Pattern
p -> forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern
p
Pattern
_ -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
instance IsFlexiblePattern (I.Pattern' a) where
maybeFlexiblePattern :: forall (m :: * -> *).
(HasConstInfo m, MonadDebug m) =>
Pattern' a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern Pattern' a
p =
case Pattern' a
p of
I.DotP{} -> forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
DotFlex
I.ConP ConHead
_ ConPatternInfo
i [NamedArg (Pattern' a)]
ps
| ConPatternInfo -> Bool
conPRecord ConPatternInfo
i , PatOrigin
PatOSystem <- PatternInfo -> PatOrigin
patOrigin (ConPatternInfo -> PatternInfo
conPInfo ConPatternInfo
i) -> forall (m :: * -> *) a. Monad m => a -> m a
return FlexibleVarKind
ImplicitFlex
| ConPatternInfo -> Bool
conPRecord ConPatternInfo
i -> forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [NamedArg (Pattern' a)]
ps
| Bool
otherwise -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
I.VarP{} -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
I.LitP{} -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
I.ProjP{} -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
I.IApplyP{} -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
I.DefP{} -> forall (m :: * -> *) a. MonadPlus m => m a
mzero
instance IsFlexiblePattern a => IsFlexiblePattern [a] where
maybeFlexiblePattern :: forall (m :: * -> *).
(HasConstInfo m, MonadDebug m) =>
[a] -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [a]
ps = [FlexibleVarKind] -> FlexibleVarKind
RecordFlex forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern [a]
ps
instance IsFlexiblePattern a => IsFlexiblePattern (Arg a) where
maybeFlexiblePattern :: forall (m :: * -> *).
(HasConstInfo m, MonadDebug m) =>
Arg a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern = forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg
instance IsFlexiblePattern a => IsFlexiblePattern (Common.Named name a) where
maybeFlexiblePattern :: forall (m :: * -> *).
(HasConstInfo m, MonadDebug m) =>
Named name a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern = forall a (m :: * -> *).
(IsFlexiblePattern a, HasConstInfo m, MonadDebug m) =>
a -> MaybeT m FlexibleVarKind
maybeFlexiblePattern forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall name a. Named name a -> a
namedThing
updateLHSState :: LHSState a -> TCM (LHSState a)
updateLHSState :: forall a. LHSState a -> TCM (LHSState a)
updateLHSState LHSState a
st = do
let tel :: Telescope
tel = LHSState a
st forall o i. o -> Lens' o i -> i
^. forall a. Lens' (LHSState a) Telescope
lhsTel
problem :: Problem a
problem = LHSState a
st forall o i. o -> Lens' o i -> i
^. forall a. Lens' (LHSState a) (Problem a)
lhsProblem
[ProblemEq]
eqs' <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel forall a b. (a -> b) -> a -> b
$ [ProblemEq] -> TCMT IO [ProblemEq]
updateProblemEqs forall a b. (a -> b) -> a -> b
$ Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) [ProblemEq]
problemEqs
Telescope
tel' <- forall (m :: * -> *).
PureTCM m =>
[ProblemEq] -> Telescope -> m Telescope
useNamesFromProblemEqs [ProblemEq]
eqs' Telescope
tel
forall (m :: * -> *) a.
(PureTCM m, MonadError TCErr m, MonadTrace m,
MonadFresh NameId m) =>
LHSState a -> m (LHSState a)
updateProblemRest forall a b. (a -> b) -> a -> b
$ forall o i. Lens' o i -> LensSet o i
set forall a. Lens' (LHSState a) Telescope
lhsTel Telescope
tel' forall a b. (a -> b) -> a -> b
$ forall o i. Lens' o i -> LensSet o i
set (forall a. Lens' (LHSState a) (Problem a)
lhsProblem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (Problem a) [ProblemEq]
problemEqs) [ProblemEq]
eqs' LHSState a
st
updateProblemEqs
:: [ProblemEq] -> TCM [ProblemEq]
updateProblemEqs :: [ProblemEq] -> TCMT IO [ProblemEq]
updateProblemEqs [ProblemEq]
eqs = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"updateProblem: equations to update"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ if forall a. Null a => a -> Bool
null [ProblemEq]
eqs then TCMT IO Doc
"(none)" else forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [ProblemEq]
eqs
]
[ProblemEq]
eqs' <- [ProblemEq] -> TCMT IO [ProblemEq]
updates [ProblemEq]
eqs
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"updateProblem: new equations"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ if forall a. Null a => a -> Bool
null [ProblemEq]
eqs' then TCMT IO Doc
"(none)" else forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [ProblemEq]
eqs'
]
forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq]
eqs'
where
updates :: [ProblemEq] -> TCM [ProblemEq]
updates :: [ProblemEq] -> TCMT IO [ProblemEq]
updates = forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat forall (m :: * -> *) b c a.
Functor m =>
(b -> c) -> (a -> m b) -> a -> m c
<.> forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse ProblemEq -> TCMT IO [ProblemEq]
update
update :: ProblemEq -> TCM [ProblemEq]
update :: ProblemEq -> TCMT IO [ProblemEq]
update eq :: ProblemEq
eq@(ProblemEq A.WildP{} Term
_ Dom Type
_) = forall (m :: * -> *) a. Monad m => a -> m a
return []
update eq :: ProblemEq
eq@(ProblemEq p :: Pattern
p@A.ProjP{} Term
_ Dom Type
_) = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
IllformedProjectionPatternAbstract Pattern
p
update eq :: ProblemEq
eq@(ProblemEq p :: Pattern
p@(A.AsP PatInfo
info BindName
x Pattern
p') Term
v Dom Type
a) =
(Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (forall e. BindName -> Pattern' e
A.VarP BindName
x) Term
v Dom Type
a forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProblemEq -> TCMT IO [ProblemEq]
update (Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq Pattern
p' Term
v Dom Type
a)
update eq :: ProblemEq
eq@(ProblemEq p :: Pattern
p@(A.AnnP PatInfo
_ Expr
_ A.WildP{}) Term
v Dom Type
a) = forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]
update eq :: ProblemEq
eq@(ProblemEq p :: Pattern
p@(A.AnnP PatInfo
info Expr
ty Pattern
p') Term
v Dom Type
a) =
(Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (forall e. PatInfo -> e -> Pattern' e -> Pattern' e
A.AnnP PatInfo
info Expr
ty (forall e. PatInfo -> Pattern' e
A.WildP PatInfo
patNoRange)) Term
v Dom Type
a forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> ProblemEq -> TCMT IO [ProblemEq]
update (Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq Pattern
p' Term
v Dom Type
a)
update eq :: ProblemEq
eq@(ProblemEq Pattern
p Term
v Dom Type
a) = forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
v forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall (m :: * -> *). HasBuiltins m => Term -> m Term
constructorForm forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Con ConHead
c ConInfo
ci Elims
es -> do
let vs :: Args
vs = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
Maybe ((QName, Type, Args), Type)
contype <- forall (m :: * -> *).
PureTCM m =>
ConHead -> Type -> m (Maybe ((QName, Type, Args), Type))
getFullyAppliedConType ConHead
c forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (forall t e. Dom' t e -> e
unDom Dom Type
a)
forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe ((QName, Type, Args), Type)
contype (forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]) forall a b. (a -> b) -> a -> b
$ \((QName
d,Type
_,Args
pars),Type
b) -> do
TelV Telescope
ctel Type
_ <- forall (m :: * -> *). PureTCM m => Type -> m (TelV Type)
telViewPath Type
b
let updMod :: Modality -> Modality
updMod = Modality -> Modality -> Modality
composeModality (forall a. LensModality a => a -> Modality
getModality Dom Type
a)
Telescope
ctel <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. LensModality a => (Modality -> Modality) -> a -> a
mapModality Modality -> Modality
updMod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope
ctel
let bs :: [Dom Type]
bs = Telescope -> [Term] -> [Dom Type]
instTel Telescope
ctel (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg Args
vs)
Pattern
p <- forall (m :: * -> *).
(MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasBuiltins m) =>
Pattern -> m Pattern
expandLitPattern Pattern
p
case Pattern
p of
A.AsP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.AnnP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.ConP ConPatInfo
cpi AmbiguousQName
ambC [NamedArg Pattern]
ps -> do
(ConHead
c',Type
_) <- AmbiguousQName -> QName -> Args -> TCM (ConHead, Type)
disambiguateConstructor AmbiguousQName
ambC QName
d Args
pars
if ConHead -> QName
conName ConHead
c forall a. Eq a => a -> a -> Bool
/= ConHead -> QName
conName ConHead
c' then forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq] else do
[NamedArg Pattern]
ps <- forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
MonadTrace m) =>
ExpandHidden
-> [NamedArg Pattern] -> Telescope -> m [NamedArg Pattern]
insertImplicitPatterns ExpandHidden
ExpandLast [NamedArg Pattern]
ps Telescope
ctel
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.imp" Int
20 forall a b. (a -> b) -> a -> b
$
TCMT IO Doc
"insertImplicitPatternsT returned" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep (forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA [NamedArg Pattern]
ps)
let checkArgs :: [NamedArg Pattern] -> Args -> Int -> Int -> TCMT IO ()
checkArgs [] [] Int
_ Int
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkArgs (NamedArg Pattern
p : [NamedArg Pattern]
ps) (Arg Term
v : Args
vs) Int
nExpected Int
nActual
| forall a. LensHiding a => a -> Hiding
getHiding NamedArg Pattern
p forall a. Eq a => a -> a -> Bool
== forall a. LensHiding a => a -> Hiding
getHiding Arg Term
v = [NamedArg Pattern] -> Args -> Int -> Int -> TCMT IO ()
checkArgs [NamedArg Pattern]
ps Args
vs (Int
nExpected forall a. Num a => a -> a -> a
+ Int
1) (Int
nActual forall a. Num a => a -> a -> a
+ Int
1)
| Bool
otherwise = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Pattern
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError TypeError
WrongHidingInLHS
checkArgs [] Args
vs Int
nExpected Int
nActual = forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$
QName -> Int -> Int -> TypeError
WrongNumberOfConstructorArguments (ConHead -> QName
conName ConHead
c) (Int
nExpected forall a. Num a => a -> a -> a
+ forall (t :: * -> *) a. Foldable t => t a -> Int
length Args
vs) Int
nActual
checkArgs (NamedArg Pattern
p : [NamedArg Pattern]
ps) [] Int
nExpected Int
nActual = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Pattern
p forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$
QName -> Int -> Int -> TypeError
WrongNumberOfConstructorArguments (ConHead -> QName
conName ConHead
c) Int
nExpected (Int
nActual forall a. Num a => a -> a -> a
+ Int
1 forall a. Num a => a -> a -> a
+ (forall (t :: * -> *) a. Foldable t => t a -> Int
length [NamedArg Pattern]
ps))
[NamedArg Pattern] -> Args -> Int -> Int -> TCMT IO ()
checkArgs [NamedArg Pattern]
ps Args
vs Int
0 Int
0
[ProblemEq] -> TCMT IO [ProblemEq]
updates forall a b. (a -> b) -> a -> b
$ forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedArg a -> a
namedArg [NamedArg Pattern]
ps) (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg Args
vs) [Dom Type]
bs
A.RecP PatInfo
pi [FieldAssignment' Pattern]
fs -> do
[Arg QName]
axs <- forall a b. (a -> b) -> [a] -> [b]
map forall t a. Dom' t a -> Arg a
argFromDom forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defn -> [Dom' Term QName]
recFields forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Defn
theDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
[Name] -> [QName] -> TCMT IO ()
disambiguateRecordFields (forall a b. (a -> b) -> [a] -> [b]
map forall a. FieldAssignment' a -> Name
_nameFieldA [FieldAssignment' Pattern]
fs) (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg [Arg QName]
axs)
let cxs :: [Arg Name]
cxs = forall a b. (a -> b) -> [a] -> [b]
map (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> Name
nameConcrete forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName)) [Arg QName]
axs
[NamedArg Pattern]
ps <- forall a.
HasRange a =>
QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFieldsFail QName
d (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> Pattern' e
A.WildP PatInfo
patNoRange) [FieldAssignment' Pattern]
fs [Arg Name]
cxs
[NamedArg Pattern]
ps <- forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
MonadTrace m) =>
ExpandHidden
-> [NamedArg Pattern] -> Telescope -> m [NamedArg Pattern]
insertImplicitPatterns ExpandHidden
ExpandLast [NamedArg Pattern]
ps Telescope
ctel
let eqs :: [ProblemEq]
eqs = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedArg a -> a
namedArg [NamedArg Pattern]
ps) (forall a b. (a -> b) -> [a] -> [b]
map forall e. Arg e -> e
unArg Args
vs) [Dom Type]
bs
[ProblemEq] -> TCMT IO [ProblemEq]
updates [ProblemEq]
eqs
Pattern
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]
Lit Literal
l | A.LitP PatInfo
_ Literal
l' <- Pattern
p , Literal
l forall a. Eq a => a -> a -> Bool
== Literal
l' -> forall (m :: * -> *) a. Monad m => a -> m a
return []
Term
_ | A.EqualP{} <- Pattern
p -> do
Term
itisone <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *).
(MonadConstraint m, MonadWarning m, MonadError TCErr m,
MonadFresh ProblemId m) =>
m () -> m Bool
tryConversion forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadConversion m =>
Type -> Term -> Term -> m ()
equalTerm (forall t e. Dom' t e -> e
unDom Dom Type
a) Term
v Term
itisone) (forall (m :: * -> *) a. Monad m => a -> m a
return []) (forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq])
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [ProblemEq
eq]
instTel :: Telescope -> [Term] -> [Dom Type]
instTel :: Telescope -> [Term] -> [Dom Type]
instTel Telescope
EmptyTel [Term]
_ = []
instTel (ExtendTel Dom Type
arg Abs Telescope
tel) (Term
u : [Term]
us) = Dom Type
arg forall a. a -> [a] -> [a]
: Telescope -> [Term] -> [Dom Type]
instTel (forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs Telescope
tel Term
u) [Term]
us
instTel ExtendTel{} [] = forall a. HasCallStack => a
__IMPOSSIBLE__
isSolvedProblem :: Problem a -> Bool
isSolvedProblem :: forall a. Problem a -> Bool
isSolvedProblem Problem a
problem = forall a. Null a => a -> Bool
null (Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) [NamedArg Pattern]
problemRestPats) Bool -> Bool -> Bool
&&
forall a. Problem a -> Bool
problemAllVariables Problem a
problem
problemAllVariables :: Problem a -> Bool
problemAllVariables :: forall a. Problem a -> Bool
problemAllVariables Problem a
problem =
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall {e}. Pattern' e -> Bool
isSolved forall a b. (a -> b) -> a -> b
$
forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedArg a -> a
namedArg (Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) [NamedArg Pattern]
problemRestPats) forall a. [a] -> [a] -> [a]
++ forall a. Problem a -> [Pattern]
problemInPats Problem a
problem
where
isSolved :: Pattern' e -> Bool
isSolved A.ConP{} = Bool
False
isSolved A.LitP{} = Bool
False
isSolved A.RecP{} = Bool
False
isSolved A.VarP{} = Bool
True
isSolved A.WildP{} = Bool
True
isSolved A.DotP{} = Bool
True
isSolved A.AbsurdP{} = Bool
True
isSolved (A.AsP PatInfo
_ BindName
_ Pattern' e
p) = Pattern' e -> Bool
isSolved Pattern' e
p
isSolved (A.AnnP PatInfo
_ e
_ Pattern' e
p) = Pattern' e -> Bool
isSolved Pattern' e
p
isSolved A.ProjP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
isSolved A.DefP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
isSolved A.PatternSynP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
isSolved A.EqualP{} = Bool
False
isSolved A.WithP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
noShadowingOfConstructors :: ProblemEq -> TCM ()
noShadowingOfConstructors :: ProblemEq -> TCMT IO ()
noShadowingOfConstructors problem :: ProblemEq
problem@(ProblemEq Pattern
p Term
_ (Dom{domInfo :: forall t e. Dom' t e -> ArgInfo
domInfo = ArgInfo
info, unDom :: forall t e. Dom' t e -> e
unDom = El Sort' Term
_ Term
a})) =
case Pattern
p of
A.WildP {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
A.AbsurdP {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
A.DotP {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
A.EqualP {} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
A.AsP PatInfo
_ BindName
_ Pattern
p -> ProblemEq -> TCMT IO ()
noShadowingOfConstructors forall a b. (a -> b) -> a -> b
$ ProblemEq
problem { problemInPat :: Pattern
problemInPat = Pattern
p }
A.AnnP PatInfo
_ Expr
_ Pattern
p -> ProblemEq -> TCMT IO ()
noShadowingOfConstructors forall a b. (a -> b) -> a -> b
$ ProblemEq
problem { problemInPat :: Pattern
problemInPat = Pattern
p }
A.ConP {} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.RecP {} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.ProjP {} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.DefP {} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.LitP {} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.PatternSynP {} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.WithP {} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.VarP A.BindName{unBind :: BindName -> Name
unBind = Name
x} -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. LensOrigin a => a -> Origin
getOrigin ArgInfo
info forall a. Eq a => a -> a -> Bool
== Origin
UserWritten) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.shadow" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"checking whether pattern variable " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow Name
x forall a. [a] -> [a] -> [a]
++ [Char]
" shadows a constructor"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"type of variable =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
a
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"position of variable =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) (forall a. HasRange a => a -> Range
getRange Name
x)
]
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.shadow" Int
70 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"a =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
a
Maybe QName
mc <- forall (m :: * -> *) a. MaybeT m a -> m (Maybe a)
runMaybeT do
Term
a <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
a
(QName
d, DataOrRecord
dr) <- forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ Term -> TCM (Maybe (QName, DataOrRecord))
isDataOrRecord Term
a
forall (f :: * -> *). Alternative f => Bool -> f ()
guard forall a b. (a -> b) -> a -> b
$ forall a. PatternMatchingAllowed a => a -> Bool
patternMatchingAllowed DataOrRecord
dr
[QName]
cs <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ QName -> TCM [QName]
getConstructors QName
d
forall (m :: * -> *) a. m (Maybe a) -> MaybeT m a
MaybeT forall a b. (a -> b) -> a -> b
$ forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((Name -> Name
A.nameConcrete Name
x forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Name
A.nameConcrete forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
A.qnameName) [QName]
cs
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe QName
mc \ QName
c -> forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange Name
x forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *).
(HasCallStack, MonadWarning m) =>
Warning -> m ()
warning forall a b. (a -> b) -> a -> b
$ Name -> QName -> Warning
PatternShadowsConstructor (Name -> Name
nameConcrete Name
x) QName
c
checkDotPattern :: DotPattern -> TCM ()
checkDotPattern :: DotPattern -> TCMT IO ()
checkDotPattern (Dot Expr
e Term
v (Dom{domInfo :: forall t e. Dom' t e -> ArgInfo
domInfo = ArgInfo
info, unDom :: forall t e. Dom' t e -> e
unDom = Type
a})) =
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Expr -> Term -> Call
CheckDotPattern Expr
e Term
v) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.dot" Int
15 forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"checking dot pattern"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Expr
e
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"=" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
v
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
":" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
a
]
forall (tcm :: * -> *) m a.
(MonadTCEnv tcm, LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext ArgInfo
info forall a b. (a -> b) -> a -> b
$ do
Term
u <- Expr -> Type -> TCMT IO Term
checkExpr Expr
e Type
a
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.dot" Int
50 forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"equalTerm"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type
a
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
u
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
v
]
forall (m :: * -> *).
MonadConversion m =>
Type -> Term -> Term -> m ()
equalTerm Type
a Term
u Term
v
checkAbsurdPattern :: AbsurdPattern -> TCM ()
checkAbsurdPattern :: AbsurdPattern -> TCMT IO ()
checkAbsurdPattern (Absurd Range
r Type
a) = Range -> Type -> TCMT IO ()
ensureEmptyType Range
r Type
a
checkAnnotationPattern :: AnnotationPattern -> TCM ()
checkAnnotationPattern :: AnnotationPattern -> TCMT IO ()
checkAnnotationPattern (Ann Expr
t Type
a) = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.ann" Int
15 forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"checking type annotation in pattern"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Expr
t
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"=" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
a
]
Type
b <- Expr -> TCM Type
isType_ Expr
t
forall (m :: * -> *). MonadConversion m => Type -> Type -> m ()
equalType Type
a Type
b
transferOrigins :: [NamedArg A.Pattern]
-> [NamedArg DeBruijnPattern]
-> TCM [NamedArg DeBruijnPattern]
transferOrigins :: [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transferOrigins [NamedArg Pattern]
ps [NamedArg DeBruijnPattern]
qs = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.origin" Int
40 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"transferOrigins"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"ps = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA [NamedArg Pattern]
ps
, TCMT IO Doc
"qs = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
qs
]
]
[NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [NamedArg Pattern]
ps [NamedArg DeBruijnPattern]
qs
where
transfers :: [NamedArg A.Pattern]
-> [NamedArg DeBruijnPattern]
-> TCM [NamedArg DeBruijnPattern]
transfers :: [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [] [NamedArg DeBruijnPattern]
qs
| forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all forall a. LensHiding a => a -> Bool
notVisible [NamedArg DeBruijnPattern]
qs = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted) [NamedArg DeBruijnPattern]
qs
| Bool
otherwise = forall a. HasCallStack => a
__IMPOSSIBLE__
transfers (NamedArg Pattern
p : [NamedArg Pattern]
ps) [] = forall a. HasCallStack => a
__IMPOSSIBLE__
transfers (NamedArg Pattern
p : [NamedArg Pattern]
ps) (NamedArg DeBruijnPattern
q : [NamedArg DeBruijnPattern]
qs)
| NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
matchingArgs NamedArg Pattern
p NamedArg DeBruijnPattern
q = do
NamedArg DeBruijnPattern
q' <- forall a.
LensNamed a =>
(Maybe (NameOf a) -> Maybe (NameOf a)) -> a -> a
mapNameOf (forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. a -> a
id (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. a -> Maybe a
Just) forall a b. (a -> b) -> a -> b
$ forall a. LensNamed a => a -> Maybe (NameOf a)
getNameOf NamedArg Pattern
p)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. LensOrigin a => Origin -> a -> a
setOrigin (forall a. LensOrigin a => a -> Origin
getOrigin NamedArg Pattern
p)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse forall a b. (a -> b) -> a -> b
$ Pattern -> DeBruijnPattern -> TCM DeBruijnPattern
transfer forall a b. (a -> b) -> a -> b
$ forall a. NamedArg a -> a
namedArg NamedArg Pattern
p) NamedArg DeBruijnPattern
q
(NamedArg DeBruijnPattern
q' forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [NamedArg Pattern]
ps [NamedArg DeBruijnPattern]
qs
| Bool
otherwise = (forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted NamedArg DeBruijnPattern
q forall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers (NamedArg Pattern
p forall a. a -> [a] -> [a]
: [NamedArg Pattern]
ps) [NamedArg DeBruijnPattern]
qs
transfer :: A.Pattern -> DeBruijnPattern -> TCM DeBruijnPattern
transfer :: Pattern -> DeBruijnPattern -> TCM DeBruijnPattern
transfer Pattern
p DeBruijnPattern
q = case (Pattern -> ([Name], [Expr], Pattern)
asView Pattern
p , DeBruijnPattern
q) of
(([Name]
asB , [Expr]
anns , A.ConP ConPatInfo
pi AmbiguousQName
_ [NamedArg Pattern]
ps) , ConP ConHead
c (ConPatternInfo PatternInfo
i Bool
r Bool
ft Maybe (Arg Type)
mb Bool
l) [NamedArg DeBruijnPattern]
qs) -> do
let cpi :: ConPatternInfo
cpi = PatternInfo
-> Bool -> Bool -> Maybe (Arg Type) -> Bool -> ConPatternInfo
ConPatternInfo (PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatOCon [Name]
asB) Bool
r Bool
ft Maybe (Arg Type)
mb Bool
l
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c ConPatternInfo
cpi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [NamedArg Pattern]
ps [NamedArg DeBruijnPattern]
qs
(([Name]
asB , [Expr]
anns , A.RecP PatInfo
pi [FieldAssignment' Pattern]
fs) , ConP ConHead
c (ConPatternInfo PatternInfo
i Bool
r Bool
ft Maybe (Arg Type)
mb Bool
l) [NamedArg DeBruijnPattern]
qs) -> do
let Def QName
d Elims
_ = forall t a. Type'' t a -> a
unEl forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe (Arg Type)
mb
axs :: [Arg Name]
axs = forall a b. (a -> b) -> [a] -> [b]
map (Name -> Name
nameConcrete forall b c a. (b -> c) -> (a -> b) -> a -> c
. QName -> Name
qnameName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. Arg e -> e
unArg) (ConHead -> [Arg QName]
conFields ConHead
c) forall a b. [a] -> [Arg b] -> [Arg a]
`withArgsFrom` [NamedArg DeBruijnPattern]
qs
cpi :: ConPatternInfo
cpi = PatternInfo
-> Bool -> Bool -> Maybe (Arg Type) -> Bool -> ConPatternInfo
ConPatternInfo (PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatORec [Name]
asB) Bool
r Bool
ft Maybe (Arg Type)
mb Bool
l
[NamedArg Pattern]
ps <- forall a.
HasRange a =>
QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFieldsFail QName
d (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> Pattern' e
A.WildP PatInfo
patNoRange) [FieldAssignment' Pattern]
fs [Arg Name]
axs
forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c ConPatternInfo
cpi forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transfers [NamedArg Pattern]
ps [NamedArg DeBruijnPattern]
qs
(([Name]
asB , [Expr]
anns , Pattern
p) , ConP ConHead
c (ConPatternInfo PatternInfo
i Bool
r Bool
ft Maybe (Arg Type)
mb Bool
l) [NamedArg DeBruijnPattern]
qs) -> do
let cpi :: ConPatternInfo
cpi = PatternInfo
-> Bool -> Bool -> Maybe (Arg Type) -> Bool -> ConPatternInfo
ConPatternInfo (PatOrigin -> [Name] -> PatternInfo
PatternInfo (Pattern -> PatOrigin
patOrig Pattern
p) [Name]
asB) Bool
r Bool
ft Maybe (Arg Type)
mb Bool
l
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c ConPatternInfo
cpi [NamedArg DeBruijnPattern]
qs
(([Name]
asB , [Expr]
anns , Pattern
p) , VarP PatternInfo
_ DBPatVar
x) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. PatternInfo -> x -> Pattern' x
VarP (PatOrigin -> [Name] -> PatternInfo
PatternInfo (Pattern -> PatOrigin
patOrig Pattern
p) [Name]
asB) DBPatVar
x
(([Name]
asB , [Expr]
anns , Pattern
p) , DotP PatternInfo
_ Term
u) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. PatternInfo -> Term -> Pattern' x
DotP (PatOrigin -> [Name] -> PatternInfo
PatternInfo (Pattern -> PatOrigin
patOrig Pattern
p) [Name]
asB) Term
u
(([Name]
asB , [Expr]
anns , Pattern
p) , LitP PatternInfo
_ Literal
l) -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall x. PatternInfo -> Literal -> Pattern' x
LitP (PatOrigin -> [Name] -> PatternInfo
PatternInfo (Pattern -> PatOrigin
patOrig Pattern
p) [Name]
asB) Literal
l
(([Name], [Expr], Pattern), DeBruijnPattern)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return DeBruijnPattern
q
patOrig :: A.Pattern -> PatOrigin
patOrig :: Pattern -> PatOrigin
patOrig (A.VarP BindName
x) = Name -> PatOrigin
PatOVar (BindName -> Name
A.unBind BindName
x)
patOrig A.DotP{} = PatOrigin
PatODot
patOrig A.ConP{} = PatOrigin
PatOCon
patOrig A.RecP{} = PatOrigin
PatORec
patOrig A.WildP{} = PatOrigin
PatOWild
patOrig A.AbsurdP{} = PatOrigin
PatOAbsurd
patOrig A.LitP{} = PatOrigin
PatOLit
patOrig A.EqualP{} = PatOrigin
PatOCon
patOrig A.AsP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
patOrig A.ProjP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
patOrig A.DefP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
patOrig A.PatternSynP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
patOrig A.WithP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
patOrig A.AnnP{} = forall a. HasCallStack => a
__IMPOSSIBLE__
matchingArgs :: NamedArg A.Pattern -> NamedArg DeBruijnPattern -> Bool
matchingArgs :: NamedArg Pattern -> NamedArg DeBruijnPattern -> Bool
matchingArgs NamedArg Pattern
p NamedArg DeBruijnPattern
q
| forall a. Maybe a -> Bool
isJust (forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
A.isProjP NamedArg Pattern
p) = forall a. Maybe a -> Bool
isJust (forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
isProjP NamedArg DeBruijnPattern
q)
| forall a. LensHiding a => a -> Bool
visible NamedArg Pattern
p Bool -> Bool -> Bool
&& forall a. LensHiding a => a -> Bool
visible NamedArg DeBruijnPattern
q = Bool
True
| forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding NamedArg Pattern
p NamedArg DeBruijnPattern
q Bool -> Bool -> Bool
&& forall a. Maybe a -> Bool
isNothing (forall a. LensNamed a => a -> Maybe (NameOf a)
getNameOf NamedArg Pattern
p) = Bool
True
| forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding NamedArg Pattern
p NamedArg DeBruijnPattern
q Bool -> Bool -> Bool
&& forall a b.
(LensNamed a, LensNamed b, NameOf a ~ NamedName,
NameOf b ~ NamedName) =>
a -> b -> Bool
namedSame NamedArg Pattern
p NamedArg DeBruijnPattern
q = Bool
True
| Bool
otherwise = Bool
False
checkPatternLinearity :: [ProblemEq] -> TCM [ProblemEq]
checkPatternLinearity :: [ProblemEq] -> TCMT IO [ProblemEq]
checkPatternLinearity [ProblemEq]
eqs = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.linear" Int
30 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"Checking linearity of pattern variables"
Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [ProblemEq]
check forall k a. Map k a
Map.empty [ProblemEq]
eqs
where
check :: Map A.BindName (Term, Type) -> [ProblemEq] -> TCM [ProblemEq]
check :: Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type)
_ [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
check Map BindName (Term, Type)
vars (eq :: ProblemEq
eq@(ProblemEq Pattern
p Term
u Dom Type
a) : [ProblemEq]
eqs) = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.linear" Int
40 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ TCMT IO Doc
"linearity: checking pattern "
, forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
p
, TCMT IO Doc
" equal to term "
, forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
u
, TCMT IO Doc
" of type "
, forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Dom Type
a
]
case Pattern
p of
A.VarP BindName
x -> do
let y :: Name
y = BindName -> Name
A.unBind BindName
x
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.lhs.linear" Int
60 forall a b. (a -> b) -> a -> b
$
[Char]
"pattern variable " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (Name -> Name
A.nameConcrete Name
y) forall a. [a] -> [a] -> [a]
++ [Char]
" with id " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (Name -> NameId
A.nameId Name
y)
case forall k a. Ord k => k -> Map k a -> Maybe a
Map.lookup BindName
x Map BindName (Term, Type)
vars of
Just (Term
v , Type
b) -> do
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Name -> Call
CheckPatternLinearityType forall a b. (a -> b) -> a -> b
$ Name -> Name
A.nameConcrete Name
y) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(MonadConstraint m, MonadWarning m, MonadError TCErr m,
MonadFresh ProblemId m) =>
m a -> m a
noConstraints forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadConversion m => Type -> Type -> m ()
equalType (forall t e. Dom' t e -> e
unDom Dom Type
a) Type
b
forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Name -> Call
CheckPatternLinearityValue forall a b. (a -> b) -> a -> b
$ Name -> Name
A.nameConcrete Name
y) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(MonadConstraint m, MonadWarning m, MonadError TCErr m,
MonadFresh ProblemId m) =>
m a -> m a
noConstraints forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
MonadConversion m =>
Type -> Term -> Term -> m ()
equalTerm (forall t e. Dom' t e -> e
unDom Dom Type
a) Term
u Term
v
Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type)
vars [ProblemEq]
eqs
Maybe (Term, Type)
Nothing -> (ProblemEq
eqforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> do
Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [ProblemEq]
check (forall k a. Ord k => k -> a -> Map k a -> Map k a
Map.insert BindName
x (Term
u,forall t e. Dom' t e -> e
unDom Dom Type
a) Map BindName (Term, Type)
vars) [ProblemEq]
eqs
A.AsP PatInfo
_ BindName
x Pattern
p ->
Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type)
vars forall a b. (a -> b) -> a -> b
$ [Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (forall e. BindName -> Pattern' e
A.VarP BindName
x) Term
u Dom Type
a, Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq Pattern
p Term
u Dom Type
a] forall a. [a] -> [a] -> [a]
++ [ProblemEq]
eqs
A.AnnP PatInfo
_ Expr
_ A.WildP{} -> TCMT IO [ProblemEq]
continue
A.AnnP PatInfo
r Expr
t Pattern
p -> (Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (forall e. PatInfo -> e -> Pattern' e -> Pattern' e
A.AnnP PatInfo
r Expr
t (forall e. PatInfo -> Pattern' e
A.WildP PatInfo
patNoRange)) Term
u Dom Type
aforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type)
vars (Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq Pattern
p Term
u Dom Type
a forall a. a -> [a] -> [a]
: [ProblemEq]
eqs)
A.WildP{} -> TCMT IO [ProblemEq]
continue
A.DotP{} -> TCMT IO [ProblemEq]
continue
A.AbsurdP{} -> TCMT IO [ProblemEq]
continue
A.ConP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.ProjP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.DefP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.LitP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.PatternSynP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.RecP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.EqualP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.WithP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
where continue :: TCMT IO [ProblemEq]
continue = (ProblemEq
eqforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Map BindName (Term, Type) -> [ProblemEq] -> TCMT IO [ProblemEq]
check Map BindName (Term, Type)
vars [ProblemEq]
eqs
computeLHSContext :: [Maybe A.Name] -> Telescope -> TCM Context
computeLHSContext :: [Maybe Name] -> Telescope -> TCM Context
computeLHSContext = forall {m :: * -> *} {f :: * -> *} {a}.
(MonadDebug m, PrettyTCM (Tele (f a)), MonadFresh NameId m,
Subst (f a), Functor f) =>
[f (Name, a)]
-> [Name] -> [Maybe Name] -> Tele (f a) -> m [f (Name, a)]
go [] []
where
go :: [f (Name, a)]
-> [Name] -> [Maybe Name] -> Tele (f a) -> m [f (Name, a)]
go [f (Name, a)]
cxt [Name]
_ [] tel :: Tele (f a)
tel@ExtendTel{} = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"impossible" Int
10 forall a b. (a -> b) -> a -> b
$
TCMT IO Doc
"computeLHSContext: no patterns left, but tel =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Tele (f a)
tel
forall a. HasCallStack => a
__IMPOSSIBLE__
go [f (Name, a)]
cxt [Name]
_ (Maybe Name
_ : [Maybe Name]
_) Tele (f a)
EmptyTel = forall a. HasCallStack => a
__IMPOSSIBLE__
go [f (Name, a)]
cxt [Name]
_ [] Tele (f a)
EmptyTel = forall (m :: * -> *) a. Monad m => a -> m a
return [f (Name, a)]
cxt
go [f (Name, a)]
cxt [Name]
taken (Maybe Name
x : [Maybe Name]
xs) tel0 :: Tele (f a)
tel0@(ExtendTel f a
a Abs (Tele (f a))
tel) = do
Name
name <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall {m :: * -> *} {p}.
MonadFresh NameId m =>
p -> [Char] -> m Name
dummyName [Name]
taken forall a b. (a -> b) -> a -> b
$ forall a. Abs a -> [Char]
absName Abs (Tele (f a))
tel) forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
x
let e :: f (Name, a)
e = (Name
name,) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> f a
a
[f (Name, a)]
-> [Name] -> [Maybe Name] -> Tele (f a) -> m [f (Name, a)]
go (f (Name, a)
e forall a. a -> [a] -> [a]
: [f (Name, a)]
cxt) (Name
name forall a. a -> [a] -> [a]
: [Name]
taken) [Maybe Name]
xs (forall a. Subst a => Abs a -> a
absBody Abs (Tele (f a))
tel)
dummyName :: p -> [Char] -> m Name
dummyName p
taken [Char]
s =
if forall a. Underscore a => a -> Bool
isUnderscore [Char]
s then forall (m :: * -> *). MonadFresh NameId m => m Name
freshNoName_
else forall a. LensInScope a => a -> a
setNotInScope forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a (m :: * -> *).
(FreshName a, MonadFresh NameId m) =>
a -> m Name
freshName_ ([Char] -> [Char]
argNameToString [Char]
s)
bindAsPatterns :: [AsBinding] -> TCM a -> TCM a
bindAsPatterns :: forall a. [AsBinding] -> TCM a -> TCM a
bindAsPatterns [] TCM a
ret = TCM a
ret
bindAsPatterns (AsB Name
x Term
v Type
a Modality
m : [AsBinding]
asb) TCM a
ret = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.as" Int
10 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"as pattern" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Name
x forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+>
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
":" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
a
, TCMT IO Doc
"=" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
v
]
forall (m :: * -> *) a.
MonadAddContext m =>
ArgInfo -> Origin -> Name -> Term -> Type -> m a -> m a
addLetBinding (forall a. LensModality a => Modality -> a -> a
setModality Modality
m ArgInfo
defaultArgInfo) Origin
Inserted Name
x Term
v Type
a forall a b. (a -> b) -> a -> b
$ forall a. [AsBinding] -> TCM a -> TCM a
bindAsPatterns [AsBinding]
asb TCM a
ret
recheckStrippedWithPattern :: ProblemEq -> TCM ()
recheckStrippedWithPattern :: ProblemEq -> TCMT IO ()
recheckStrippedWithPattern (ProblemEq Pattern
p Term
v Dom Type
a) = forall a (m :: * -> *).
(CheckInternal a, MonadCheckInternal m) =>
a -> Comparison -> TypeOf a -> m ()
checkInternal Term
v Comparison
CmpLeq (forall t e. Dom' t e -> e
unDom Dom Type
a)
forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` \TCErr
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
IllTypedPatternAfterWithAbstraction Pattern
p
data LHSResult = LHSResult
{ LHSResult -> Int
lhsParameters :: Nat
, LHSResult -> Telescope
lhsVarTele :: Telescope
, LHSResult -> [NamedArg DeBruijnPattern]
lhsPatterns :: [NamedArg DeBruijnPattern]
, LHSResult -> Bool
lhsHasAbsurd :: Bool
, LHSResult -> Arg Type
lhsBodyType :: Arg Type
, LHSResult -> Substitution
lhsPatSubst :: Substitution
, LHSResult -> [AsBinding]
lhsAsBindings :: [AsBinding]
, LHSResult -> IntSet
lhsPartialSplit :: IntSet
, LHSResult -> Bool
lhsIndexedSplit :: Bool
}
instance InstantiateFull LHSResult where
instantiateFull' :: LHSResult -> ReduceM LHSResult
instantiateFull' (LHSResult Int
n Telescope
tel [NamedArg DeBruijnPattern]
ps Bool
abs Arg Type
t Substitution
sub [AsBinding]
as IntSet
psplit Bool
ixsplit) = Int
-> Telescope
-> [NamedArg DeBruijnPattern]
-> Bool
-> Arg Type
-> Substitution
-> [AsBinding]
-> IntSet
-> Bool
-> LHSResult
LHSResult Int
n
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Telescope
tel
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [NamedArg DeBruijnPattern]
ps
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Bool
abs
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Arg Type
t
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' Substitution
sub
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall t. InstantiateFull t => t -> ReduceM t
instantiateFull' [AsBinding]
as
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure IntSet
psplit
forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (f :: * -> *) a. Applicative f => a -> f a
pure Bool
ixsplit
checkLeftHandSide :: forall a.
Call
-> Maybe QName
-> [NamedArg A.Pattern]
-> Type
-> Maybe Substitution
-> [ProblemEq]
-> (LHSResult -> TCM a)
-> TCM a
checkLeftHandSide :: forall a.
Call
-> Maybe QName
-> [NamedArg Pattern]
-> Type
-> Maybe Substitution
-> [ProblemEq]
-> (LHSResult -> TCM a)
-> TCM a
checkLeftHandSide Call
call Maybe QName
f [NamedArg Pattern]
ps Type
a Maybe Substitution
withSub' [ProblemEq]
strippedPats =
forall (m :: * -> *) b c.
MonadBench m =>
Account (BenchPhase m) -> ((b -> m c) -> m c) -> (b -> m c) -> m c
Bench.billToCPS [Phase
Bench.Typing, Phase
Bench.CheckLHS] forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a b.
MonadTrace m =>
Call -> ((a -> m b) -> m b) -> (a -> m b) -> m b
traceCallCPS Call
call forall a b. (a -> b) -> a -> b
$ \ LHSResult -> TCMT IO a
ret -> do
Context
cxt <- forall a b. (a -> b) -> [a] -> [b]
map (forall a. LensOrigin a => Origin -> a -> a
setOrigin Origin
Inserted) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. [a] -> [a]
reverse forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadTCEnv m => m Context
getContext
let tel :: Telescope
tel = forall a. (a -> [Char]) -> ListTel' a -> Telescope
telFromList' forall a. Pretty a => a -> [Char]
prettyShow Context
cxt
cps :: [NamedArg Pattern]
cps = [ forall a name. a -> Named name a
unnamed forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall e. BindName -> Pattern' e
A.VarP forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> BindName
A.mkBindName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> a
fst forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t a. Dom' t a -> Arg a
argFromDom ContextEntry
d
| ContextEntry
d <- Context
cxt ]
eqs0 :: [ProblemEq]
eqs0 = forall a b c d. (a -> b -> c -> d) -> [a] -> [b] -> [c] -> [d]
zipWith3 Pattern -> Term -> Dom Type -> ProblemEq
ProblemEq (forall a b. (a -> b) -> [a] -> [b]
map forall a. NamedArg a -> a
namedArg [NamedArg Pattern]
cps) (forall a b. (a -> b) -> [a] -> [b]
map Int -> Term
var forall a b. (a -> b) -> a -> b
$ forall a. Integral a => a -> [a]
downFrom forall a b. (a -> b) -> a -> b
$ forall a. Sized a => a -> Int
size Telescope
tel) (forall a. TermSubst a => Tele (Dom a) -> [Dom a]
flattenTel Telescope
tel)
let finalChecks :: LHSState a -> TCM a
finalChecks :: LHSState a -> TCMT IO a
finalChecks (LHSState Telescope
delta [NamedArg DeBruijnPattern]
qs0 (Problem [ProblemEq]
eqs [NamedArg Pattern]
rps LHSState a -> TCMT IO a
_) Arg Type
b [Maybe Int]
psplit Bool
ixsplit) = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"lhs: final checks with remaining equations"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ if forall a. Null a => a -> Bool
null [ProblemEq]
eqs then TCMT IO Doc
"(none)" else forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [ProblemEq]
eqs
, TCMT IO Doc
"qs0 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (forall (m :: * -> *).
MonadPretty m =>
[NamedArg DeBruijnPattern] -> m Doc
prettyTCMPatternList [NamedArg DeBruijnPattern]
qs0)
]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Null a => a -> Bool
null [NamedArg Pattern]
rps) forall a. HasCallStack => a
__IMPOSSIBLE__
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ProblemEq -> TCMT IO ()
noShadowingOfConstructors [ProblemEq]
eqs
Int
arity_a <- Type -> TCM Int
arityPiPath Type
a
let notProj :: Pattern' x -> Bool
notProj ProjP{} = Bool
False
notProj Pattern' x
_ = Bool
True
numPats :: Int
numPats = forall (t :: * -> *) a. Foldable t => t a -> Int
length forall a b. (a -> b) -> a -> b
$ forall a. (a -> Bool) -> [a] -> [a]
takeWhile (forall {x}. Pattern' x -> Bool
notProj forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedArg a -> a
namedArg) [NamedArg DeBruijnPattern]
qs0
weakSub :: Substitution
weakSub :: Substitution
weakSub | forall a. Maybe a -> Bool
isJust Maybe Substitution
withSub' = forall a. Int -> Substitution' a -> Substitution' a
wkS (forall a. Ord a => a -> a -> a
max Int
0 forall a b. (a -> b) -> a -> b
$ Int
numPats forall a. Num a => a -> a -> a
- Int
arity_a) forall a. Substitution' a
idS
| Bool
otherwise = forall a. Int -> Substitution' a -> Substitution' a
wkS (Int
numPats forall a. Num a => a -> a -> a
- forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
cxt) forall a. Substitution' a
idS
withSub :: Substitution
withSub = forall a. a -> Maybe a -> a
fromMaybe forall a. Substitution' a
idS Maybe Substitution
withSub'
patSub :: Substitution
patSub = forall a b. (a -> b) -> [a] -> [b]
map (DeBruijnPattern -> Term
patternToTerm forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. NamedArg a -> a
namedArg) (forall a. [a] -> [a]
reverse forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take Int
numPats [NamedArg DeBruijnPattern]
qs0) forall a. DeBruijn a => [a] -> Substitution' a -> Substitution' a
++# forall a. Impossible -> Substitution' a
EmptyS HasCallStack => Impossible
impossible
paramSub :: Substitution
paramSub = Substitution
patSub forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Substitution
weakSub forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
`composeS` Substitution
withSub
[ProblemEq]
eqs <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta forall a b. (a -> b) -> a -> b
$ [ProblemEq] -> TCMT IO [ProblemEq]
checkPatternLinearity [ProblemEq]
eqs
leftovers :: LeftoverPatterns
leftovers@(LeftoverPatterns IntMap [(Name, PatVarPosition)]
patVars [AsBinding]
asb0 [DotPattern]
dots [AbsurdPattern]
absurds [AnnotationPattern]
annps [Pattern]
otherPats)
<- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PureTCM m =>
[ProblemEq] -> m LeftoverPatterns
getLeftoverPatterns [ProblemEq]
eqs
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.leftover" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"leftover patterns: " , forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta forall a b. (a -> b) -> a -> b
$ forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM LeftoverPatterns
leftovers) ]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Null a => a -> Bool
null [Pattern]
otherPats) forall a. HasCallStack => a
__IMPOSSIBLE__
let ([Maybe Name]
vars, [AsBinding]
asb1) = Telescope
-> IntMap [(Name, PatVarPosition)] -> ([Maybe Name], [AsBinding])
getUserVariableNames Telescope
delta IntMap [(Name, PatVarPosition)]
patVars
asb :: [AsBinding]
asb = [AsBinding]
asb0 forall a. [a] -> [a] -> [a]
++ [AsBinding]
asb1
let makeVar :: Maybe Name -> Int -> DeBruijnPattern
makeVar = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall a. DeBruijn a => Int -> a
deBruijnVar forall a b. (a -> b) -> a -> b
$ forall a. DeBruijn a => [Char] -> Int -> a
debruijnNamedVar forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> [Char]
nameToArgName
ren :: PatternSubstitution
ren = forall a. DeBruijn a => [a] -> Substitution' a
parallelS forall a b. (a -> b) -> a -> b
$ forall a b c. (a -> b -> c) -> [a] -> [b] -> [c]
zipWith Maybe Name -> Int -> DeBruijnPattern
makeVar (forall a. [a] -> [a]
reverse [Maybe Name]
vars) [Int
0..]
[NamedArg DeBruijnPattern]
qs <- [NamedArg Pattern]
-> [NamedArg DeBruijnPattern] -> TCM [NamedArg DeBruijnPattern]
transferOrigins ([NamedArg Pattern]
cps forall a. [a] -> [a] -> [a]
++ [NamedArg Pattern]
ps) forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst PatternSubstitution
ren [NamedArg DeBruijnPattern]
qs0
let hasAbsurd :: Bool
hasAbsurd = Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Null a => a -> Bool
null forall a b. (a -> b) -> a -> b
$ [AbsurdPattern]
absurds
let lhsResult :: LHSResult
lhsResult = Int
-> Telescope
-> [NamedArg DeBruijnPattern]
-> Bool
-> Arg Type
-> Substitution
-> [AsBinding]
-> IntSet
-> Bool
-> LHSResult
LHSResult (forall (t :: * -> *) a. Foldable t => t a -> Int
length Context
cxt) Telescope
delta [NamedArg DeBruijnPattern]
qs Bool
hasAbsurd Arg Type
b Substitution
patSub [AsBinding]
asb ([Int] -> IntSet
IntSet.fromList forall a b. (a -> b) -> a -> b
$ forall a. [Maybe a] -> [a]
catMaybes [Maybe Int]
psplit) Bool
ixsplit
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
10 forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat [ TCMT IO Doc
"checked lhs:"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"delta = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta
, TCMT IO Doc
"dots = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate forall (m :: * -> *). Applicative m => m Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [DotPattern]
dots)
, TCMT IO Doc
"asb = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate forall (m :: * -> *). Applicative m => m Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [AsBinding]
asb)
, TCMT IO Doc
"absurds = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate forall (m :: * -> *). Applicative m => m Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM [AbsurdPattern]
absurds)
, TCMT IO Doc
"qs = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
t (m Doc) -> m Doc
prettyList forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
qs)
, TCMT IO Doc
"b = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Arg Type
b)
]
]
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
30 forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"vars = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [Maybe Name]
vars
, TCMT IO Doc
"b = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Arg Type
b
]
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"withSub = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Substitution
withSub
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"weakSub = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Substitution
weakSub
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"patSub = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Substitution
patSub
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"paramSub = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Substitution
paramSub
Context
newCxt <- [Maybe Name] -> Telescope -> TCM Context
computeLHSContext [Maybe Name]
vars Telescope
delta
forall (m :: * -> *) a.
MonadAddContext m =>
Substitution -> (Context -> Context) -> m a -> m a
updateContext Substitution
paramSub (forall a b. a -> b -> a
const Context
newCxt) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
10 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"bound pattern variables"
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
60 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"context = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Telescope
getContextTelescope)
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"type = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Arg Type
b
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
60 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"type = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Arg Type
b
forall a. [AsBinding] -> TCM a -> TCM a
bindAsPatterns [AsBinding]
asb forall a b. (a -> b) -> a -> b
$ do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ DotPattern -> TCMT IO ()
checkDotPattern [DotPattern]
dots
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ AbsurdPattern -> TCMT IO ()
checkAbsurdPattern [AbsurdPattern]
absurds
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ AnnotationPattern -> TCMT IO ()
checkAnnotationPattern [AnnotationPattern]
annps
LHSResult -> TCMT IO a
ret LHSResult
lhsResult
LHSState a
st0 <- forall a.
Telescope
-> [ProblemEq]
-> [NamedArg Pattern]
-> Type
-> (LHSState a -> TCM a)
-> TCM (LHSState a)
initLHSState Telescope
tel [ProblemEq]
eqs0 [NamedArg Pattern]
ps Type
a LHSState a -> TCMT IO a
finalChecks
let withSub :: Substitution
withSub = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ Maybe Substitution
withSub'
[ProblemEq]
withEqs <- [ProblemEq] -> TCMT IO [ProblemEq]
updateProblemEqs forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
withSub [ProblemEq]
strippedPats
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext (LHSState a
st0 forall o i. o -> Lens' o i -> i
^. forall a. Lens' (LHSState a) Telescope
lhsTel) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ [ProblemEq]
withEqs ProblemEq -> TCMT IO ()
recheckStrippedWithPattern
let st :: LHSState a
st = forall o i. Lens' o i -> LensMap o i
over (forall a. Lens' (LHSState a) (Problem a)
lhsProblem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (Problem a) [ProblemEq]
problemEqs) (forall a. [a] -> [a] -> [a]
++ [ProblemEq]
withEqs) LHSState a
st0
(a
result, Blocked' Term ()
block) <- forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
unsafeInTopContext forall a b. (a -> b) -> a -> b
$ forall w (m :: * -> *) a. WriterT w m a -> m (a, w)
runWriterT forall a b. (a -> b) -> a -> b
$ (forall r (m :: * -> *) a. ReaderT r m a -> r -> m a
`runReaderT` (forall a. Sized a => a -> Int
size Context
cxt)) forall a b. (a -> b) -> a -> b
$ forall (tcm :: * -> *) a.
(MonadTCM tcm, PureTCM tcm, MonadWriter (Blocked' Term ()) tcm,
MonadError TCErr tcm, MonadTrace tcm, MonadReader Int tcm) =>
Maybe QName -> LHSState a -> tcm a
checkLHS Maybe QName
f LHSState a
st
forall (m :: * -> *) a. Monad m => a -> m a
return a
result
conSplitModalityCheck
:: Modality
-> PatternSubstitution
-> Int
-> Telescope
-> Type
-> TCM ()
conSplitModalityCheck :: Modality
-> PatternSubstitution -> Int -> Telescope -> Type -> TCMT IO ()
conSplitModalityCheck Modality
mod PatternSubstitution
rho Int
blocking Telescope
gamma Type
target = forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any ((forall a. Eq a => a -> a -> Bool
/= Modality
defaultModality) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. LensModality a => a -> Modality
getModality) Telescope
gamma) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"LHS modality check for modality: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Modality
mod
, TCMT IO Doc
"rho: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM PatternSubstitution
rho)
, TCMT IO Doc
"gamma: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
gamma)
, TCMT IO Doc
"target: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
target forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Functor m => m Doc -> m Doc
parens (forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Type
target)
, TCMT IO Doc
"Δ'target: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho Type
target)
, TCMT IO Doc
"blocking:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Int
blocking
]
case PatternSubstitution -> Int -> Maybe Int
firstForced PatternSubstitution
rho (forall (t :: * -> *) a. Foldable t => t a -> Int
length Telescope
gamma) of
Just Int
ix -> do
let
(Telescope
gamma0, Telescope
delta) = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt (forall (t :: * -> *) a. Foldable t => t a -> Int
length Telescope
gamma forall a. Num a => a -> a -> a
- Int
ix) Telescope
gamma
name :: Int -> TCMT IO Name
name = forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *).
(Applicative m, MonadFail m, MonadTCEnv m) =>
Int -> m Name
nameOfBV
delta'target :: Type
delta'target = forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho Type
target
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"found forced argument!"
, TCMT IO Doc
"forced: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Int
ix
, TCMT IO Doc
"before: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
gamma0)
, TCMT IO Doc
"after: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext (forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma0 (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta))
]
Name
forced <- Int -> TCMT IO Name
name Int
ix
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a b. [a] -> [b] -> [(a, b)]
zip [Int
ix forall a. Num a => a -> a -> a
- Int
1, Int
ix forall a. Num a => a -> a -> a
- Int
2 ..] (forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Telescope
delta)) forall a b. (a -> b) -> a -> b
$ \(Int
arg, Dom ([Char], Type)
d) -> do
let
rho' :: PatternSubstitution
rho' = forall a.
EndoSubst a =>
Substitution' a -> Substitution' a -> Substitution' a
composeS PatternSubstitution
rho (forall a. Int -> Substitution' a -> Substitution' a
wkS (Int
arg forall a. Num a => a -> a -> a
+ Int
1) forall a. Substitution' a
idS)
Term
ty' <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho' (forall t a. Type'' t a -> a
unEl (forall a b. (a, b) -> b
snd (forall t e. Dom' t e -> e
unDom Dom ([Char], Type)
d))))
let
docheck :: Bool
docheck = forall (t :: * -> *). Foldable t => t Bool -> Bool
and
[ Int
ix forall a. Free a => Int -> a -> Bool
`freeIn` forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst (forall a. Int -> Substitution' a -> Substitution' a
wkS (Int
arg forall a. Num a => a -> a -> a
+ Int
1) forall a. Substitution' a
idS) (forall t a. Type'' t a -> a
unEl (forall a b. (a, b) -> b
snd (forall t e. Dom' t e -> e
unDom Dom ([Char], Type)
d)))
, Int
arg forall a. Eq a => a -> a -> Bool
/= Int
blocking
, Int
arg forall a. Free a => Int -> a -> Bool
`freeIn` Type
target
]
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"arg: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Int
arg
, TCMT IO Doc
"arg type: " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst (forall a. Int -> Substitution' a -> Substitution' a
wkS (Int
arg forall a. Num a => a -> a -> a
+ Int
1) forall a. Substitution' a
idS) (forall t a. Type'' t a -> a
unEl (forall a b. (a, b) -> b
snd (forall t e. Dom' t e -> e
unDom Dom ([Char], Type)
d))))
, TCMT IO Doc
"check " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Bool
docheck
]
Name
argn <- Int -> TCMT IO Name
name Int
arg
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
docheck forall a b. (a -> b) -> a -> b
$
MonadConstraint (TCMT IO) =>
WhyCheckModality -> Modality -> Term -> TCMT IO ()
usableAtModality (Name -> Name -> WhyCheckModality
IndexedClauseArg Name
forced Name
argn) Modality
mod Term
ty'
Maybe Int
Nothing -> forall (f :: * -> *) a. Applicative f => a -> f a
pure ()
MonadConstraint (TCMT IO) =>
WhyCheckModality -> Modality -> Term -> TCMT IO ()
usableAtModality WhyCheckModality
IndexedClause Modality
mod (forall t a. Type'' t a -> a
unEl (forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho Type
target))
forall (tcm :: * -> *) a.
(MonadTCEnv tcm, ReadTCState tcm) =>
tcm a -> tcm a
inTopContext forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma forall a b. (a -> b) -> a -> b
$ MonadConstraint (TCMT IO) =>
WhyCheckModality -> Modality -> Term -> TCMT IO ()
usableAtModality WhyCheckModality
IndexedClause Modality
mod (forall t a. Type'' t a -> a
unEl Type
target)
where
firstForced :: PatternSubstitution -> Int -> Maybe Int
firstForced :: PatternSubstitution -> Int -> Maybe Int
firstForced PatternSubstitution
pat Int
level
| Int
level forall a. Ord a => a -> a -> Bool
>= Int
0 = case forall a. EndoSubst a => Substitution' a -> Int -> a
lookupS PatternSubstitution
pat Int
level of
DotP{} -> forall a. a -> Maybe a
Just Int
level
DeBruijnPattern
_ -> PatternSubstitution -> Int -> Maybe Int
firstForced PatternSubstitution
pat (Int
level forall a. Num a => a -> a -> a
- Int
1)
| Bool
otherwise = forall a. Maybe a
Nothing
splitStrategy :: [ProblemEq] -> [ProblemEq]
splitStrategy :: [ProblemEq] -> [ProblemEq]
splitStrategy = forall a. (a -> Bool) -> [a] -> [a]
filter ProblemEq -> Bool
shouldSplit
where
shouldSplit :: ProblemEq -> Bool
shouldSplit :: ProblemEq -> Bool
shouldSplit problem :: ProblemEq
problem@(ProblemEq Pattern
p Term
v Dom Type
a) = case Pattern
p of
A.LitP{} -> Bool
True
A.RecP{} -> Bool
True
A.ConP{} -> Bool
True
A.EqualP{} -> Bool
True
A.VarP{} -> Bool
False
A.WildP{} -> Bool
False
A.DotP{} -> Bool
False
A.AbsurdP{} -> Bool
False
A.AsP PatInfo
_ BindName
_ Pattern
p -> ProblemEq -> Bool
shouldSplit forall a b. (a -> b) -> a -> b
$ ProblemEq
problem { problemInPat :: Pattern
problemInPat = Pattern
p }
A.AnnP PatInfo
_ Expr
_ Pattern
p -> ProblemEq -> Bool
shouldSplit forall a b. (a -> b) -> a -> b
$ ProblemEq
problem { problemInPat :: Pattern
problemInPat = Pattern
p }
A.ProjP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.DefP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.PatternSynP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.WithP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
checkLHS
:: forall tcm a. (MonadTCM tcm, PureTCM tcm, MonadWriter Blocked_ tcm, MonadError TCErr tcm, MonadTrace tcm, MonadReader Nat tcm)
=> Maybe QName
-> LHSState a
-> tcm a
checkLHS :: forall (tcm :: * -> *) a.
(MonadTCM tcm, PureTCM tcm, MonadWriter (Blocked' Term ()) tcm,
MonadError TCErr tcm, MonadTrace tcm, MonadReader Int tcm) =>
Maybe QName -> LHSState a -> tcm a
checkLHS Maybe QName
mf = forall {tcm :: * -> *} {a} {a}.
MonadTCEnv tcm =>
(LHSState a -> tcm a) -> LHSState a -> tcm a
updateModality LHSState a -> tcm a
checkLHS_ where
updateModality :: (LHSState a -> tcm a) -> LHSState a -> tcm a
updateModality LHSState a -> tcm a
cont st :: LHSState a
st@(LHSState Telescope
tel [NamedArg DeBruijnPattern]
ip Problem a
problem Arg Type
target [Maybe Int]
psplit Bool
_) = do
let m :: Modality
m = forall a. LensModality a => a -> Modality
getModality Arg Type
target
forall (tcm :: * -> *) m a.
(MonadTCEnv tcm, LensModality m) =>
m -> tcm a -> tcm a
applyModalityToContext Modality
m forall a b. (a -> b) -> a -> b
$ do
LHSState a -> tcm a
cont forall a b. (a -> b) -> a -> b
$ forall o i. Lens' o i -> LensMap o i
over (forall a. Lens' (LHSState a) Telescope
lhsTel forall b c a. (b -> c) -> (a -> b) -> a -> c
. Lens' Telescope [Dom ([Char], Type)]
listTel)
(forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a -> b) -> a -> b
$ forall a. LensModality a => Modality -> a -> a
inverseApplyModalityButNotQuantity Modality
m) LHSState a
st
checkLHS_ :: LHSState a -> tcm a
checkLHS_ st :: LHSState a
st@(LHSState Telescope
tel [NamedArg DeBruijnPattern]
ip Problem a
problem Arg Type
target [Maybe Int]
psplit Bool
ixsplit) = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs" Int
40 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"tel is" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs" Int
40 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"ip is" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty [NamedArg DeBruijnPattern]
ip
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs" Int
40 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target is" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Arg Type
target)
if forall a. Problem a -> Bool
isSolvedProblem Problem a
problem then
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ (Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) (LHSState a -> TCM a)
problemCont) LHSState a
st
else do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"LHS state: " , forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM LHSState a
st) ]
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (PragmaOptions -> Bool
optPatternMatching forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a. ReadTCState m => (TCState -> a) -> m a
getsTC forall a. LensPragmaOptions a => a -> PragmaOptions
getPragmaOptions) forall a b. (a -> b) -> a -> b
$
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. Problem a -> Bool
problemAllVariables Problem a
problem) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError forall a b. (a -> b) -> a -> b
$ [Char]
"Pattern matching is disabled"
let splitsToTry :: [ProblemEq]
splitsToTry = [ProblemEq] -> [ProblemEq]
splitStrategy forall a b. (a -> b) -> a -> b
$ Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) [ProblemEq]
problemEqs
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr ProblemEq
-> tcm (Either [TCErr] (LHSState a))
-> tcm (Either [TCErr] (LHSState a))
trySplit tcm (Either [TCErr] (LHSState a))
trySplitRest [ProblemEq]
splitsToTry forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right LHSState a
st' -> forall (tcm :: * -> *) a.
(MonadTCM tcm, PureTCM tcm, MonadWriter (Blocked' Term ()) tcm,
MonadError TCErr tcm, MonadTrace tcm, MonadReader Int tcm) =>
Maybe QName -> LHSState a -> tcm a
checkLHS Maybe QName
mf LHSState a
st'
Left (TCErr
err:[TCErr]
_) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
Left [] -> forall a. HasCallStack => a
__IMPOSSIBLE__
where
trySplit :: ProblemEq
-> tcm (Either [TCErr] (LHSState a))
-> tcm (Either [TCErr] (LHSState a))
trySplit :: ProblemEq
-> tcm (Either [TCErr] (LHSState a))
-> tcm (Either [TCErr] (LHSState a))
trySplit ProblemEq
eq tcm (Either [TCErr] (LHSState a))
tryNextSplit = forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (ProblemEq -> ExceptT TCErr tcm (LHSState a)
splitArg ProblemEq
eq) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Right LHSState a
st' -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right LHSState a
st'
Left TCErr
err -> forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left (TCErr
errforall a. a -> [a] -> [a]
:) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> tcm (Either [TCErr] (LHSState a))
tryNextSplit
trySplitRest :: tcm (Either [TCErr] (LHSState a))
trySplitRest :: tcm (Either [TCErr] (LHSState a))
trySplitRest = case Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) [NamedArg Pattern]
problemRestPats of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left []
(NamedArg Pattern
p:[NamedArg Pattern]
_) -> forall (a :: * -> * -> *) b c d.
ArrowChoice a =>
a b c -> a (Either b d) (Either c d)
left forall el coll. Singleton el coll => el -> coll
singleton forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT (NamedArg Pattern -> ExceptT TCErr tcm (LHSState a)
splitRest NamedArg Pattern
p)
splitArg :: ProblemEq -> ExceptT TCErr tcm (LHSState a)
splitArg :: ProblemEq -> ExceptT TCErr tcm (LHSState a)
splitArg (ProblemEq Pattern
p Term
v Dom{unDom :: forall t e. Dom' t e -> e
unDom = Type
a}) = forall (m :: * -> *) a. MonadTrace m => Call -> m a -> m a
traceCall (Pattern -> Telescope -> Type -> Call
CheckPattern Pattern
p Telescope
tel Type
a) forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ TCMT IO Doc
"split looking at pattern"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"p =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA Pattern
p
]
Int
i <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> (a -> m b) -> m b -> m b
ifJustM (forall (m :: * -> *). PureTCM m => Term -> Type -> m (Maybe Int)
isEtaVar Term
v Type
a) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ Term -> Type -> TypeError
SplitOnNonVariable Term
v Type
a
let pos :: Int
pos = forall a. Sized a => a -> Int
size Telescope
tel forall a. Num a => a -> a -> a
- (Int
i forall a. Num a => a -> a -> a
+ Int
1)
(Telescope
delta1, tel' :: Telescope
tel'@(ExtendTel Dom Type
dom Abs Telescope
adelta2)) = Int -> Telescope -> (Telescope, Telescope)
splitTelescopeAt Int
pos Telescope
tel
Pattern
p <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadError TCErr m, MonadTCEnv m, ReadTCState m, HasBuiltins m) =>
Pattern -> m Pattern
expandLitPattern Pattern
p
let splitOnPat :: Pattern -> ExceptT TCErr tcm (LHSState a)
splitOnPat = \case
(A.LitP PatInfo
_ Literal
l) -> Telescope
-> Dom Type
-> Abs Telescope
-> Literal
-> ExceptT TCErr tcm (LHSState a)
splitLit Telescope
delta1 Dom Type
dom Abs Telescope
adelta2 Literal
l
p :: Pattern
p@A.RecP{} -> Telescope
-> Dom Type
-> Abs Telescope
-> Pattern
-> Maybe AmbiguousQName
-> ExceptT TCErr tcm (LHSState a)
splitCon Telescope
delta1 Dom Type
dom Abs Telescope
adelta2 Pattern
p forall a. Maybe a
Nothing
p :: Pattern
p@(A.ConP ConPatInfo
_ AmbiguousQName
c [NamedArg Pattern]
ps) -> Telescope
-> Dom Type
-> Abs Telescope
-> Pattern
-> Maybe AmbiguousQName
-> ExceptT TCErr tcm (LHSState a)
splitCon Telescope
delta1 Dom Type
dom Abs Telescope
adelta2 Pattern
p forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just AmbiguousQName
c
p :: Pattern
p@(A.EqualP PatInfo
_ [(Expr, Expr)]
ts) -> Telescope
-> Dom Type
-> Abs Telescope
-> [(Expr, Expr)]
-> ExceptT TCErr tcm (LHSState a)
splitPartial Telescope
delta1 Dom Type
dom Abs Telescope
adelta2 [(Expr, Expr)]
ts
A.AsP PatInfo
_ BindName
_ Pattern
p -> Pattern -> ExceptT TCErr tcm (LHSState a)
splitOnPat Pattern
p
A.AnnP PatInfo
_ Expr
_ Pattern
p -> Pattern -> ExceptT TCErr tcm (LHSState a)
splitOnPat Pattern
p
A.VarP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.WildP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.DotP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.AbsurdP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.ProjP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.DefP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.PatternSynP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
A.WithP{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Pattern -> ExceptT TCErr tcm (LHSState a)
splitOnPat Pattern
p
splitRest :: NamedArg A.Pattern -> ExceptT TCErr tcm (LHSState a)
splitRest :: NamedArg Pattern -> ExceptT TCErr tcm (LHSState a)
splitRest NamedArg Pattern
p = forall (m :: * -> *) x a.
(MonadTrace m, HasRange x) =>
x -> m a -> m a
setCurrentRange NamedArg Pattern
p forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ TCMT IO Doc
"splitting problem rest"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"projection pattern =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *).
(ToConcrete a, Pretty (ConOfAbs a), MonadAbsToCon m) =>
a -> m Doc
prettyA NamedArg Pattern
p
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"eliminates type =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Arg Type
target
]
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
80 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"projection pattern (raw) = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show NamedArg Pattern
p
]
(ProjOrigin
orig, AmbiguousQName
ambProjName) <- forall a b. Maybe a -> (a -> b) -> b -> b
ifJust (forall a. IsProjP a => a -> Maybe (ProjOrigin, AmbiguousQName)
A.isProjP NamedArg Pattern
p) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel forall a b. (a -> b) -> a -> b
$ do
Maybe Blocker
block <- forall t (m :: * -> *).
(Reduce t, IsMeta t, MonadReduce m) =>
t -> m (Maybe Blocker)
isBlocked Arg Type
target
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> NamedArg Pattern -> Type -> TypeError
CannotEliminateWithPattern Maybe Blocker
block NamedArg Pattern
p (forall e. Arg e -> e
unArg Arg Type
target)
(QName
projName, Bool
comatchingAllowed, QName
recName, Arg Type
projType, ArgInfo
ai) <- forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors forall a b. (a -> b) -> a -> b
$ do
let h :: Maybe Hiding
h = if ProjOrigin
orig forall a. Eq a => a -> a -> Bool
== ProjOrigin
ProjPostfix then forall a. Maybe a
Nothing else forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall a. LensHiding a => a -> Hiding
getHiding NamedArg Pattern
p
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel forall a b. (a -> b) -> a -> b
$ Maybe Hiding
-> AmbiguousQName
-> Arg Type
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
disambiguateProjection Maybe Hiding
h AmbiguousQName
ambProjName Arg Type
target
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless Bool
comatchingAllowed forall a b. (a -> b) -> a -> b
$ do
forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall a b. (a -> b) -> a -> b
$ QName -> TypeError
ComatchingDisabledForRecord QName
recName
QName
f <- forall a b. Maybe a -> (a -> b) -> b -> b
ifJust Maybe QName
mf forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall a b. (a -> b) -> a -> b
$
[Char] -> TypeError
GenericError [Char]
"Cannot use copatterns in a let binding"
let self :: Term
self = QName -> Elims -> Term
Def QName
f forall a b. (a -> b) -> a -> b
$ [NamedArg DeBruijnPattern] -> Elims
patternsToElims [NamedArg DeBruijnPattern]
ip
Arg Type
target' <- forall (t :: * -> *) (f :: * -> *) a b.
(Traversable t, Applicative f) =>
(a -> f b) -> t a -> f (t b)
traverse (forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
`piApplyM` Term
self) Arg Type
projType
let projP :: NamedArg DeBruijnPattern
projP = forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen (ProjOrigin
orig forall a. Eq a => a -> a -> Bool
== ProjOrigin
ProjPostfix) (forall a. LensHiding a => Hiding -> a -> a
setHiding Hiding
NotHidden) forall a b. (a -> b) -> a -> b
$
forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
ai forall a b. (a -> b) -> a -> b
$ forall name a. Maybe name -> a -> Named name a
Named forall a. Maybe a
Nothing (forall x. ProjOrigin -> QName -> Pattern' x
ProjP ProjOrigin
orig QName
projName)
ip' :: [NamedArg DeBruijnPattern]
ip' = [NamedArg DeBruijnPattern]
ip forall a. [a] -> [a] -> [a]
++ [NamedArg DeBruijnPattern
projP]
problem' :: Problem a
problem' = forall o i. Lens' o i -> LensMap o i
over forall a. Lens' (Problem a) [NamedArg Pattern]
problemRestPats (forall a. Int -> [a] -> [a]
drop Int
1) Problem a
problem
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall a. LHSState a -> TCM (LHSState a)
updateLHSState (forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
LHSState Telescope
tel [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' [Maybe Int]
psplit Bool
ixsplit)
splitPartial :: Telescope
-> Dom Type
-> Abs Telescope
-> [(A.Expr, A.Expr)]
-> ExceptT TCErr tcm (LHSState a)
splitPartial :: Telescope
-> Dom Type
-> Abs Telescope
-> [(Expr, Expr)]
-> ExceptT TCErr tcm (LHSState a)
splitPartial Telescope
delta1 Dom Type
dom Abs Telescope
adelta2 [(Expr, Expr)]
ts = do
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall t e. Dom' t e -> Bool
domIsFinite Dom Type
dom) forall a b. (a -> b) -> a -> b
$ forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ Dom Type -> TypeError
SplitOnPartial Dom Type
dom
Type
tInterval <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Type
primIntervalType
[Maybe Name]
names <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
tel forall a b. (a -> b) -> a -> b
$ do
LeftoverPatterns{patternVariables :: LeftoverPatterns -> IntMap [(Name, PatVarPosition)]
patternVariables = IntMap [(Name, PatVarPosition)]
vars} <- forall (m :: * -> *).
PureTCM m =>
[ProblemEq] -> m LeftoverPatterns
getLeftoverPatterns forall a b. (a -> b) -> a -> b
$ Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) [ProblemEq]
problemEqs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. Int -> [a] -> [a]
take (forall a. Sized a => a -> Int
size Telescope
delta1) forall a b. (a -> b) -> a -> b
$ forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ Telescope
-> IntMap [(Name, PatVarPosition)] -> ([Maybe Name], [AsBinding])
getUserVariableNames Telescope
tel IntMap [(Name, PatVarPosition)]
vars
Int
lhsCxtSize <- forall r (m :: * -> *). MonadReader r m => m r
ask
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"lhsCxtSize =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Int
lhsCxtSize
Context
newContext <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ [Maybe Name] -> Telescope -> TCM Context
computeLHSContext [Maybe Name]
names Telescope
delta1
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"newContext =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Context
newContext
let cpSub :: Substitution
cpSub = forall a. Int -> Substitution' a
raiseS forall a b. (a -> b) -> a -> b
$ forall a. Sized a => a -> Int
size Context
newContext forall a. Num a => a -> a -> a
- Int
lhsCxtSize
(Telescope
gamma,Substitution
sigma) <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
MonadAddContext m =>
Substitution -> (Context -> Context) -> m a -> m a
updateContext Substitution
cpSub (forall a b. a -> b -> a
const Context
newContext) forall a b. (a -> b) -> a -> b
$ do
[Term]
ts <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [(Expr, Expr)]
ts forall a b. (a -> b) -> a -> b
$ \ (Expr
t,Expr
u) -> do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"currentCxt =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *). MonadTCEnv m => m Context
getContext)
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"t, u (Expr) =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (Expr
t,Expr
u)
Term
t <- Expr -> Type -> TCMT IO Term
checkExpr Expr
t Type
tInterval
Term
u <- Expr -> Type -> TCMT IO Term
checkExpr Expr
u Type
tInterval
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"t, u =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty (Term
t, Term
u)
IntervalView
u <- forall (m :: * -> *). HasBuiltins m => Term -> m IntervalView
intervalView forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
u
case IntervalView
u of
IntervalView
IZero -> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primINeg forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> forall (f :: * -> *) a. Applicative f => a -> f a
pure Term
t
IntervalView
IOne -> forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
IntervalView
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError forall a b. (a -> b) -> a -> b
$ [Char]
"Only 0 or 1 allowed on the rhs of face"
Term
phi <- case [Term]
ts of
[] -> do
Term
a <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (forall t a. Type'' t a -> a
unEl forall a b. (a -> b) -> a -> b
$ forall t e. Dom' t e -> e
unDom Dom Type
dom)
QName
isone <- forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall (m :: * -> *). HasBuiltins m => BuiltinId -> m (Maybe QName)
getBuiltinName' BuiltinId
builtinIsOne
case Term
a of
Def QName
q [Apply Arg Term
phi] | QName
q forall a. Eq a => a -> a -> Bool
== QName
isone -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall e. Arg e -> e
unArg Arg Term
phi)
Term
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ Term -> TypeError
BuiltinMustBeIsOne Term
a
[Term]
_ -> forall (t :: * -> *) b a.
Foldable t =>
(b -> a -> b) -> b -> t a -> b
foldl (\ TCMT IO Term
x TCMT IO Term
y -> forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIMin forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term
x forall (m :: * -> *). Applicative m => m Term -> m Term -> m Term
<@> TCMT IO Term
y) forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primIOne (forall a b. (a -> b) -> [a] -> [b]
map forall (f :: * -> *) a. Applicative f => a -> f a
pure [Term]
ts)
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"phi =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
phi
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"phi =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Term
phi
Term
phi <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce Term
phi
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"phi (reduced) =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Term
phi
[(Telescope, Substitution)]
refined <- forall (m :: * -> *) a.
MonadConversion m =>
Term
-> (IntMap Bool -> Blocker -> Term -> m a)
-> (IntMap Bool -> Substitution -> m a)
-> m [a]
forallFaceMaps Term
phi (\ IntMap Bool
bs Blocker
m Term
t -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError forall a b. (a -> b) -> a -> b
$ [Char]
"face blocked on meta")
(\IntMap Bool
_ Substitution
sigma -> (,Substitution
sigma) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). (Applicative m, MonadTCEnv m) => m Telescope
getContextTelescope)
case [(Telescope, Substitution)]
refined of
[(Telescope
gamma,Substitution
sigma)] -> forall (m :: * -> *) a. Monad m => a -> m a
return (Telescope
gamma,Substitution
sigma)
[] -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError forall a b. (a -> b) -> a -> b
$ [Char]
"The face constraint is unsatisfiable."
[(Telescope, Substitution)]
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ [Char] -> TypeError
GenericError forall a b. (a -> b) -> a -> b
$ [Char]
"Cannot have disjunctions in a face constraint."
Term
itisone <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
m Term
primItIsOne
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.faces" Int
60 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> [Char]
show Substitution
sigma
let oix :: Int
oix = forall a. Sized a => a -> Int
size Abs Telescope
adelta2
o_n :: Int
o_n = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$
forall a. (a -> Bool) -> [a] -> Maybe Int
findIndex (\ NamedArg DeBruijnPattern
x -> case forall name a. Named name a -> a
namedThing (forall e. Arg e -> e
unArg NamedArg DeBruijnPattern
x) of
VarP PatternInfo
_ DBPatVar
x -> DBPatVar -> Int
dbPatVarIndex DBPatVar
x forall a. Eq a => a -> a -> Bool
== Int
oix
DeBruijnPattern
_ -> Bool
False) [NamedArg DeBruijnPattern]
ip
delta2' :: Telescope
delta2' = forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs Telescope
adelta2 Term
itisone
delta2 :: Telescope
delta2 = forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst Substitution
sigma Telescope
delta2'
mkConP :: Term -> DeBruijnPattern
mkConP (Con ConHead
c ConInfo
_ [])
= forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c (ConPatternInfo
noConPatternInfo { conPType :: Maybe (Arg Type)
conPType = forall a. a -> Maybe a
Just (forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
defaultArgInfo Type
tInterval)
, conPFallThrough :: Bool
conPFallThrough = Bool
True })
[]
mkConP (Var Int
i []) = forall x. PatternInfo -> x -> Pattern' x
VarP PatternInfo
defaultPatternInfo ([Char] -> Int -> DBPatVar
DBPatVar [Char]
"x" Int
i)
mkConP Term
_ = forall a. HasCallStack => a
__IMPOSSIBLE__
rho0 :: PatternSubstitution
rho0 = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Term -> DeBruijnPattern
mkConP Substitution
sigma
rho :: PatternSubstitution
rho = forall a. Int -> Substitution' a -> Substitution' a
liftS (forall a. Sized a => a -> Int
size Telescope
delta2) forall a b. (a -> b) -> a -> b
$ forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS (forall x. PatternInfo -> Term -> Pattern' x
DotP PatternInfo
defaultPatternInfo Term
itisone) PatternSubstitution
rho0
delta' :: Telescope
delta' = forall t. Abstract t => Telescope -> t -> t
abstract Telescope
gamma Telescope
delta2
eqs' :: [ProblemEq]
eqs' = forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho forall a b. (a -> b) -> a -> b
$ Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) [ProblemEq]
problemEqs
ip' :: [NamedArg DeBruijnPattern]
ip' = forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst PatternSubstitution
rho [NamedArg DeBruijnPattern]
ip
target' :: Arg Type
target' = forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho Arg Type
target
let problem' :: Problem a
problem' = forall o i. Lens' o i -> LensSet o i
set forall a. Lens' (Problem a) [ProblemEq]
problemEqs [ProblemEq]
eqs' Problem a
problem
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.partial" Int
60 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text (forall a. Show a => a -> [Char]
show Problem a
problem')
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall a. LHSState a -> TCM (LHSState a)
updateLHSState (forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
LHSState Telescope
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' ([Maybe Int]
psplit forall a. [a] -> [a] -> [a]
++ [forall a. a -> Maybe a
Just Int
o_n]) Bool
ixsplit)
splitLit :: Telescope
-> Dom Type
-> Abs Telescope
-> Literal
-> ExceptT TCErr tcm (LHSState a)
splitLit :: Telescope
-> Dom Type
-> Abs Telescope
-> Literal
-> ExceptT TCErr tcm (LHSState a)
splitLit Telescope
delta1 dom :: Dom Type
dom@Dom{domInfo :: forall t e. Dom' t e -> ArgInfo
domInfo = ArgInfo
info, unDom :: forall t e. Dom' t e -> e
unDom = Type
a} Abs Telescope
adelta2 Literal
lit = do
let delta2 :: Telescope
delta2 = forall a. Subst a => Abs a -> SubstArg a -> a
absApp Abs Telescope
adelta2 (Literal -> Term
Lit Literal
lit)
delta' :: Telescope
delta' = forall t. Abstract t => Telescope -> t -> t
abstract Telescope
delta1 Telescope
delta2
rho :: PatternSubstitution
rho = forall a. DeBruijn a => Int -> a -> Substitution' a
singletonS (forall a. Sized a => a -> Int
size Telescope
delta2) (forall a. Literal -> Pattern' a
litP Literal
lit)
eqs' :: [ProblemEq]
eqs' = forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho forall a b. (a -> b) -> a -> b
$ Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) [ProblemEq]
problemEqs
ip' :: [NamedArg DeBruijnPattern]
ip' = forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst PatternSubstitution
rho [NamedArg DeBruijnPattern]
ip
target' :: Arg Type
target' = forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho Arg Type
target
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. LensRelevance a => a -> Bool
usableRelevance ArgInfo
info) forall a b. (a -> b) -> a -> b
$
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ Dom Type -> TypeError
SplitOnIrrelevant Dom Type
dom
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (forall (m :: * -> *) a.
(HasOptions m, LensCohesion a) =>
a -> m Bool
splittableCohesion ArgInfo
info) forall a b. (a -> b) -> a -> b
$
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ Dom Type -> TypeError
SplitOnUnusableCohesion Dom Type
dom
forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadConversion m => Type -> Type -> m ()
equalType Type
a forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *).
(HasBuiltins m, MonadError TCErr m, MonadTCEnv m, ReadTCState m) =>
Literal -> m Type
litType Literal
lit
let problem' :: Problem a
problem' = forall o i. Lens' o i -> LensSet o i
set forall a. Lens' (Problem a) [ProblemEq]
problemEqs [ProblemEq]
eqs' Problem a
problem
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall a. LHSState a -> TCM (LHSState a)
updateLHSState (forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
LHSState Telescope
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target' [Maybe Int]
psplit Bool
ixsplit)
splitCon :: Telescope
-> Dom Type
-> Abs Telescope
-> A.Pattern
-> Maybe AmbiguousQName
-> ExceptT TCErr tcm (LHSState a)
splitCon :: Telescope
-> Dom Type
-> Abs Telescope
-> Pattern
-> Maybe AmbiguousQName
-> ExceptT TCErr tcm (LHSState a)
splitCon Telescope
delta1 dom :: Dom Type
dom@Dom{domInfo :: forall t e. Dom' t e -> ArgInfo
domInfo = ArgInfo
info, unDom :: forall t e. Dom' t e -> e
unDom = Type
a} Abs Telescope
adelta2 Pattern
focusPat Maybe AmbiguousQName
ambC = do
let delta2 :: Telescope
delta2 = forall a. Subst a => Abs a -> a
absBody Abs Telescope
adelta2
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
10 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"checking lhs"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"tel =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
tel
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"rel =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Applicative m => [Char] -> m Doc
text (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. LensRelevance a => a -> Relevance
getRelevance ArgInfo
info)
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"mod =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Applicative m => [Char] -> m Doc
text (forall a. Show a => a -> [Char]
show forall a b. (a -> b) -> a -> b
$ forall a. LensModality a => a -> Modality
getModality ArgInfo
info)
]
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
15 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"split problem"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"delta1 = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta1
, TCMT IO Doc
"a = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
a)
, TCMT IO Doc
"delta2 = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1
(forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext ([Char]
"x" :: String, Dom Type
dom) (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta2))
]
]
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.lhs.split" Int
30 forall a b. (a -> b) -> a -> b
$ [Char]
"split ConP: relevance is " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. LensRelevance a => a -> Relevance
getRelevance ArgInfo
info)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a. LensRelevance a => a -> Bool
usableRelevance ArgInfo
info) forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ Dom Type -> TypeError
SplitOnIrrelevant Dom Type
dom
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (forall (m :: * -> *) a.
(HasOptions m, LensCohesion a) =>
a -> m Bool
splittableCohesion ArgInfo
info) forall a b. (a -> b) -> a -> b
$
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ Dom Type -> TypeError
SplitOnUnusableCohesion Dom Type
dom
let genTrx :: Maybe NoLeftInv
genTrx = forall a. Bool -> a -> Maybe a
boolToMaybe ((forall a. LensCohesion a => a -> Cohesion
getCohesion ArgInfo
info forall a. Eq a => a -> a -> Bool
== Cohesion
Flat)) NoLeftInv
SplitOnFlat
(DataOrRecord
dr, QName
d, Args
pars, Args
ixs) <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(MonadTCM m, PureTCM m) =>
Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
isDataOrRecordType Type
a
let isRec :: Bool
isRec = case DataOrRecord
dr of
IsData{} -> Bool
False
IsRecord{} -> Bool
True
forall (m :: * -> *).
MonadTCError m =>
QName -> DataOrRecord -> m ()
checkMatchingAllowed QName
d DataOrRecord
dr
forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a ty.
(MonadTCM m, PureTCM m, MonadError TCErr m, LensSort a,
PrettyTCM a, LensSort ty, PrettyTCM ty) =>
DataOrRecord -> a -> Telescope -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr Type
a Telescope
delta2 (forall a. a -> Maybe a
Just Arg Type
target)
TCMT IO UnificationResult -> TCMT IO UnificationResult
withKIfStrict <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (forall a. LensSort a => a -> Sort' Term
getSort Type
a) forall (f :: * -> *) a b. Functor f => f a -> (a -> b) -> f b
<&> \ Sort' Term
dsort ->
forall b a. IsBool b => b -> (a -> a) -> a -> a
applyWhen (forall t. Sort' t -> Bool
isStrictDataSort Sort' Term
dsort) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a b.
MonadTCEnv m =>
Lens' TCEnv a -> (a -> a) -> m b -> m b
locallyTC Lens' TCEnv Bool
eSplitOnStrict forall a b. (a -> b) -> a -> b
$ forall a b. a -> b -> a
const Bool
True
(ConHead
c :: ConHead, Type
b :: Type) <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 forall a b. (a -> b) -> a -> b
$ case Maybe AmbiguousQName
ambC of
Just AmbiguousQName
ambC -> AmbiguousQName -> QName -> Args -> TCM (ConHead, Type)
disambiguateConstructor AmbiguousQName
ambC QName
d Args
pars
Maybe AmbiguousQName
Nothing -> QName -> Args -> Type -> TCM (ConHead, Type)
getRecordConstructor QName
d Args
pars Type
a
case Pattern
focusPat of
A.ConP ConPatInfo
cpi AmbiguousQName
_ [NamedArg Pattern]
_ | ConPatInfo -> ConPatLazy
conPatLazy ConPatInfo
cpi forall a. Eq a => a -> a -> Bool
== ConPatLazy
ConPatLazy ->
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (forall (m :: * -> *). HasConstInfo m => QName -> m Bool
isEtaRecord QName
d) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ Pattern -> TypeError
ForcedConstructorNotInstantiated Pattern
focusPat
Pattern
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(TelV Telescope
gamma (El Sort' Term
_ Term
ctarget), Boundary
boundary) <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). PureTCM m => Type -> m (TelV Type, Boundary)
telViewPathBoundaryP Type
b
let Def QName
d' Elims
es' = Term
ctarget
cixs :: Args
cixs = forall a. Int -> [a] -> [a]
drop (forall a. Sized a => a -> Int
size Args
pars) forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es'
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split.con" Int
50 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
" boundary = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Boundary
boundary
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (QName
d forall a. Eq a => a -> a -> Bool
== QName
d') forall a. HasCallStack => a
__IMPOSSIBLE__
Telescope
gamma <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ case Pattern
focusPat of
A.ConP ConPatInfo
_ AmbiguousQName
_ [NamedArg Pattern]
ps -> do
[NamedArg Pattern]
ps <- forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
MonadTrace m) =>
ExpandHidden
-> [NamedArg Pattern] -> Telescope -> m [NamedArg Pattern]
insertImplicitPatterns ExpandHidden
ExpandLast [NamedArg Pattern]
ps Telescope
gamma
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [NamedArg Pattern] -> Telescope -> Telescope
useNamesFromPattern [NamedArg Pattern]
ps Telescope
gamma
A.RecP PatInfo
_ [FieldAssignment' Pattern]
fs -> do
[Arg Name]
axs <- forall a b. (a -> b) -> [a] -> [b]
map forall t a. Dom' t a -> Arg a
argFromDom forall b c a. (b -> c) -> (a -> b) -> a -> c
. Defn -> [Dom' Term Name]
recordFieldNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Defn
theDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
[NamedArg Pattern]
ps <- forall a.
HasRange a =>
QName
-> (Name -> a)
-> [FieldAssignment' a]
-> [Arg Name]
-> TCM [NamedArg a]
insertMissingFieldsFail QName
d (forall a b. a -> b -> a
const forall a b. (a -> b) -> a -> b
$ forall e. PatInfo -> Pattern' e
A.WildP PatInfo
patNoRange) [FieldAssignment' Pattern]
fs [Arg Name]
axs
[NamedArg Pattern]
ps <- forall (m :: * -> *).
(PureTCM m, MonadError TCErr m, MonadFresh NameId m,
MonadTrace m) =>
ExpandHidden
-> [NamedArg Pattern] -> Telescope -> m [NamedArg Pattern]
insertImplicitPatterns ExpandHidden
ExpandLast [NamedArg Pattern]
ps Telescope
gamma
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [NamedArg Pattern] -> Telescope -> Telescope
useNamesFromPattern [NamedArg Pattern]
ps Telescope
gamma
Pattern
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
let updMod :: Modality -> Modality
updMod = Modality -> Modality -> Modality
composeModality (forall a. LensModality a => a -> Modality
getModality ArgInfo
info)
Telescope
gamma <- forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. LensModality a => (Modality -> Modality) -> a -> a
mapModality Modality -> Modality
updMod forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope
gamma
Type
da <- (Type -> Args -> Type
`piApply` Args
pars) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
30 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
" da = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
da
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
15 forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1 forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep [ TCMT IO Doc
"preparing to unify"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"c =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ConHead
c forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
":" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
b
, TCMT IO Doc
"d =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (QName -> Elims -> Term
Def QName
d (forall a b. (a -> b) -> [a] -> [b]
map forall a. Arg a -> Elim' a
Apply Args
pars)) forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> TCMT IO Doc
":" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
da
, TCMT IO Doc
"isRec =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Show a => a -> [Char]
show) Bool
isRec
, TCMT IO Doc
"gamma =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
gamma
, TCMT IO Doc
"pars =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets (forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate forall (m :: * -> *). Applicative m => m Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Args
pars)
, TCMT IO Doc
"ixs =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets (forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate forall (m :: * -> *). Applicative m => m Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Args
ixs)
, TCMT IO Doc
"cixs =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
gamma (forall (m :: * -> *). Functor m => m Doc -> m Doc
brackets (forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Semigroup (m Doc), Foldable t) =>
m Doc -> t (m Doc) -> [m Doc]
punctuate forall (m :: * -> *). Applicative m => m Doc
comma forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Args
cixs))
]
]
[IsForced]
cforced <- forall (m :: * -> *) a. Monad m => m Bool -> m a -> m a -> m a
ifM (forall (m :: * -> *) a. MonadTCEnv m => Lens' TCEnv a -> m a
viewTC Lens' TCEnv Bool
eMakeCase) (forall (m :: * -> *) a. Monad m => a -> m a
return []) forall a b. (a -> b) -> a -> b
$
Definition -> [IsForced]
defForced forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
c)
let delta1Gamma :: Telescope
delta1Gamma = Telescope
delta1 forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
gamma
da' :: Type
da' = forall a. Subst a => Int -> a -> a
raise (forall a. Sized a => a -> Int
size Telescope
gamma) Type
da
ixs' :: Args
ixs' = forall a. Subst a => Int -> a -> a
raise (forall a. Sized a => a -> Int
size Telescope
gamma) Args
ixs
forced :: [IsForced]
forced = forall a. Int -> a -> [a]
replicate (forall a. Sized a => a -> Int
size Telescope
delta1) IsForced
NotForced forall a. [a] -> [a] -> [a]
++ [IsForced]
cforced
let flex :: FlexibleVars
flex = [IsForced] -> Telescope -> FlexibleVars
allFlexVars [IsForced]
forced forall a b. (a -> b) -> a -> b
$ Telescope
delta1Gamma
Type
da' <- forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1Gamma forall a b. (a -> b) -> a -> b
$ do
let updCoh :: Cohesion -> Cohesion
updCoh = Cohesion -> Cohesion -> Cohesion
composeCohesion (forall a. LensCohesion a => a -> Cohesion
getCohesion ArgInfo
info)
TelV Telescope
tel Type
dt <- forall (m :: * -> *).
(MonadReduce m, MonadAddContext m) =>
Type -> m (TelV Type)
telView Type
da'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall t. Abstract t => Telescope -> t -> t
abstract (forall a. LensCohesion a => (Cohesion -> Cohesion) -> a -> a
mapCohesion Cohesion -> Cohesion
updCoh forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Telescope
tel) Type
a
let stuck :: Maybe Blocker
-> [UnificationFailure] -> ExceptT TCErr tcm (LHSState a)
stuck Maybe Blocker
b [UnificationFailure]
errs = forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ SplitError -> TypeError
SplitError forall a b. (a -> b) -> a -> b
$
Maybe Blocker
-> QName
-> Telescope
-> Args
-> Args
-> [UnificationFailure]
-> SplitError
UnificationStuck Maybe Blocker
b (ConHead -> QName
conName ConHead
c) (Telescope
delta1 forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
gamma) Args
cixs Args
ixs' [UnificationFailure]
errs
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (TCMT IO UnificationResult -> TCMT IO UnificationResult
withKIfStrict forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
(PureTCM m, MonadBench m, BenchPhase m ~ Phase,
MonadError TCErr m) =>
Maybe NoLeftInv
-> Telescope
-> FlexibleVars
-> Type
-> Args
-> Args
-> m UnificationResult
unifyIndices Maybe NoLeftInv
genTrx Telescope
delta1Gamma FlexibleVars
flex Type
da' Args
cixs Args
ixs') forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
NoUnify NegativeUnification
neg -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall a b. (a -> b) -> a -> b
$ QName -> NegativeUnification -> TypeError
ImpossibleConstructor (ConHead -> QName
conName ConHead
c) NegativeUnification
neg
UnifyBlocked Blocker
block -> Maybe Blocker
-> [UnificationFailure] -> ExceptT TCErr tcm (LHSState a)
stuck (forall a. a -> Maybe a
Just Blocker
block) []
UnifyStuck [UnificationFailure]
errs -> Maybe Blocker
-> [UnificationFailure] -> ExceptT TCErr tcm (LHSState a)
stuck forall a. Maybe a
Nothing [UnificationFailure]
errs
Unifies (Telescope
delta1',PatternSubstitution
rho0,[NamedArg DeBruijnPattern]
es) -> do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
15 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"unification successful"
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"delta1' =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta1'
, TCMT IO Doc
"rho0 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM PatternSubstitution
rho0)
, TCMT IO Doc
"es =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall a b. (a -> b) -> a -> b
$ (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap) DeBruijnPattern -> Term
patternToTerm [NamedArg DeBruijnPattern]
es)
]
let (PatternSubstitution
rho1,PatternSubstitution
rho2) = forall a.
Int -> Substitution' a -> (Substitution' a, Substitution' a)
splitS (forall a. Sized a => a -> Int
size Telescope
gamma) PatternSubstitution
rho0
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"rho1 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM PatternSubstitution
rho1
, TCMT IO Doc
"rho2 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM PatternSubstitution
rho2
]
let a' :: Type
a' = forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho1 Type
a
let cpi :: ConPatternInfo
cpi = ConPatternInfo { conPInfo :: PatternInfo
conPInfo = PatOrigin -> [Name] -> PatternInfo
PatternInfo PatOrigin
PatOCon []
, conPRecord :: Bool
conPRecord = Bool
isRec
, conPFallThrough :: Bool
conPFallThrough = Bool
False
, conPType :: Maybe (Arg Type)
conPType = forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
info Type
a'
, conPLazy :: Bool
conPLazy = Bool
False }
let crho :: DeBruijnPattern
crho = forall x.
ConHead -> ConPatternInfo -> [NamedArg (Pattern' x)] -> Pattern' x
ConP ConHead
c ConPatternInfo
cpi forall a b. (a -> b) -> a -> b
$ forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst PatternSubstitution
rho0 forall a b. (a -> b) -> a -> b
$ (forall a.
DeBruijn a =>
Telescope -> Boundary -> [NamedArg (Pattern' a)]
telePatterns Telescope
gamma Boundary
boundary)
rho3 :: PatternSubstitution
rho3 = forall a. DeBruijn a => a -> Substitution' a -> Substitution' a
consS DeBruijnPattern
crho PatternSubstitution
rho1
delta2' :: Telescope
delta2' = forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho3 Telescope
delta2
delta' :: Telescope
delta' = Telescope
delta1' forall t. Abstract t => Telescope -> t -> t
`abstract` Telescope
delta2'
rho :: PatternSubstitution
rho = forall a. Int -> Substitution' a -> Substitution' a
liftS (forall a. Sized a => a -> Int
size Telescope
delta2) PatternSubstitution
rho3
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
20 forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"crho =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM DeBruijnPattern
crho
, TCMT IO Doc
"rho3 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM PatternSubstitution
rho3
, TCMT IO Doc
"delta2' =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta2'
]
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
70 forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta1' forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"crho =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty DeBruijnPattern
crho
, TCMT IO Doc
"rho3 =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty PatternSubstitution
rho3
, TCMT IO Doc
"delta2' =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty Telescope
delta2'
]
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
15 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"delta' =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Telescope
delta'
, TCMT IO Doc
"rho =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta' (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM PatternSubstitution
rho)
]
let ip' :: [NamedArg DeBruijnPattern]
ip' = forall a. Subst a => Substitution' (SubstArg a) -> a -> a
applySubst PatternSubstitution
rho [NamedArg DeBruijnPattern]
ip
target' :: Arg Type
target' = forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho Arg Type
target
let eqs' :: [ProblemEq]
eqs' = forall a. TermSubst a => PatternSubstitution -> a -> a
applyPatSubst PatternSubstitution
rho forall a b. (a -> b) -> a -> b
$ Problem a
problem forall o i. o -> Lens' o i -> i
^. forall a. Lens' (Problem a) [ProblemEq]
problemEqs
problem' :: Problem a
problem' = forall o i. Lens' o i -> LensSet o i
set forall a. Lens' (Problem a) [ProblemEq]
problemEqs [ProblemEq]
eqs' Problem a
problem
Quantity
cq <- forall a. LensQuantity a => a -> Quantity
getQuantity forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *).
(ReadTCState m, HasConstInfo m) =>
QName -> m Definition
getOriginalConstInfo (ConHead -> QName
conName ConHead
c)
let target'' :: Arg Type
target'' = forall a. LensQuantity a => (Quantity -> Quantity) -> a -> a
mapQuantity Quantity -> Quantity
updResMod Arg Type
target'
where
erased :: Bool
erased = case forall a. LensQuantity a => a -> Quantity
getQuantity ArgInfo
info of
Quantity0{} -> Bool
True
Quantity1{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Quantityω{} -> Bool
False
updResMod :: Quantity -> Quantity
updResMod Quantity
q =
case Quantity
cq of
Quantity
_ | Bool
erased -> Quantity
q
Quantity0{} -> Quantity -> Quantity -> Quantity
composeQuantity Quantity
cq Quantity
q
Quantity1{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Quantityω{} -> Quantity
q
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext Telescope
delta' forall a b. (a -> b) -> a -> b
$ do
Bool
withoutK <- PragmaOptions -> Bool
optWithoutK forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
Bool
cubical <- PragmaOptions -> Bool
optCubicalCompatible forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasOptions m => m PragmaOptions
pragmaOptions
Modality
mod <- forall (m :: * -> *). MonadTCEnv m => m Modality
currentModality
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when ((Bool
withoutK Bool -> Bool -> Bool
|| Bool
cubical) Bool -> Bool -> Bool
&& Bool -> Bool
not (forall a. Null a => a -> Bool
null Args
ixs)) forall a b. (a -> b) -> a -> b
$
Modality
-> PatternSubstitution -> Int -> Telescope -> Type -> TCMT IO ()
conSplitModalityCheck Modality
mod PatternSubstitution
rho (forall (t :: * -> *) a. Foldable t => t a -> Int
length Telescope
delta2) Telescope
tel (forall e. Arg e -> e
unArg Arg Type
target)
LHSState a
st' <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall a. LHSState a -> TCM (LHSState a)
updateLHSState forall a b. (a -> b) -> a -> b
$ forall a.
Telescope
-> [NamedArg DeBruijnPattern]
-> Problem a
-> Arg Type
-> [Maybe Int]
-> Bool
-> LHSState a
LHSState Telescope
delta' [NamedArg DeBruijnPattern]
ip' Problem a
problem' Arg Type
target'' [Maybe Int]
psplit (Bool
ixsplit Bool -> Bool -> Bool
|| Bool -> Bool
not (forall a. Null a => a -> Bool
null Args
ixs))
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.top" Int
12 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ TCMT IO Doc
"new problem from rest"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ TCMT IO Doc
"delta' =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (LHSState a
st' forall o i. o -> Lens' o i -> i
^. forall a. Lens' (LHSState a) Telescope
lhsTel)
, TCMT IO Doc
"eqs' =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext (LHSState a
st' forall o i. o -> Lens' o i -> i
^. forall a. Lens' (LHSState a) Telescope
lhsTel) (forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall a b. (a -> b) -> a -> b
$ LHSState a
st' forall o i. o -> Lens' o i -> i
^. (forall a. Lens' (LHSState a) (Problem a)
lhsProblem forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Lens' (Problem a) [ProblemEq]
problemEqs))
, TCMT IO Doc
"ip' =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall b (m :: * -> *) a.
(AddContext b, MonadAddContext m) =>
b -> m a -> m a
addContext (LHSState a
st' forall o i. o -> Lens' o i -> i
^. forall a. Lens' (LHSState a) Telescope
lhsTel) (forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty forall a b. (a -> b) -> a -> b
$ LHSState a
st' forall o i. o -> Lens' o i -> i
^. forall a. Lens' (LHSState a) [NamedArg DeBruijnPattern]
lhsOutPat)
]
]
forall (m :: * -> *) a. Monad m => a -> m a
return LHSState a
st'
checkMatchingAllowed :: (MonadTCError m)
=> QName
-> DataOrRecord
-> m ()
checkMatchingAllowed :: forall (m :: * -> *).
MonadTCError m =>
QName -> DataOrRecord -> m ()
checkMatchingAllowed QName
d = \case
IsRecord InductionAndEta { recordInduction :: InductionAndEta -> Maybe Induction
recordInduction=Maybe Induction
ind, recordEtaEquality :: InductionAndEta -> EtaEquality
recordEtaEquality=EtaEquality
eta }
| Just Induction
CoInductive <- Maybe Induction
ind -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$
[Char] -> TypeError
GenericError [Char]
"Pattern matching on coinductive types is not allowed"
| Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ forall a. PatternMatchingAllowed a => a -> Bool
patternMatchingAllowed EtaEquality
eta -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ QName -> TypeError
SplitOnNonEtaRecord QName
d
| Bool
otherwise -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
DataOrRecord
IsData -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
suspendErrors :: (MonadTCM m, MonadError TCErr m) => TCM a -> m a
suspendErrors :: forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors TCM a
f = do
Either TCErr a
ok <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ (forall a b. b -> Either a b
Right forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> TCM a
f) forall e (m :: * -> *) a.
MonadError e m =>
m a -> (e -> m a) -> m a
`catchError` (forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. a -> Either a b
Left)
forall a c b. (a -> c) -> (b -> c) -> Either a b -> c
either forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (m :: * -> *) a. Monad m => a -> m a
return Either TCErr a
ok
softTypeError :: (HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) => TypeError -> m a
softTypeError :: forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError TypeError
err = forall b. HasCallStack => (CallStack -> b) -> b
withCallerCallStack forall a b. (a -> b) -> a -> b
$ \CallStack
loc ->
forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall (m :: * -> *) a.
MonadTCError m =>
CallStack -> TypeError -> m a
typeError' CallStack
loc TypeError
err
hardTypeError :: (HasCallStack, MonadTCM m) => TypeError -> m a
hardTypeError :: forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError = forall b. HasCallStack => (CallStack -> b) -> b
withCallerCallStack forall a b. (a -> b) -> a -> b
$ \CallStack
loc -> forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a.
MonadTCError m =>
CallStack -> TypeError -> m a
typeError' CallStack
loc
type DataOrRecord = DataOrRecord' InductionAndEta
isDataOrRecordType
:: (MonadTCM m, PureTCM m)
=> Type
-> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
isDataOrRecordType :: forall (m :: * -> *).
(MonadTCM m, PureTCM m) =>
Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
isDataOrRecordType Type
a0 = forall t (m :: * -> *) a.
(Reduce t, IsMeta t, MonadReduce m) =>
t -> (Blocker -> t -> m a) -> (NotBlocked -> t -> m a) -> m a
ifBlocked Type
a0 Blocker
-> Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
blocked forall a b. (a -> b) -> a -> b
$ \case
NotBlocked
ReallyNotBlocked -> \ Type
a -> case forall t a. Type'' t a -> a
unEl Type
a of
Def QName
d Elims
es -> forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (Definition -> Defn
theDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Datatype{dataPars :: Defn -> Int
dataPars = Int
np} -> do
forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM (forall (m :: * -> *). (MonadTCM m, MonadReduce m) => Type -> m Bool
isInterval Type
a) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
let (Args
pars, Args
ixs) = forall a. Int -> [a] -> ([a], [a])
splitAt Int
np forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. DataOrRecord' p
IsData, QName
d, Args
pars, Args
ixs)
Record{ Maybe Induction
recInduction :: Defn -> Maybe Induction
recInduction :: Maybe Induction
recInduction, EtaEquality
recEtaEquality' :: Defn -> EtaEquality
recEtaEquality' :: EtaEquality
recEtaEquality' } -> do
let pars :: Args
pars = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
forall (m :: * -> *) a. Monad m => a -> m a
return (forall p. p -> DataOrRecord' p
IsRecord InductionAndEta {recordInduction :: Maybe Induction
recordInduction=Maybe Induction
recInduction, recordEtaEquality :: EtaEquality
recordEtaEquality=EtaEquality
recEtaEquality' }, QName
d, Args
pars, [])
AbstractDefn{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall a b. (a -> b) -> a -> b
$ QName -> TypeError
SplitOnAbstract QName
d
Axiom{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
DataOrRecSig{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall a b. (a -> b) -> a -> b
$ QName -> TypeError
SplitOnUnchecked QName
d
Function{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
Constructor{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Primitive{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
PrimitiveSort{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
GeneralizableVar{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Var{} -> forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
MetaV{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Pi{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
Sort{} -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
Lam{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Lit{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Con{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Level{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
DontCare{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
Dummy [Char]
s Elims
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadDebug m) =>
[Char] -> m a
__IMPOSSIBLE_VERBOSE__ [Char]
s
StuckOn{} -> \ Type
_a -> forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
AbsurdMatch{} -> \ Type
_a -> forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
MissingClauses{} -> \ Type
_a -> forall (m :: * -> *) a.
(HasCallStack, MonadTCM m) =>
TypeError -> m a
hardTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< ExceptT TCErr m TypeError
notData
Underapplied{} -> forall a. HasCallStack => a
__IMPOSSIBLE__
where
notData :: ExceptT TCErr m TypeError
notData = forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ SplitError -> TypeError
SplitError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Closure Type -> SplitError
NotADatatype forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Type
a0
blocked :: Blocker
-> Type -> ExceptT TCErr m (DataOrRecord, QName, Args, Args)
blocked Blocker
b Type
_a = forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ SplitError -> TypeError
SplitError forall b c a. (b -> c) -> (a -> b) -> a -> c
. Blocker -> Closure Type -> SplitError
BlockedType Blocker
b forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) a.
(MonadTCEnv m, ReadTCState m) =>
a -> m (Closure a)
buildClosure Type
a0
getRecordConstructor
:: QName
-> Args
-> Type
-> TCM (ConHead, Type)
getRecordConstructor :: QName -> Args -> Type -> TCM (ConHead, Type)
getRecordConstructor QName
d Args
pars Type
a = do
ConHead
con <- (Definition -> Defn
theDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Record{recConHead :: Defn -> ConHead
recConHead = ConHead
con} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a. KillRange a => KillRangeT a
killRange ConHead
con
Defn
_ -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ Type -> TypeError
ShouldBeRecordType Type
a
Type
b <- (Type -> Args -> Type
`piApply` Args
pars) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo (ConHead -> QName
conName ConHead
con)
forall (m :: * -> *) a. Monad m => a -> m a
return (ConHead
con, Type
b)
disambiguateProjection
:: Maybe Hiding
-> AmbiguousQName
-> Arg Type
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
disambiguateProjection :: Maybe Hiding
-> AmbiguousQName
-> Arg Type
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
disambiguateProjection Maybe Hiding
h ambD :: AmbiguousQName
ambD@(AmbQ List1 QName
ds) Arg Type
b = do
forall (m :: * -> *) a b.
Monad m =>
m (Maybe a) -> m b -> (a -> m b) -> m b
caseMaybeM (forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *).
PureTCM m =>
Type -> m (Maybe (QName, Args, Defn))
isRecordType forall a b. (a -> b) -> a -> b
$ forall e. Arg e -> e
unArg Arg Type
b) TCM (QName, Bool, QName, Arg Type, ArgInfo)
notRecord forall a b. (a -> b) -> a -> b
$ \(QName
r, Args
vs, Defn
def) -> case Defn
def of
Record{ recFields :: Defn -> [Dom' Term QName]
recFields = [Dom' Term QName]
fs, Maybe Induction
recInduction :: Maybe Induction
recInduction :: Defn -> Maybe Induction
recInduction, recEtaEquality' :: Defn -> EtaEquality
recEtaEquality' = EtaEquality
eta } -> do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"we are of record type r = " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
r
, forall (m :: * -> *). Applicative m => [Char] -> m Doc
text [Char]
"applied to parameters vs = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Args
vs
, forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"and have fields fs = " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow (forall a b. (a -> b) -> [a] -> [b]
map forall t a. Dom' t a -> Arg a
argFromDom [Dom' Term QName]
fs)
]
let comatching :: Bool
comatching = Maybe Induction
recInduction forall a. Eq a => a -> a -> Bool
== forall a. a -> Maybe a
Just Induction
CoInductive
Bool -> Bool -> Bool
|| forall a. CopatternMatchingAllowed a => a -> Bool
copatternMatchingAllowed EtaEquality
eta
Bool
-> [Dom' Term QName]
-> QName
-> Args
-> Bool
-> (([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
-> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
tryDisambiguate Bool
False [Dom' Term QName]
fs QName
r Args
vs Bool
comatching forall a b. (a -> b) -> a -> b
$ \ ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
_ ->
Bool
-> [Dom' Term QName]
-> QName
-> Args
-> Bool
-> (([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
-> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
tryDisambiguate Bool
True [Dom' Term QName]
fs QName
r Args
vs Bool
comatching forall a b. (a -> b) -> a -> b
$ \case
([] , [] ) -> forall a. HasCallStack => a
__IMPOSSIBLE__
(TCErr
err:[TCErr]
_, [] ) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
([TCErr]
_ , disambs :: [(QName, (Arg Type, ArgInfo, Maybe TCState))]
disambs@((QName
d,(Arg Type, ArgInfo, Maybe TCState)
a):[(QName, (Arg Type, ArgInfo, Maybe TCState))]
_)) -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ QName -> [QName] -> TypeError
AmbiguousProjection QName
d (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(QName, (Arg Type, ArgInfo, Maybe TCState))]
disambs)
Defn
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
where
tryDisambiguate :: Bool
-> [Dom' Term QName]
-> QName
-> Args
-> Bool
-> (([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
-> TCM (QName, Bool, QName, Arg Type, ArgInfo))
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
tryDisambiguate Bool
constraintsOk [Dom' Term QName]
fs QName
r Args
vs Bool
comatching ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
failure = do
NonEmpty (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState)))
disambiguations <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [Dom' Term QName]
-> QName
-> Args
-> QName
-> ExceptT
TCErr (TCMT IO) (QName, (Arg Type, ArgInfo, Maybe TCState))
tryProj Bool
constraintsOk [Dom' Term QName]
fs QName
r Args
vs) List1 QName
ds
case forall a b. List1 (Either a b) -> ([a], [b])
List1.partitionEithers NonEmpty (Either TCErr (QName, (Arg Type, ArgInfo, Maybe TCState)))
disambiguations of
([TCErr]
_ , (QName
d, (Arg Type
a, ArgInfo
ai, Maybe TCState
mst)) : [(QName, (Arg Type, ArgInfo, Maybe TCState))]
disambs) | Bool
constraintsOk forall a. Ord a => a -> a -> Bool
<= forall a. Null a => a -> Bool
null [(QName, (Arg Type, ArgInfo, Maybe TCState))]
disambs -> do
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall (m :: * -> *). MonadTCState m => TCState -> m ()
putTC Maybe TCState
mst
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ QName -> TCMT IO ()
storeDisambiguatedProjection QName
d
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
d, Bool
comatching, QName
r, Arg Type
a, ArgInfo
ai)
([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
other -> ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
-> TCM (QName, Bool, QName, Arg Type, ArgInfo)
failure ([TCErr], [(QName, (Arg Type, ArgInfo, Maybe TCState))])
other
notRecord :: TCM (QName, Bool, QName, Arg Type, ArgInfo)
notRecord = forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj forall a b. (a -> b) -> a -> b
$ forall a. NonEmpty a -> a
List1.head List1 QName
ds
wrongProj :: (MonadTCM m, MonadError TCErr m, ReadTCState m) => QName -> m a
wrongProj :: forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d = forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ if AmbiguousQName -> Bool
isAmbiguous AmbiguousQName
ambD then Arg Type -> Bool -> QName -> TypeError
CannotEliminateWithProjection Arg Type
b Bool
True forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). MonadPretty m => QName -> m QName
dropTopLevelModule QName
d
else forall (f :: * -> *) a. Applicative f => a -> f a
pure forall a b. (a -> b) -> a -> b
$ Arg Type -> Bool -> QName -> TypeError
CannotEliminateWithProjection Arg Type
b Bool
False QName
d
tryProj
:: Bool
-> [Dom QName]
-> QName
-> Args
-> QName
-> ExceptT TCErr TCM (QName, (Arg Type, ArgInfo, Maybe TCState))
tryProj :: Bool
-> [Dom' Term QName]
-> QName
-> Args
-> QName
-> ExceptT
TCErr (TCMT IO) (QName, (Arg Type, ArgInfo, Maybe TCState))
tryProj Bool
constraintsOk [Dom' Term QName]
fs QName
r Args
vs QName
d0 = forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Maybe Projection)
isProjection QName
d0 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Maybe Projection
Nothing -> forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d0
Just Projection
proj -> do
let d :: QName
d = Projection -> QName
projOrig Projection
proj
QName
qr <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Projection -> Maybe QName
projProper Projection
proj
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (forall a. Null a => a -> Bool
null forall a b. (a -> b) -> a -> b
$ Projection -> ProjLams
projLams Projection
proj) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> [Char] -> m ()
reportSLn [Char]
"tc.lhs.split" Int
90 [Char]
"we are a projection pattern"
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"proj d0 = " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
d0
, forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"original proj d = " forall a. [a] -> [a] -> [a]
++ forall a. Pretty a => a -> [Char]
prettyShow QName
d
]
Dom' Term QName
argd <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m, ReadTCState m) =>
QName -> m a
wrongProj QName
d) forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Maybe a
List.find ((QName
d forall a. Eq a => a -> a -> Bool
==) forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t e. Dom' t e -> e
unDom) [Dom' Term QName]
fs
let ai :: ArgInfo
ai = forall a. LensArgInfo a => a -> ArgInfo
getArgInfo Dom' Term QName
argd
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat
[ forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"original proj relevance = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. LensRelevance a => a -> Relevance
getRelevance Dom' Term QName
argd)
, forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall a b. (a -> b) -> a -> b
$ [Char]
"original proj quantity = " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> [Char]
show (forall a. LensQuantity a => a -> Quantity
getQuantity Dom' Term QName
argd)
]
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (forall a b. Maybe a -> b -> (a -> b) -> b
caseMaybe Maybe Hiding
h Bool
True forall a b. (a -> b) -> a -> b
$ forall a b. (LensHiding a, LensHiding b) => a -> b -> Bool
sameHiding forall a b. (a -> b) -> a -> b
$ Projection -> ArgInfo
projArgInfo Projection
proj) forall a b. (a -> b) -> a -> b
$
forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ QName -> TypeError
WrongHidingInProjection QName
d
let chk :: TCMT IO ()
chk = forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> Args -> tcm ()
checkParameters QName
qr QName
r Args
vs
Maybe TCState
mst <- forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors forall a b. (a -> b) -> a -> b
$
if Bool
constraintsOk then forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TCM a -> TCM (a, TCState)
localTCStateSaving TCMT IO ()
chk
else forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a.
(HasOptions m, MonadConstraint m, MonadDebug m, MonadError TCErr m,
MonadFresh ProblemId m, MonadTCEnv m, MonadWarning m) =>
m a -> m a
nonConstraining TCMT IO ()
chk
Type
dType <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ Definition -> Type
defType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
20 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ TCMT IO Doc
"we are being projected by dType = " forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
dType
]
Type
projType <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ Type
dType forall a (m :: * -> *).
(PiApplyM a, MonadReduce m, HasBuiltins m) =>
Type -> a -> m Type
`piApplyM` Args
vs
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
d0, (forall e. ArgInfo -> e -> Arg e
Arg ArgInfo
ai Type
projType, Projection -> ArgInfo
projArgInfo Projection
proj, Maybe TCState
mst))
disambiguateConstructor
:: AmbiguousQName
-> QName
-> Args
-> TCM (ConHead, Type)
disambiguateConstructor :: AmbiguousQName -> QName -> Args -> TCM (ConHead, Type)
disambiguateConstructor ambC :: AmbiguousQName
ambC@(AmbQ List1 QName
cs) QName
d Args
pars = do
QName
d <- forall (m :: * -> *). HasConstInfo m => QName -> m QName
canonicalName QName
d
[QName]
cons <- Definition -> Defn
theDef forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => QName -> m Definition
getConstInfo QName
d forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
def :: Defn
def@Datatype{} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Defn -> [QName]
dataCons Defn
def
def :: Defn
def@Record{} -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ [ConHead -> QName
conName forall a b. (a -> b) -> a -> b
$ Defn -> ConHead
recConHead Defn
def]
Defn
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
Bool
-> QName
-> [QName]
-> (([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
-> TCM (ConHead, Type))
-> TCM (ConHead, Type)
tryDisambiguate Bool
False QName
d [QName]
cons forall a b. (a -> b) -> a -> b
$ \ ([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
_ ->
Bool
-> QName
-> [QName]
-> (([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
-> TCM (ConHead, Type))
-> TCM (ConHead, Type)
tryDisambiguate Bool
True QName
d [QName]
cons forall a b. (a -> b) -> a -> b
$ \case
([] , [] ) -> forall a. HasCallStack => a
__IMPOSSIBLE__
(TCErr
err:[TCErr]
_, [] ) -> forall e (m :: * -> *) a. MonadError e m => e -> m a
throwError TCErr
err
([TCErr]
_ , [List1 (QName, ConHead, (Type, Maybe TCState))
_]) -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$ QName -> List1 QName -> TypeError
CantResolveOverloadedConstructorsTargetingSameDatatype QName
d List1 QName
cs
([TCErr]
_ , disambs :: [List1 (QName, ConHead, (Type, Maybe TCState))]
disambs@(((QName
c,ConHead
_,(Type, Maybe TCState)
_) :| [(QName, ConHead, (Type, Maybe TCState))]
_) : [List1 (QName, ConHead, (Type, Maybe TCState))]
_)) -> forall (m :: * -> *) a.
(HasCallStack, MonadTCError m) =>
TypeError -> m a
typeError forall a b. (a -> b) -> a -> b
$
QName -> [QName] -> TypeError
AmbiguousConstructor QName
c (forall a b. (a -> b) -> [a] -> [b]
map (ConHead -> QName
conName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a, b, c) -> b
snd3) forall a b. (a -> b) -> a -> b
$ forall a. [List1 a] -> [a]
List1.concat [List1 (QName, ConHead, (Type, Maybe TCState))]
disambs)
where
tryDisambiguate
:: Bool
-> QName
-> [QName]
-> ( ( [TCErr]
, [List1 (QName, ConHead, (Type, Maybe TCState))]
)
-> TCM (ConHead, Type) )
-> TCM (ConHead, Type)
tryDisambiguate :: Bool
-> QName
-> [QName]
-> (([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
-> TCM (ConHead, Type))
-> TCM (ConHead, Type)
tryDisambiguate Bool
constraintsOk QName
d [QName]
cons ([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
-> TCM (ConHead, Type)
failure = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.disamb" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep forall a b. (a -> b) -> a -> b
$ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
List.concat forall a b. (a -> b) -> a -> b
$
[ [ TCMT IO Doc
"tryDisambiguate" ]
, if Bool
constraintsOk then [ TCMT IO Doc
"(allowing new constraints)" ] else forall a. Null a => a
empty
, forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty) forall a b. (a -> b) -> a -> b
$ forall l. IsList l => l -> [Item l]
List1.toList List1 QName
cs
, [ TCMT IO Doc
"against" ]
, forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty) [QName]
cons
]
NonEmpty (Either TCErr (QName, ConHead, (Type, Maybe TCState)))
disambiguations <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall e (m :: * -> *) a. ExceptT e m a -> m (Either e a)
runExceptT forall b c a. (b -> c) -> (a -> b) -> a -> c
. Bool
-> [QName]
-> QName
-> Args
-> QName
-> ExceptT TCErr (TCMT IO) (QName, ConHead, (Type, Maybe TCState))
tryCon Bool
constraintsOk [QName]
cons QName
d Args
pars) List1 QName
cs
let ([TCErr]
errs, [(QName, ConHead, (Type, Maybe TCState))]
fits0) = forall a b. List1 (Either a b) -> ([a], [b])
List1.partitionEithers NonEmpty (Either TCErr (QName, ConHead, (Type, Maybe TCState)))
disambiguations
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.disamb" Int
40 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$ do
let hideSt :: (a, b, (a, f b)) -> (a, b, (a, f [Char]))
hideSt (a
c0,b
c,(a
a,f b
mst)) = (a
c0, b
c, (a
a, ([Char]
"(state change)" :: String) forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ f b
mst))
TCMT IO Doc
"remaining candidates: " forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {f :: * -> *} {a} {b} {a} {b}.
Functor f =>
(a, b, (a, f b)) -> (a, b, (a, f [Char]))
hideSt) [(QName, ConHead, (Type, Maybe TCState))]
fits0
forall a.
[(a, ConHead, (Type, Maybe TCState))]
-> TCM [List1 (a, ConHead, (Type, Maybe TCState))]
dedupCons [(QName, ConHead, (Type, Maybe TCState))]
fits0 forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
[ (QName
c0,ConHead
c,(Type
a,Maybe TCState
mst)) :| [] ] -> do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.disamb" Int
30 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep forall a b. (a -> b) -> a -> b
$
[ TCMT IO Doc
"tryDisambiguate suceeds with"
, forall (m :: * -> *) a. (Applicative m, Pretty a) => a -> m Doc
pretty QName
c0
, TCMT IO Doc
":"
, forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
a
]
forall (m :: * -> *) a. Monad m => Maybe a -> (a -> m ()) -> m ()
whenJust Maybe TCState
mst forall (m :: * -> *). MonadTCState m => TCState -> m ()
putTC
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (AmbiguousQName -> Bool
isAmbiguous AmbiguousQName
ambC) forall a b. (a -> b) -> a -> b
$ forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$
Induction -> QName -> TCMT IO ()
storeDisambiguatedConstructor (ConHead -> Induction
conInductive ConHead
c) QName
c0
forall (m :: * -> *) a. Monad m => a -> m a
return (ConHead
c,Type
a)
[List1 (QName, ConHead, (Type, Maybe TCState))]
groups -> ([TCErr], [List1 (QName, ConHead, (Type, Maybe TCState))])
-> TCM (ConHead, Type)
failure ([TCErr]
errs, [List1 (QName, ConHead, (Type, Maybe TCState))]
groups)
abstractConstructor :: QName -> m a
abstractConstructor QName
c = forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$
QName -> TypeError
AbstractConstructorNotInScope QName
c
wrongDatatype :: QName -> QName -> m a
wrongDatatype QName
c QName
d = forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$
QName -> QName -> TypeError
ConstructorPatternInWrongDatatype QName
c QName
d
tryCon
:: Bool
-> [QName]
-> QName
-> Args
-> QName
-> ExceptT TCErr TCM (QName, ConHead, (Type, Maybe TCState))
tryCon :: Bool
-> [QName]
-> QName
-> Args
-> QName
-> ExceptT TCErr (TCMT IO) (QName, ConHead, (Type, Maybe TCState))
tryCon Bool
constraintsOk [QName]
cons QName
d Args
pars QName
c = forall (m :: * -> *).
HasConstInfo m =>
QName -> m (Either SigError Definition)
getConstInfo' QName
c forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left (SigUnknown [Char]
err) -> forall a. HasCallStack => a
__IMPOSSIBLE__
Left SigError
SigCubicalNotErasure -> forall a. HasCallStack => a
__IMPOSSIBLE__
Left SigError
SigAbstract -> forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
QName -> m a
abstractConstructor QName
c
Right Definition
def -> do
let con :: ConHead
con = Defn -> ConHead
conSrcCon (Definition -> Defn
theDef Definition
def) forall t u. (SetRange t, HasRange u) => t -> u -> t
`withRangeOf` QName
c
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (ConHead -> QName
conName ConHead
con forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [QName]
cons) forall a b. (a -> b) -> a -> b
$ forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
QName -> QName -> m a
wrongDatatype QName
c QName
d
let chk :: TCMT IO ()
chk = forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> Args -> tcm ()
checkConstructorParameters QName
c QName
d Args
pars
Maybe TCState
mst <- forall (m :: * -> *) a.
(MonadTCM m, MonadError TCErr m) =>
TCM a -> m a
suspendErrors forall a b. (a -> b) -> a -> b
$
if Bool
constraintsOk then forall a. a -> Maybe a
Just forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b. (a, b) -> b
snd forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. TCM a -> TCM (a, TCState)
localTCStateSaving TCMT IO ()
chk
else forall a. Maybe a
Nothing forall (f :: * -> *) a b. Functor f => a -> f b -> f a
<$ forall (m :: * -> *) a.
(HasOptions m, MonadConstraint m, MonadDebug m, MonadError TCErr m,
MonadFresh ProblemId m, MonadTCEnv m, MonadWarning m) =>
m a -> m a
nonConstraining TCMT IO ()
chk
Type
cType <- (Type -> Args -> Type
`piApply` Args
pars) forall b c a. (b -> c) -> (a -> b) -> a -> c
. Definition -> Type
defType forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *). HasConstInfo m => ConHead -> m Definition
getConInfo ConHead
con
forall (m :: * -> *) a. Monad m => a -> m a
return (QName
c, ConHead
con, (Type
cType, Maybe TCState
mst))
dedupCons ::
forall a. [ (a, ConHead, (Type, Maybe TCState)) ]
-> TCM [ List1 (a, ConHead, (Type, Maybe TCState)) ]
dedupCons :: forall a.
[(a, ConHead, (Type, Maybe TCState))]
-> TCM [List1 (a, ConHead, (Type, Maybe TCState))]
dedupCons [(a, ConHead, (Type, Maybe TCState))]
cands = do
let groups :: [List1 (a, ConHead, (Type, Maybe TCState))]
groups = forall (f :: * -> *) b a.
(Foldable f, Eq b) =>
(a -> b) -> f a -> [NonEmpty a]
List1.groupWith (ConHead -> QName
conName forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a b c. (a, b, c) -> b
snd3) [(a, ConHead, (Type, Maybe TCState))]
cands
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (m :: * -> *) a.
Monad m =>
(a -> a -> m Bool) -> List1 a -> m (List1 a)
List1.nubM ((Type, Maybe TCState) -> (Type, Maybe TCState) -> TCMT IO Bool
cmpM forall b c a. (b -> b -> c) -> (a -> b) -> a -> a -> c
`on` forall a b c. (a, b, c) -> c
thd3)) [List1 (a, ConHead, (Type, Maybe TCState))]
groups
where
cmpM :: (Type, Maybe TCState) -> (Type, Maybe TCState) -> TCMT IO Bool
cmpM (Type
a1, Maybe TCState
mst1) (Type
a2, Maybe TCState
mst2) = do
let cmpTypes :: TCMT IO Bool
cmpTypes = forall (m :: * -> *).
(MonadConstraint m, MonadWarning m, MonadError TCErr m,
MonadFresh ProblemId m) =>
m () -> m Bool
tryConversion forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). MonadConversion m => Type -> Type -> m ()
equalType Type
a1 Type
a2
case (Maybe TCState
mst1, Maybe TCState
mst2) of
(Maybe TCState
Nothing, Maybe TCState
Nothing) -> TCMT IO Bool
cmpTypes
(Just TCState
st, Maybe TCState
Nothing) -> forall {a}. TCState -> TCMT IO a -> TCMT IO a
inState TCState
st TCMT IO Bool
cmpTypes
(Maybe TCState
Nothing, Just TCState
st) -> forall {a}. TCState -> TCMT IO a -> TCMT IO a
inState TCState
st TCMT IO Bool
cmpTypes
(Just{}, Just{}) -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
inState :: TCState -> TCMT IO a -> TCMT IO a
inState TCState
st TCMT IO a
m = forall a. TCM a -> TCM a
localTCState forall a b. (a -> b) -> a -> b
$ do forall (m :: * -> *). MonadTCState m => TCState -> m ()
putTC TCState
st; TCMT IO a
m
checkConstructorParameters :: MonadTCM tcm => QName -> QName -> Args -> tcm ()
checkConstructorParameters :: forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> Args -> tcm ()
checkConstructorParameters QName
c QName
d Args
pars = do
QName
dc <- forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). HasConstInfo m => QName -> m QName
getConstructorData QName
c
forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> Args -> tcm ()
checkParameters QName
dc QName
d Args
pars
checkParameters
:: MonadTCM tcm
=> QName
-> QName
-> Args
-> tcm ()
checkParameters :: forall (tcm :: * -> *).
MonadTCM tcm =>
QName -> QName -> Args -> tcm ()
checkParameters QName
dc QName
d Args
pars = forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ do
Term
a <- forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce (QName -> Elims -> Term
Def QName
dc [])
case Term
a of
Def QName
d0 Elims
es -> do
let vs :: Args
vs = forall a. a -> Maybe a -> a
fromMaybe forall a. HasCallStack => a
__IMPOSSIBLE__ forall a b. (a -> b) -> a -> b
$ forall a. [Elim' a] -> Maybe [Arg a]
allApplyElims Elims
es
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.lhs.split" Int
40 forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
vcat forall a b. (a -> b) -> a -> b
$
[ TCMT IO Doc
"checkParameters"
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"d =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
prettyShow) QName
d
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"d0 (should be == d) =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
prettyShow) QName
d0
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"dc =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> (forall (m :: * -> *). Applicative m => [Char] -> m Doc
text forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Pretty a => a -> [Char]
prettyShow) QName
dc
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"vs =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Args
vs
, forall (m :: * -> *). Functor m => Int -> m Doc -> m Doc
nest Int
2 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"pars =" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Args
pars
]
Type
t <- forall (m :: * -> *).
(HasConstInfo m, ReadTCState m) =>
QName -> m Type
typeOfConst QName
d
forall (m :: * -> *).
MonadConversion m =>
[Polarity] -> [IsForced] -> Type -> Term -> Args -> Args -> m ()
compareArgs [] [] Type
t (QName -> Elims -> Term
Def QName
d []) Args
vs (forall a. Int -> [a] -> [a]
take (forall (t :: * -> *) a. Foldable t => t a -> Int
length Args
vs) Args
pars)
Term
_ -> forall a. HasCallStack => a
__IMPOSSIBLE__
checkSortOfSplitVar :: (MonadTCM m, PureTCM m, MonadError TCErr m,
LensSort a, PrettyTCM a, LensSort ty, PrettyTCM ty)
=> DataOrRecord -> a -> Telescope -> Maybe ty -> m ()
checkSortOfSplitVar :: forall (m :: * -> *) a ty.
(MonadTCM m, PureTCM m, MonadError TCErr m, LensSort a,
PrettyTCM a, LensSort ty, PrettyTCM ty) =>
DataOrRecord -> a -> Telescope -> Maybe ty -> m ()
checkSortOfSplitVar DataOrRecord
dr a
a Telescope
tel Maybe ty
mtarget = do
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM (forall a (m :: * -> *). (Reduce a, MonadReduce m) => a -> m a
reduce forall a b. (a -> b) -> a -> b
$ forall a. LensSort a => a -> Sort' Term
getSort a
a) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Type{} -> forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall (m :: * -> *). HasOptions m => m Bool
isTwoLevelEnabled m ()
checkFibrantSplit
Prop{} -> m ()
checkPropSplit
SSet{} -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Inf Univ
u Integer
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Univ -> IsFibrant
univFibrancy Univ
u forall a. Eq a => a -> a -> Bool
== IsFibrant
IsFibrant) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
whenM forall (m :: * -> *). HasOptions m => m Bool
isTwoLevelEnabled m ()
checkFibrantSplit
Sort' Term
sa -> forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> TypeError
SortOfSplitVarError forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall t (m :: * -> *).
(Reduce t, IsMeta t, MonadReduce m) =>
t -> m (Maybe Blocker)
isBlocked Sort' Term
sa forall (f :: * -> *) a b. Applicative f => f (a -> b) -> f a -> f b
<*> forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
sep
[ TCMT IO Doc
"Cannot split on datatype in sort" , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM (forall a. LensSort a => a -> Sort' Term
getSort a
a) ]
where
checkPropSplit :: m ()
checkPropSplit
| IsRecord InductionAndEta { recordInduction :: InductionAndEta -> Maybe Induction
recordInduction=Maybe Induction
Nothing } <- DataOrRecord
dr = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just ty
target <- Maybe ty
mtarget = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target prop:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ty
target
ty -> m ()
checkIsProp ty
target
| Bool
otherwise = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"no target prop"
forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
DataOrRecord -> m a
splitOnPropError DataOrRecord
dr
checkIsProp :: ty -> m ()
checkIsProp ty
t = forall (m :: * -> *) a.
Monad m =>
BlockT m a -> m (Either Blocker a)
runBlocked (forall a (m :: * -> *).
(LensSort a, PrettyTCM a, PureTCM m, MonadBlock m) =>
a -> m Bool
isPropM ty
t) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Blocker
b -> forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
DataOrRecord -> m a
splitOnPropError DataOrRecord
dr
Right Bool
False -> forall {m :: * -> *} {a}.
(ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
DataOrRecord -> m a
splitOnPropError DataOrRecord
dr
Right Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkFibrantSplit :: m ()
checkFibrantSplit
| IsRecord InductionAndEta
_ <- DataOrRecord
dr = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Just ty
target <- Maybe ty
mtarget = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"target:" forall (m :: * -> *). Applicative m => m Doc -> m Doc -> m Doc
<+> forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM ty
target
ty -> m ()
checkIsFibrant ty
target
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall t. Tele (Dom t) -> [Dom ([Char], t)]
telToList Telescope
tel) forall a b. (a -> b) -> a -> b
$ \ Dom ([Char], Type)
d -> do
let ty :: Type
ty = forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall t e. Dom' t e -> e
unDom Dom ([Char], Type)
d
Type -> m ()
checkIsCoFibrant Type
ty
| Bool
otherwise = do
forall (m :: * -> *).
MonadDebug m =>
[Char] -> Int -> TCMT IO Doc -> m ()
reportSDoc [Char]
"tc.sort.check" Int
20 forall a b. (a -> b) -> a -> b
$ TCMT IO Doc
"no target"
Maybe Blocker -> m ()
splitOnFibrantError forall a. Maybe a
Nothing
checkIsCoFibrant :: Type -> m ()
checkIsCoFibrant Type
t = forall (m :: * -> *) a.
Monad m =>
BlockT m a -> m (Either Blocker a)
runBlocked (forall a (m :: * -> *).
(LensSort a, PureTCM m, MonadBlock m) =>
a -> m Bool
isCoFibrantSort Type
t) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Blocker
b -> Type -> Maybe Blocker -> m ()
splitOnFibrantError' Type
t forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Blocker
b
Right Bool
False -> forall (m :: * -> *). Monad m => m Bool -> m () -> m ()
unlessM (forall (m :: * -> *). (MonadTCM m, MonadReduce m) => Type -> m Bool
isInterval Type
t) forall a b. (a -> b) -> a -> b
$
Type -> Maybe Blocker -> m ()
splitOnFibrantError' Type
t forall a b. (a -> b) -> a -> b
$ forall a. Maybe a
Nothing
Right Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkIsFibrant :: ty -> m ()
checkIsFibrant ty
t = forall (m :: * -> *) a.
Monad m =>
BlockT m a -> m (Either Blocker a)
runBlocked (forall a (m :: * -> *).
(LensSort a, PureTCM m, MonadBlock m) =>
a -> m Bool
isFibrant ty
t) forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= \case
Left Blocker
b -> Maybe Blocker -> m ()
splitOnFibrantError forall a b. (a -> b) -> a -> b
$ forall a. a -> Maybe a
Just Blocker
b
Right Bool
False -> Maybe Blocker -> m ()
splitOnFibrantError forall a. Maybe a
Nothing
Right Bool
True -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
splitOnPropError :: DataOrRecord -> m a
splitOnPropError DataOrRecord
dr = forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall a b. (a -> b) -> a -> b
$ DataOrRecord -> TypeError
SplitInProp DataOrRecord
dr
splitOnFibrantError' :: Type -> Maybe Blocker -> m ()
splitOnFibrantError' Type
t Maybe Blocker
mb = forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> TypeError
SortOfSplitVarError Maybe Blocker
mb forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep
[ TCMT IO Doc
"Cannot eliminate fibrant type" , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
a
, TCMT IO Doc
"unless context type", forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM Type
t, TCMT IO Doc
"is also fibrant."
]
splitOnFibrantError :: Maybe Blocker -> m ()
splitOnFibrantError Maybe Blocker
mb = forall (m :: * -> *) a.
(HasCallStack, ReadTCState m, MonadError TCErr m, MonadTCEnv m) =>
TypeError -> m a
softTypeError forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< do
forall (tcm :: * -> *) a. MonadTCM tcm => TCM a -> tcm a
liftTCM forall a b. (a -> b) -> a -> b
$ Maybe Blocker -> Doc -> TypeError
SortOfSplitVarError Maybe Blocker
mb forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall (m :: * -> *) (t :: * -> *).
(Applicative m, Foldable t) =>
t (m Doc) -> m Doc
fsep
[ TCMT IO Doc
"Cannot eliminate fibrant type" , forall a (m :: * -> *). (PrettyTCM a, MonadPretty m) => a -> m Doc
prettyTCM a
a
, TCMT IO Doc
"unless target type is also fibrant"
]