{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module Idris.Elab.Term where
import Idris.AbsSyntax
import Idris.Core.CaseTree (SC'(STerm), findCalls)
import Idris.Core.Elaborate hiding (Tactic(..))
import Idris.Core.Evaluate
import Idris.Core.ProofTerm (getProofTerm)
import Idris.Core.TT
import Idris.Core.Typecheck (check, converts, isType, recheck)
import Idris.Core.Unify
import Idris.Core.WHNF (whnf)
import Idris.Coverage (genClauses, recoverableCoverage)
import Idris.Delaborate
import Idris.Elab.Quasiquote (extractUnquotes)
import Idris.Elab.Rewrite
import Idris.Elab.Utils
import Idris.Error
import Idris.ErrReverse (errReverse)
import Idris.Options
import Idris.ProofSearch
import Idris.Reflection
import Idris.Termination (buildSCG, checkDeclTotality, checkPositive)
import Control.Monad
import Control.Monad.State.Strict
import Data.Foldable (for_)
import Data.List
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import qualified Data.Set as S
import Debug.Trace
data ElabMode = ETyDecl | ETransLHS | ELHS | EImpossible | ERHS
deriving ElabMode -> ElabMode -> Bool
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ElabMode -> ElabMode -> Bool
$c/= :: ElabMode -> ElabMode -> Bool
== :: ElabMode -> ElabMode -> Bool
$c== :: ElabMode -> ElabMode -> Bool
Eq
data ElabResult = ElabResult {
ElabResult -> Term
resultTerm :: Term
, ElabResult -> [(Name, (Int, Maybe Name, Term, [Name]))]
resultMetavars :: [(Name, (Int, Maybe Name, Type, [Name]))]
, ElabResult -> [PDecl]
resultCaseDecls :: [PDecl]
, ElabResult -> Context
resultContext :: Context
, ElabResult -> [RDeclInstructions]
resultTyDecls :: [RDeclInstructions]
, ElabResult -> Set (FC', OutputAnnotation)
resultHighlighting :: S.Set (FC', OutputAnnotation)
, ElabResult -> Int
resultName :: Int
}
build :: IState
-> ElabInfo
-> ElabMode
-> FnOpts
-> Name
-> PTerm
-> ElabD ElabResult
build :: IState
-> ElabInfo
-> ElabMode
-> FnOpts
-> Name
-> PTerm
-> ElabD ElabResult
build IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn PTerm
tm
= do IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn PTerm
tm
let inf :: Bool
inf = case forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
fn (IState -> Ctxt TIData
idris_tyinfodata IState
ist) of
[TIData
TIPartial] -> Bool
True
[TIData]
_ -> Bool
False
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
[Name]
ivs <- forall aux. Elab' aux [Name]
get_implementations
Term
ptm <- forall aux. Elab' aux Term
get_term
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$
do forall aux. Name -> Elab' aux ()
focus Name
n
Term
g <- forall aux. Elab' aux Term
goal
forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
resolveTC' Bool
True Bool
True Int
10 Term
g Name
fn IState
ist)
(forall aux. Name -> Elab' aux ()
movelast Name
n)) [Name]
ivs
[Name]
ivs <- forall aux. Elab' aux [Name]
get_implementations
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$
do forall aux. Name -> Elab' aux ()
focus Name
n
Term
g <- forall aux. Elab' aux Term
goal
Term
ptm <- forall aux. Elab' aux Term
get_term
Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
resolveTC' Bool
True Bool
True Int
10 Term
g Name
fn IState
ist) [Name]
ivs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$ IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
False
Term
tm <- forall aux. Elab' aux Term
get_term
Context
ctxt <- forall aux. Elab' aux Context
get_context
Fails
probs <- forall aux. Elab' aux Fails
get_probs
Bool
u <- forall aux. Elab' aux Bool
getUnifyLog
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$
forall {a}. Bool -> String -> a -> a
traceWhen Bool
u (String
"Remaining holes:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Name]
hs forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
String
"Remaining problems:\n" forall a. [a] -> [a] -> [a]
++ Fails -> String
qshow Fails
probs) forall a b. (a -> b) -> a -> b
$
do forall aux. Elab' aux ()
unify_all; forall aux. Bool -> Elab' aux ()
matchProblems Bool
True; forall aux. Elab' aux ()
unifyProblems
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$ IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
True
Fails
probs <- forall aux. Elab' aux Fails
get_probs
case Fails
probs of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
((Term
_,Term
_,Bool
_,Env
_,Err
e,[FailContext]
_,FailAt
_):Fails
es) -> forall {a}. Bool -> String -> a -> a
traceWhen Bool
u (String
"Final problems:\n" forall a. [a] -> [a] -> [a]
++ Fails -> String
qshow Fails
probs forall a. [a] -> [a] -> [a]
++ String
"\nin\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
tm) forall a b. (a -> b) -> a -> b
$
if Bool
inf then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
Error Err
e)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tydecl (do forall aux. Elab' aux ()
mkPat
forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
orderPats)
EState [(Name, PDecl)]
is [(Int, ElabD ())]
_ [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights [Name]
_ [(FC, Name)]
_ <- forall aux. Elab' aux aux
getAux
Term
tt <- forall aux. Elab' aux Term
get_term
Context
ctxt <- forall aux. Elab' aux Context
get_context
let (Term
tm, [(Name, (Int, Maybe Name, Term, [Name]))]
ds) = forall s a. State s a -> s -> (a, s)
runState (Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred (forall a. a -> Maybe a
Just Name
fn) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, PDecl)]
is) Context
ctxt Term
tt) []
String
log <- forall aux. Elab' aux String
getLog
Int
g_nextname <- forall aux. Elab' aux Int
get_global_nextname
if String
log forall a. Eq a => a -> a -> Bool
/= String
""
then forall a. String -> a -> a
trace String
log forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [PDecl]
-> Context
-> [RDeclInstructions]
-> Set (FC', OutputAnnotation)
-> Int
-> ElabResult
ElabResult Term
tm [(Name, (Int, Maybe Name, Term, [Name]))]
ds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)
else forall (m :: * -> *) a. Monad m => a -> m a
return (Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [PDecl]
-> Context
-> [RDeclInstructions]
-> Set (FC', OutputAnnotation)
-> Int
-> ElabResult
ElabResult Term
tm [(Name, (Int, Maybe Name, Term, [Name]))]
ds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)
where pattern :: Bool
pattern = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
tydecl :: Bool
tydecl = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl
mkPat :: StateT (ElabState aux) TC ()
mkPat = do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
Term
tm <- forall aux. Elab' aux Term
get_term
case [Name]
hs of
(Name
h: [Name]
hs) -> do forall aux. Name -> Elab' aux ()
patvar Name
h; StateT (ElabState aux) TC ()
mkPat
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name ->
[Name] ->
PTerm ->
ElabD ElabResult
buildTC :: IState
-> ElabInfo
-> ElabMode
-> FnOpts
-> Name
-> [Name]
-> PTerm
-> ElabD ElabResult
buildTC IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn [Name]
ns PTerm
tm
= do let inf :: Bool
inf = case forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
fn (IState -> Ctxt TIData
idris_tyinfodata IState
ist) of
[TIData
TIPartial] -> Bool
True
[TIData]
_ -> Bool
False
forall aux. [Name] -> Elab' aux ()
initNextNameFrom [Name]
ns
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn PTerm
tm
Fails
probs <- forall aux. Elab' aux Fails
get_probs
Term
tm <- forall aux. Elab' aux Term
get_term
case Fails
probs of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
((Term
_,Term
_,Bool
_,Env
_,Err
e,[FailContext]
_,FailAt
_):Fails
es) -> if Bool
inf then forall (m :: * -> *) a. Monad m => a -> m a
return ()
else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
Error Err
e)
[(Name, [Name])]
dots <- forall aux. Elab' aux [(Name, [Name])]
get_dotterm
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, [Name])]
dots)) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
Error (forall t. t -> Err' t
CantMatch (Term -> Term
getInferTerm Term
tm)))
EState [(Name, PDecl)]
is [(Int, ElabD ())]
_ [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights [Name]
_ [(FC, Name)]
_ <- forall aux. Elab' aux aux
getAux
Term
tt <- forall aux. Elab' aux Term
get_term
Context
ctxt <- forall aux. Elab' aux Context
get_context
let (Term
tm, [(Name, (Int, Maybe Name, Term, [Name]))]
ds) = forall s a. State s a -> s -> (a, s)
runState (Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred (forall a. a -> Maybe a
Just Name
fn) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, PDecl)]
is) Context
ctxt Term
tt) []
String
log <- forall aux. Elab' aux String
getLog
Int
g_nextname <- forall aux. Elab' aux Int
get_global_nextname
if (String
log forall a. Eq a => a -> a -> Bool
/= String
"")
then forall a. String -> a -> a
trace String
log forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [PDecl]
-> Context
-> [RDeclInstructions]
-> Set (FC', OutputAnnotation)
-> Int
-> ElabResult
ElabResult Term
tm [(Name, (Int, Maybe Name, Term, [Name]))]
ds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)
else forall (m :: * -> *) a. Monad m => a -> m a
return (Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [PDecl]
-> Context
-> [RDeclInstructions]
-> Set (FC', OutputAnnotation)
-> Int
-> ElabResult
ElabResult Term
tm [(Name, (Int, Maybe Name, Term, [Name]))]
ds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)
getUnmatchable :: Context -> Name -> [Bool]
getUnmatchable :: Context -> Name -> [Bool]
getUnmatchable Context
ctxt Name
n | Name -> Context -> Bool
isDConName Name
n Context
ctxt Bool -> Bool -> Bool
&& Name
n forall a. Eq a => a -> a -> Bool
/= Name
inferCon
= case Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt of
Maybe Term
Nothing -> []
Just Term
ty -> [Name] -> [[Name]] -> Term -> [Bool]
checkArgs [] [] Term
ty
where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]
checkArgs :: [Name] -> [[Name]] -> Term -> [Bool]
checkArgs [Name]
env [[Name]]
ns (Bind Name
n (Pi RigCount
_ Maybe ImplicitInfo
_ Term
t Term
_) Term
sc)
= let env' :: [Name]
env' = case Term
t of
TType UExp
_ -> Name
n forall a. a -> [a] -> [a]
: [Name]
env
Term
_ -> [Name]
env in
[Name] -> [[Name]] -> Term -> [Bool]
checkArgs [Name]
env' (forall a. Eq a => [a] -> [a] -> [a]
intersect [Name]
env (Term -> [Name]
refsIn Term
t) forall a. a -> [a] -> [a]
: [[Name]]
ns)
(forall n. TT n -> TT n -> TT n
instantiate (forall n. NameType -> n -> TT n -> TT n
P NameType
Bound Name
n Term
t) Term
sc)
checkArgs [Name]
env [[Name]]
ns Term
t
= forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (forall a. [a] -> [a]
reverse [[Name]]
ns)
getUnmatchable Context
ctxt Name
n = []
data ElabCtxt = ElabCtxt { ElabCtxt -> Bool
e_inarg :: Bool,
ElabCtxt -> Bool
e_isfn :: Bool,
ElabCtxt -> Bool
e_guarded :: Bool,
ElabCtxt -> Bool
e_intype :: Bool,
ElabCtxt -> Bool
e_qq :: Bool,
ElabCtxt -> Bool
e_nomatching :: Bool
}
initElabCtxt :: ElabCtxt
initElabCtxt = Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> ElabCtxt
ElabCtxt Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False
goal_polymorphic :: ElabD Bool
goal_polymorphic :: ElabD Bool
goal_polymorphic =
do Term
ty <- forall aux. Elab' aux Term
goal
case Term
ty of
P NameType
_ Name
n Term
_ -> do Env
env <- forall aux. Elab' aux Env
get_env
case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Maybe (Binder Term)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Maybe (Binder Term)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
elab :: IState
-> ElabInfo
-> ElabMode
-> FnOpts
-> Name
-> PTerm
-> ElabD ()
elab :: IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn PTerm
tm
= do let loglvl :: Int
loglvl = IOption -> Int
opt_logLevel (IState -> IOption
idris_options IState
ist)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
loglvl forall a. Ord a => a -> a -> Bool
> Int
5) forall a b. (a -> b) -> a -> b
$ forall aux. Bool -> Elab' aux ()
unifyLog Bool
True
forall aux. Elab' aux ()
compute
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
initElabCtxt (ElabInfo -> Maybe FC
elabFC ElabInfo
info) PTerm
tm
EState
est <- forall aux. Elab' aux aux
getAux
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (EState -> [ElabD ()]
get_delayed_elab EState
est)
forall aux. Elab' aux ()
end_unify
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform) forall a b. (a -> b) -> a -> b
$
do forall aux. Elab' aux ()
unify_all
forall aux. Bool -> Elab' aux ()
matchProblems Bool
False
forall aux. Elab' aux ()
unifyProblems
forall aux. Elab' aux ()
mkPat
forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
Term
ptm <- forall aux. Elab' aux Term
get_term
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pattern forall a b. (a -> b) -> a -> b
$
do let pnms :: [(Name, RigCount)]
pnms = RigCount -> IState -> [Name] -> Term -> [(Name, RigCount)]
findLinear RigCount
Rig1 IState
ist [] Term
ptm
forall aux. (Term -> Term) -> Elab' aux ()
update_term ([(Name, RigCount)] -> Term -> Term
setLinear [(Name, RigCount)]
pnms)
where
pattern :: Bool
pattern = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
eimpossible :: Bool
eimpossible = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
intransform :: Bool
intransform = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETransLHS
bindfree :: Bool
bindfree = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETransLHS
Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
autoimpls :: Bool
autoimpls = IOption -> Bool
opt_autoimpls (IState -> IOption
idris_options IState
ist)
get_delayed_elab :: EState -> [ElabD ()]
get_delayed_elab EState
est =
let ds :: [(Int, ElabD ())]
ds = EState -> [(Int, ElabD ())]
delayed_elab EState
est in
forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Int
p1, ElabD ()
_) (Int
p2, ElabD ()
_) -> forall a. Ord a => a -> a -> Ordering
compare Int
p1 Int
p2) [(Int, ElabD ())]
ds
tcgen :: Bool
tcgen = FnOpt
Dictionary forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts
reflection :: Bool
reflection = FnOpt
Reflection forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts
isph :: PArg -> (Bool, Int)
isph PArg
arg = case forall t. PArg' t -> t
getTm PArg
arg of
PTerm
Placeholder -> (Bool
True, forall t. PArg' t -> Int
priority PArg
arg)
PTerm
tm -> (Bool
False, forall t. PArg' t -> Int
priority PArg
arg)
mkPat :: StateT (ElabState aux) TC ()
mkPat = do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
Term
tm <- forall aux. Elab' aux Term
get_term
case [Name]
hs of
(Name
h: [Name]
hs) -> do forall aux. Name -> Elab' aux ()
patvar Name
h; StateT (ElabState aux) TC ()
mkPat
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
elabRec :: PTerm -> ElabD ()
elabRec = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
initElabCtxt forall a. Maybe a
Nothing
elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina Maybe FC
fc' PTerm
t =
do [Name]
solved <- forall aux. Elab' aux [Name]
get_recents
[(Name, ([FailContext], [Name]))]
as <- forall aux. Elab' aux [(Name, ([FailContext], [Name]))]
get_autos
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Name
a, ([FailContext]
failc, [Name]
ns)) ->
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
n -> Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
solved) [Name]
ns Bool -> Bool -> Bool
&& forall a. [a] -> a
head [Name]
hs forall a. Eq a => a -> a -> Bool
/= Name
a
then IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
solveAuto IState
ist Name
fn Bool
False (Name
a, [FailContext]
failc)
else forall (m :: * -> *) a. Monad m => a -> m a
return ()) [(Name, ([FailContext], [Name]))]
as
PTerm
apt <- forall {aux}. PTerm -> StateT (ElabState aux) TC PTerm
expandToArity PTerm
t
PTerm
itm <- if Bool -> Bool
not Bool
pattern then forall {p} {aux}. p -> PTerm -> StateT (ElabState aux) TC PTerm
insertImpLam ElabCtxt
ina PTerm
apt else forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
apt
PTerm
ct <- forall {p} {aux}. p -> PTerm -> StateT (ElabState aux) TC PTerm
insertCoerce ElabCtxt
ina PTerm
itm
PTerm
t' <- ElabCtxt -> PTerm -> ElabD PTerm
insertLazy ElabCtxt
ina PTerm
ct
Term
g <- forall aux. Elab' aux Term
goal
Term
tm <- forall aux. Elab' aux Term
get_term
Fails
ps <- forall aux. Elab' aux Fails
get_probs
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
Env
env <- forall aux. Elab' aux Env
get_env
let fc :: FC
fc = String -> FC
fileFC String
"Force"
forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError (PTerm -> Env -> Err -> Bool
forceErr PTerm
t' Env
env)
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc' PTerm
t')
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc' (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] (String -> Name
sUN String
"Force"))
[forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"t") PTerm
Placeholder Bool
True,
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"a") PTerm
Placeholder Bool
True,
forall {t}. t -> PArg' t
pexp PTerm
ct]))
forceErr :: PTerm -> Env -> Err -> Bool
forceErr PTerm
orig Env
env (CantUnify Bool
_ (Term
t,Maybe Provenance
_) (Term
t',Maybe Provenance
_) Err
_ [(Name, Term)]
_ Int
_)
| (P NameType
_ (UN Text
ht) Term
_, [Term]
_) <- forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
t),
Text
ht forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed" = PTerm -> Bool
notDelay PTerm
orig
forceErr PTerm
orig Env
env (CantUnify Bool
_ (Term
t,Maybe Provenance
_) (Term
t',Maybe Provenance
_) Err
_ [(Name, Term)]
_ Int
_)
| (P NameType
_ (UN Text
ht) Term
_, [Term]
_) <- forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
t'),
Text
ht forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed" = PTerm -> Bool
notDelay PTerm
orig
forceErr PTerm
orig Env
env (InfiniteUnify Name
_ Term
t [(Name, Term)]
_)
| (P NameType
_ (UN Text
ht) Term
_, [Term]
_) <- forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
t),
Text
ht forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed" = PTerm -> Bool
notDelay PTerm
orig
forceErr PTerm
orig Env
env (Elaborating String
_ Name
_ Maybe Term
_ Err
t) = PTerm -> Env -> Err -> Bool
forceErr PTerm
orig Env
env Err
t
forceErr PTerm
orig Env
env (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err
t) = PTerm -> Env -> Err -> Bool
forceErr PTerm
orig Env
env Err
t
forceErr PTerm
orig Env
env (At FC
_ Err
t) = PTerm -> Env -> Err -> Bool
forceErr PTerm
orig Env
env Err
t
forceErr PTerm
orig Env
env Err
t = Bool
False
notDelay :: PTerm -> Bool
notDelay t :: PTerm
t@(PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg]
_) | Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delay" = Bool
False
notDelay PTerm
_ = Bool
True
elab' :: ElabCtxt
-> Maybe FC
-> PTerm
-> ElabD ()
elab' :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc (PNoImplicits PTerm
t) = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
elab' ElabCtxt
ina Maybe FC
fc (PType FC
fc') =
do forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply Raw
RType []
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (String -> String -> OutputAnnotation
AnnType String
"Type" String
"The type of types")
elab' ElabCtxt
ina Maybe FC
fc (PUniverse FC
fc' Universe
u) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
UniquenessTypes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist
Bool -> Bool -> Bool
|| ElabCtxt -> Bool
e_qq ElabCtxt
ina) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
fc' (forall t. String -> Err' t
Msg String
"You must turn on the UniquenessTypes extension to use UniqueType or AnyType")
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Universe -> Raw
RUType Universe
u) []
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (String -> String -> OutputAnnotation
AnnType (forall a. Show a => a -> String
show Universe
u) String
"The type of unique types")
elab' ElabCtxt
ina Maybe FC
fc tm :: PTerm
tm@(PConstant FC
fc' Const
c)
| Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_intype ElabCtxt
ina)
Bool -> Bool -> Bool
&& Const -> Bool
isTypeConst Const
c
= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
| Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& ElabCtxt -> Bool
e_nomatching ElabCtxt
ina
= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
| Bool
otherwise = do forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Const -> Raw
RConstant Const
c) []
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (Const -> OutputAnnotation
AnnConst Const
c)
elab' ElabCtxt
ina Maybe FC
fc (PQuote Raw
r) = do forall aux. Raw -> Elab' aux ()
fill Raw
r; forall aux. Elab' aux ()
solve
elab' ElabCtxt
ina Maybe FC
_ (PTrue FC
fc PunInfo
_) =
do forall aux. Elab' aux ()
compute
Term
g <- forall aux. Elab' aux Term
goal
case Term
g of
TType UExp
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
unitTy)
UType Universe
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
unitTy)
Term
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
unitCon)
elab' ElabCtxt
ina Maybe FC
fc (PResolveTC (FC String
"HACK" (Int, Int)
_ (Int, Int)
_))
= do Term
g <- forall aux. Elab' aux Term
goal; Bool
-> Bool
-> Int
-> Term
-> Name
-> (PTerm -> ElabD ())
-> IState
-> ElabD ()
resolveTC Bool
False Bool
False Int
5 Term
g Name
fn PTerm -> ElabD ()
elabRec IState
ist
elab' ElabCtxt
ina Maybe FC
fc (PResolveTC FC
fc')
= do Name
c <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"__interface")
forall aux. Name -> Elab' aux ()
implementationArg Name
c
elab' ElabCtxt
ina Maybe FC
_ (PApp FC
fc (PRef FC
_ [FC]
_ Name
n) [PArg]
args)
| Name
n forall a. Eq a => a -> a -> Bool
== Name
eqTy, [PTerm
Placeholder, PTerm
Placeholder, PTerm
l, PTerm
r] <- forall a b. (a -> b) -> [a] -> [b]
map forall t. PArg' t -> t
getTm [PArg]
args
= forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"aqty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
forall aux. Name -> Elab' aux ()
movelast Name
tyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
eqTy)
[forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
tyn) Bool
True,
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
tyn) Bool
False,
forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r]))
(do Name
atyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"aqty")
Name
btyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"bqty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
atyn Raw
RType
forall aux. Name -> Elab' aux ()
movelast Name
atyn
forall aux. Name -> Raw -> Elab' aux ()
claim Name
btyn Raw
RType
forall aux. Name -> Elab' aux ()
movelast Name
btyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
eqTy)
[forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
atyn) Bool
True,
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
btyn) Bool
False,
forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r]))
elab' ElabCtxt
ina Maybe FC
_ (PPair FC
fc [FC]
hls PunInfo
_ PTerm
l PTerm
r)
= do forall aux. Elab' aux ()
compute
Term
g <- forall aux. Elab' aux Term
goal
let (Term
tc, [Term]
_) = forall n. TT n -> (TT n, [TT n])
unApply Term
g
case Term
g of
TType UExp
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
pairTy)
[forall {t}. t -> PArg' t
pexp PTerm
l,forall {t}. t -> PArg' t
pexp PTerm
r])
UType Universe
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
upairTy)
[forall {t}. t -> PArg' t
pexp PTerm
l,forall {t}. t -> PArg' t
pexp PTerm
r])
Term
_ -> case Term
tc of
P NameType
_ Name
n Term
_ | Name
n forall a. Eq a => a -> a -> Bool
== Name
upairTy
-> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
upairCon)
[forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") PTerm
Placeholder Bool
False,
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") PTerm
Placeholder Bool
False,
forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r])
Term
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
pairCon)
[forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") PTerm
Placeholder Bool
False,
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") PTerm
Placeholder Bool
False,
forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r])
elab' ElabCtxt
ina Maybe FC
_ (PDPair FC
fc [FC]
hls PunInfo
p l :: PTerm
l@(PRef FC
nfc [FC]
hl Name
n) PTerm
t PTerm
r)
= case PunInfo
p of
PunInfo
IsType -> ElabD ()
asType
PunInfo
IsTerm -> ElabD ()
asValue
PunInfo
TypeOrTerm ->
do forall aux. Elab' aux ()
compute
Term
g <- forall aux. Elab' aux Term
goal
case Term
g of
TType UExp
_ -> ElabD ()
asType
Term
_ -> ElabD ()
asValue
where asType :: ElabD ()
asType = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [FC]
hls Name
sigmaTy)
[forall {t}. t -> PArg' t
pexp PTerm
t,
forall {t}. t -> PArg' t
pexp (FC -> Name -> FC -> PTerm -> PTerm -> PTerm
PLam FC
fc Name
n FC
nfc PTerm
Placeholder PTerm
r)])
asValue :: ElabD ()
asValue = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
sigmaCon)
[forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"a") PTerm
t Bool
False,
forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"P") PTerm
Placeholder Bool
True,
forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r])
elab' ElabCtxt
ina Maybe FC
_ (PDPair FC
fc [FC]
hls PunInfo
p PTerm
l PTerm
t PTerm
r) = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
sigmaCon)
[forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"a") PTerm
t Bool
False,
forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"P") PTerm
Placeholder Bool
True,
forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r])
elab' ElabCtxt
ina Maybe FC
fc (PAlternative [(Name, Name)]
ms (ExactlyOne Bool
delayok) [PTerm]
as)
= do [PTerm]
as_pruned <- forall {aux}. [PTerm] -> StateT (ElabState aux) TC [PTerm]
doPrune [PTerm]
as
[Name]
uns <- forall aux. Elab' aux [Name]
get_usedns
let as' :: [PTerm]
as' = forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> [(Name, Name)] -> PTerm -> PTerm
mkUniqueNames ([Name]
uns forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, Name)]
ms) [(Name, Name)]
ms) [PTerm]
as_pruned
~(Name
h : [Name]
hs) <- forall aux. Elab' aux [Name]
get_holes
Term
ty <- forall aux. Elab' aux Term
goal
case [PTerm]
as' of
[] -> do [Name]
hds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {aux}. PTerm -> StateT (ElabState aux) TC Name
showHd [PTerm]
as
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. [Name] -> Err' t
NoValidAlts [Name]
hds
[PTerm
x] -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x
[PTerm]
_ -> forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError forall {t}. Err' t -> Bool
isAmbiguous
(do [Name]
hds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {aux}. PTerm -> StateT (ElabState aux) TC Name
showHd [PTerm]
as'
forall aux a. [(Elab' aux a, Name)] -> Elab' aux a
tryAll (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc) [PTerm]
as')
[Name]
hds))
(do forall aux. Name -> Elab' aux ()
movelast Name
h
Int -> ElabD () -> ElabD ()
delayElab Int
5 forall a b. (a -> b) -> a -> b
$ do
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
h forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$ do
forall aux. Name -> Elab' aux ()
focus Name
h
[PTerm]
as'' <- forall {aux}. [PTerm] -> StateT (ElabState aux) TC [PTerm]
doPrune [PTerm]
as'
case [PTerm]
as'' of
[PTerm
x] -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x
[PTerm]
_ -> do [Name]
hds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {aux}. PTerm -> StateT (ElabState aux) TC Name
showHd [PTerm]
as''
forall aux a. Bool -> [(Elab' aux a, Name)] -> Elab' aux a
tryAll' Bool
False (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc) [PTerm]
as'')
[Name]
hds))
where showHd :: PTerm -> StateT (ElabState aux) TC Name
showHd (PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg
_, PArg
_, PArg
arg])
| Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delay" = PTerm -> StateT (ElabState aux) TC Name
showHd (forall t. PArg' t -> t
getTm PArg
arg)
showHd (PApp FC
_ (PRef FC
_ [FC]
_ Name
n) [PArg]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
showHd (PRef FC
_ [FC]
_ Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
showHd (PApp FC
_ PTerm
h [PArg]
_) = PTerm -> StateT (ElabState aux) TC Name
showHd PTerm
h
showHd (PHidden PTerm
h) = PTerm -> StateT (ElabState aux) TC Name
showHd PTerm
h
showHd PTerm
x = forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"_")
doPrune :: [PTerm] -> StateT (ElabState aux) TC [PTerm]
doPrune [PTerm]
as =
do forall aux. Elab' aux ()
compute
Term
ty <- forall aux. Elab' aux Term
goal
Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
let ty' :: Term
ty' = Term -> Term
unDelay Term
ty
let (Term
tc, [Term]
_) = forall n. TT n -> (TT n, [TT n])
unApply Term
ty'
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Env -> Term -> Term -> IState -> [PTerm] -> [PTerm]
pruneByType Bool
eimpossible Env
env Term
tc Term
ty' IState
ist [PTerm]
as
unDelay :: Term -> Term
unDelay Term
t | (P NameType
_ (UN Text
l) Term
_, [Term
_, Term
arg]) <- forall n. TT n -> (TT n, [TT n])
unApply Term
t,
Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed" = Term -> Term
unDelay Term
arg
| Bool
otherwise = Term
t
isAmbiguous :: Err' t -> Bool
isAmbiguous (CantResolveAlts [Name]
_) = Bool
delayok
isAmbiguous (Elaborating String
_ Name
_ Maybe t
_ Err' t
e) = Err' t -> Bool
isAmbiguous Err' t
e
isAmbiguous (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err' t
e) = Err' t -> Bool
isAmbiguous Err' t
e
isAmbiguous (At FC
_ Err' t
e) = Err' t -> Bool
isAmbiguous Err' t
e
isAmbiguous Err' t
_ = Bool
False
elab' ElabCtxt
ina Maybe FC
fc (PAlternative [(Name, Name)]
ms PAltType
FirstSuccess [PTerm]
as_in)
= do
[Name]
uns <- forall aux. Elab' aux [Name]
get_usedns
let as :: [PTerm]
as = forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> [(Name, Name)] -> PTerm -> PTerm
mkUniqueNames ([Name]
uns forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, Name)]
ms) [(Name, Name)]
ms) [PTerm]
as_in
[PTerm] -> ElabD ()
trySeq [PTerm]
as
where
trySeq :: [PTerm] -> ElabD ()
trySeq (PTerm
x : [PTerm]
xs) = let e1 :: ElabD ()
e1 = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x in
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' ElabD ()
e1 (forall {a}. StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' ElabD ()
e1 [PTerm]
xs) Bool
True
trySeq [] = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Nothing to try in sequence"
trySeq' :: StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' StateT (ElabState EState) TC a
deferr [] = do StateT (ElabState EState) TC a
deferr; forall aux. Elab' aux ()
unifyProblems
trySeq' StateT (ElabState EState) TC a
deferr (PTerm
x : [PTerm]
xs)
= forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (forall aux a. Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
tryCatch (do ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x
IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
False
forall aux. Elab' aux ()
unifyProblems)
(\Err
_ -> StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' StateT (ElabState EState) TC a
deferr []))
(StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' StateT (ElabState EState) TC a
deferr [PTerm]
xs) Bool
True
elab' ElabCtxt
ina Maybe FC
fc (PAlternative [(Name, Name)]
ms PAltType
TryImplicit (PTerm
orig : [PTerm]
alts)) = do
Env
env <- forall aux. Elab' aux Env
get_env
forall aux. Elab' aux ()
compute
Term
ty <- forall aux. Elab' aux Term
goal
let doelab :: ElabD ()
doelab = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
orig
forall aux a. Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
tryCatch ElabD ()
doelab
(\Err
err ->
if forall {t}. Err' t -> Bool
recoverableErr Err
err
then
case Err -> [PTerm] -> Env -> [PTerm]
pruneAlts Err
err [PTerm]
alts Env
env of
[] -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail Err
err
[PTerm]
alts' -> do
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc ([(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms (Bool -> PAltType
ExactlyOne Bool
False) [PTerm]
alts'))
(forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail Err
err)
Bool
True
else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail Err
err)
where
recoverableErr :: Err' t -> Bool
recoverableErr (CantUnify Bool
_ (t, Maybe Provenance)
_ (t, Maybe Provenance)
_ Err' t
_ [(Name, t)]
_ Int
_) = Bool
True
recoverableErr (TooManyArguments Name
_) = Bool
False
recoverableErr (CantSolveGoal t
_ [(Name, t)]
_) = Bool
False
recoverableErr (CantResolveAlts [Name]
_) = Bool
False
recoverableErr (NoValidAlts [Name]
_) = Bool
True
recoverableErr (ProofSearchFail (Msg String
_)) = Bool
True
recoverableErr (ProofSearchFail Err' t
_) = Bool
False
recoverableErr (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err' t
e) = Err' t -> Bool
recoverableErr Err' t
e
recoverableErr (At FC
_ Err' t
e) = Err' t -> Bool
recoverableErr Err' t
e
recoverableErr (ElabScriptDebug [ErrorReportPart]
_ t
_ [(Name, t, [(Name, Binder t)])]
_) = Bool
False
recoverableErr Err' t
_ = Bool
True
pruneAlts :: Err -> [PTerm] -> Env -> [PTerm]
pruneAlts (CantUnify Bool
_ (Term
inc, Maybe Provenance
_) (Term
outc, Maybe Provenance
_) Err
_ [(Name, Term)]
_ Int
_) [PTerm]
alts Env
env
= case forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
inc) of
(P (TCon Int
_ Int
_) Name
n Term
_, [Term]
_) -> forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Env -> PTerm -> Bool
hasArg Name
n Env
env) [PTerm]
alts
(Constant Const
_, [Term]
_) -> [PTerm]
alts
(Term, [Term])
_ -> forall a. (a -> Bool) -> [a] -> [a]
filter PTerm -> Bool
isLend [PTerm]
alts
pruneAlts (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err
e) [PTerm]
alts Env
env = Err -> [PTerm] -> Env -> [PTerm]
pruneAlts Err
e [PTerm]
alts Env
env
pruneAlts (At FC
_ Err
e) [PTerm]
alts Env
env = Err -> [PTerm] -> Env -> [PTerm]
pruneAlts Err
e [PTerm]
alts Env
env
pruneAlts (NoValidAlts [Name]
as) [PTerm]
alts Env
env = [PTerm]
alts
pruneAlts Err
err [PTerm]
alts Env
_ = forall a. (a -> Bool) -> [a] -> [a]
filter PTerm -> Bool
isLend [PTerm]
alts
hasArg :: Name -> Env -> PTerm -> Bool
hasArg Name
n Env
env PTerm
ap | PTerm -> Bool
isLend PTerm
ap = Bool
True
hasArg Name
n Env
env (PApp FC
_ (PRef FC
_ [FC]
_ Name
a) [PArg]
_)
= case Name -> Context -> Maybe Term
lookupTyExact Name
a (IState -> Context
tt_ctxt IState
ist) of
Just Term
ty -> let args :: [Term]
args = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty)) in
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall {a}. Eq a => a -> TT a -> Bool
fnIs Name
n) [Term]
args
Maybe Term
Nothing -> Bool
False
hasArg Name
n Env
env (PAlternative [(Name, Name)]
_ PAltType
_ [PTerm]
as) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> Env -> PTerm -> Bool
hasArg Name
n Env
env) [PTerm]
as
hasArg Name
n Env
_ PTerm
tm = Bool
False
isLend :: PTerm -> Bool
isLend (PApp FC
_ (PRef FC
_ [FC]
_ Name
l) [PArg]
_) = Name
l forall a. Eq a => a -> a -> Bool
== Name -> [String] -> Name
sNS (String -> Name
sUN String
"lend") [String
"Ownership"]
isLend PTerm
_ = Bool
False
fnIs :: a -> TT a -> Bool
fnIs a
n TT a
ty = case forall n. TT n -> (TT n, [TT n])
unApply TT a
ty of
(P NameType
_ a
n' TT a
_, [TT a]
_) -> a
n forall a. Eq a => a -> a -> Bool
== a
n'
(TT a, [TT a])
_ -> Bool
False
elab' ElabCtxt
ina Maybe FC
_ (PPatvar FC
fc Name
n) | Bool
bindfree
= do forall aux. Name -> Elab' aux ()
patvar Name
n
forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
elab' ElabCtxt
ec Maybe FC
fc' tm :: PTerm
tm@(PRef FC
fc [FC]
hls Name
n)
| Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ec) Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_intype ElabCtxt
ec)
Bool -> Bool -> Bool
&& Name -> Context -> Bool
isTConName Name
n (IState -> Context
tt_ctxt IState
ist)
= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
| Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ec) Bool -> Bool -> Bool
&& ElabCtxt -> Bool
e_nomatching ElabCtxt
ec
= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
| (Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform Bool -> Bool -> Bool
|| (Bool
bindfree Bool -> Bool -> Bool
&& Name -> Bool
bindable Name
n)) Bool -> Bool -> Bool
&& Bool -> Bool
not (Name -> Bool
inparamBlock Name
n) Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ec)
= do Term
ty <- forall aux. Elab' aux Term
goal
FC -> Name -> Term -> ElabD ()
testImplicitWarning FC
fc Name
n Term
ty
let ina :: Bool
ina = ElabCtxt -> Bool
e_inarg ElabCtxt
ec
Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
let defined :: Bool
defined = case Name -> Context -> [Term]
lookupTy Name
n Context
ctxt of
[] -> case Name -> Env -> Maybe (Int, RigCount, Term)
lookupTyEnv Name
n Env
env of
Just (Int, RigCount, Term)
_ -> Bool
True
Maybe (Int, RigCount, Term)
_ -> Bool
False
[Term]
_ -> Bool
True
if (Name -> Bool
tcname Name
n Bool -> Bool -> Bool
&& Bool
ina Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
intransform)
then forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc forall a b. (a -> b) -> a -> b
$
do forall aux. Name -> Elab' aux ()
patvar Name
n
forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
else if Bool
defined
then ElabCtxt -> Maybe FC -> FC -> [FC] -> Name -> PTerm -> ElabD ()
elabRef ElabCtxt
ec Maybe FC
fc' FC
fc [FC]
hls Name
n PTerm
tm
else forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
n) []
OutputAnnotation
annot <- Name -> ElabD OutputAnnotation
findHighlight Name
n
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc OutputAnnotation
annot)
(do forall aux. Name -> Elab' aux ()
patvar Name
n
forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False))
where inparamBlock :: Name -> Bool
inparamBlock Name
n = case forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
n (ElabInfo -> Ctxt [Name]
inblock ElabInfo
info) of
[] -> Bool
False
[(Name, [Name])]
_ -> Bool
True
bindable :: Name -> Bool
bindable (NS Name
_ [Text]
_) = Bool
False
bindable (MN Int
_ Text
_) = Bool
True
bindable Name
n = Name -> Bool
implicitable Name
n Bool -> Bool -> Bool
&& Bool
autoimpls
elab' ElabCtxt
ina Maybe FC
_ f :: PTerm
f@(PInferRef FC
fc [FC]
hls Name
n) = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
NoFC PTerm
f [])
elab' ElabCtxt
ina Maybe FC
fc' tm :: PTerm
tm@(PRef FC
fc [FC]
hls Name
n)
| Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_intype ElabCtxt
ina)
Bool -> Bool -> Bool
&& Name -> Context -> Bool
isTConName Name
n (IState -> Context
tt_ctxt IState
ist)
= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
| Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& ElabCtxt -> Bool
e_nomatching ElabCtxt
ina
= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
| Bool
otherwise = ElabCtxt -> Maybe FC -> FC -> [FC] -> Name -> PTerm -> ElabD ()
elabRef ElabCtxt
ina Maybe FC
fc' FC
fc [FC]
hls Name
n PTerm
tm
elab' ElabCtxt
ina Maybe FC
_ (PLam FC
_ Name
_ FC
_ PTerm
_ PTerm
PImpossible) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Only pattern-matching lambdas can be impossible"
elab' ElabCtxt
ina Maybe FC
_ (PLam FC
fc Name
n FC
nfc PTerm
Placeholder PTerm
sc)
= do
Context
ctxt <- forall aux. Elab' aux Context
get_context
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Context -> Bool
isTConName Name
n Context
ctxt) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail (forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Can't use type constructor " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" here")
forall aux. Name -> Elab' aux ()
checkPiGoal Name
n
forall aux. Elab' aux ()
attack; forall aux. Maybe Name -> Elab' aux ()
intro (forall a. a -> Maybe a
Just Name
n);
forall aux. Name -> Elab' aux ()
addPSname Name
n
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True } ) (forall a. a -> Maybe a
Just FC
fc) PTerm
sc; forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
elab' ElabCtxt
ec Maybe FC
_ (PLam FC
fc Name
n FC
nfc PTerm
ty PTerm
sc)
= do Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"lamty")
Context
ctxt <- forall aux. Elab' aux Context
get_context
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Context -> Bool
isTConName Name
n Context
ctxt) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail (forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Can't use type constructor " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" here")
forall aux. Name -> Elab' aux ()
checkPiGoal Name
n
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
forall aux. Name -> Elab' aux ()
explicit Name
tyn
forall aux. Elab' aux ()
attack
Term
ptm <- forall aux. Elab' aux Term
get_term
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
forall aux. Raw -> Maybe Name -> Elab' aux ()
introTy (Name -> Raw
Var Name
tyn) (forall a. a -> Maybe a
Just Name
n)
forall aux. Name -> Elab' aux ()
addPSname Name
n
forall aux. Name -> Elab' aux ()
focus Name
tyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ec { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
ty
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ec { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
sc
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
elab' ElabCtxt
ina Maybe FC
fc (PPi Plicity
p Name
n FC
nfc PTerm
Placeholder PTerm
sc)
= do forall aux. Elab' aux ()
attack;
case Plicity -> RigCount
pcount Plicity
p of
RigCount
RigW -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RigCount
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
LinearTypes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist
Bool -> Bool -> Bool
|| ElabCtxt -> Bool
e_qq ElabCtxt
ina) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
nfc (forall t. String -> Err' t
Msg String
"You must turn on the LinearTypes extension to use a count")
forall aux.
Name -> RigCount -> Maybe ImplicitInfo -> Name -> Elab' aux ()
arg Name
n (Plicity -> RigCount
pcount Plicity
p) (Plicity -> Maybe ImplicitInfo
is_scoped Plicity
p) (Int -> String -> Name
sMN Int
0 String
"phTy")
Plicity -> Name -> ElabD ()
addAutoBind Plicity
p Name
n
forall aux. Name -> Elab' aux ()
addPSname Name
n
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True }) Maybe FC
fc PTerm
sc
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
elab' ElabCtxt
ina Maybe FC
fc (PPi Plicity
p Name
n FC
nfc PTerm
ty PTerm
sc)
= do forall aux. Elab' aux ()
attack; Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"piTy")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
n' <- case Name
n of
MN Int
_ Text
_ -> forall aux. Name -> Elab' aux Name
unique_hole Name
n
Name
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
case Plicity -> RigCount
pcount Plicity
p of
RigCount
RigW -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RigCount
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
LinearTypes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist
Bool -> Bool -> Bool
|| ElabCtxt -> Bool
e_qq ElabCtxt
ina) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
nfc (forall t. String -> Err' t
Msg String
"You must turn on the LinearTypes extension to use a linear argument")
forall aux.
Name -> RigCount -> Maybe ImplicitInfo -> Raw -> Elab' aux ()
forAll Name
n' (Plicity -> RigCount
pcount Plicity
p) (Plicity -> Maybe ImplicitInfo
is_scoped Plicity
p) (Name -> Raw
Var Name
tyn)
Plicity -> Name -> ElabD ()
addAutoBind Plicity
p Name
n'
forall aux. Name -> Elab' aux ()
addPSname Name
n'
forall aux. Name -> Elab' aux ()
focus Name
tyn
let ec' :: ElabCtxt
ec' = ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True }
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ec' Maybe FC
fc PTerm
ty
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ec' Maybe FC
fc PTerm
sc
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
elab' ElabCtxt
ina Maybe FC
_ tm :: PTerm
tm@(PLet FC
fc RigCount
rig Name
n FC
nfc PTerm
ty PTerm
val PTerm
sc)
= do forall aux. Elab' aux ()
attack
[Name]
ivs <- forall aux. Elab' aux [Name]
get_implementations
Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
forall aux. Name -> Elab' aux ()
explicit Name
valn
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n RigCount
rig (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
forall aux. Name -> Elab' aux ()
addPSname Name
n
case PTerm
ty of
PTerm
Placeholder -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
PTerm
_ -> do forall aux. Name -> Elab' aux ()
focus Name
tyn
forall aux. Name -> Elab' aux ()
explicit Name
tyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True })
(forall a. a -> Maybe a
Just FC
fc) PTerm
ty
forall aux. Name -> Elab' aux ()
focus Name
valn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True })
(forall a. a -> Maybe a
Just FC
fc) PTerm
val
[Name]
ivs' <- forall aux. Elab' aux [Name]
get_implementations
Env
env <- forall aux. Elab' aux Env
get_env
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
sc
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform)) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> do forall aux. Name -> Elab' aux ()
focus Name
n
Term
g <- forall aux. Elab' aux Term
goal
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
tyn Bool -> Bool -> Bool
|| Bool -> Bool
not (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs)) (forall n. Eq n => TT n -> [n]
freeNames Term
g)
then forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError (ElabMode -> Err -> Bool
tcRecoverable ElabMode
emode)
(Bool
-> Bool
-> Int
-> Term
-> Name
-> (PTerm -> ElabD ())
-> IState
-> ElabD ()
resolveTC Bool
True Bool
False Int
10 Term
g Name
fn PTerm -> ElabD ()
elabRec IState
ist)
(forall aux. Name -> Elab' aux ()
movelast Name
n)
else forall aux. Name -> Elab' aux ()
movelast Name
n)
([Name]
ivs' forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
ivs)
forall aux. Name -> Term -> Elab' aux ()
expandLet Name
n (case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Just (Let RigCount
rig Term
t Term
v) -> Term
v
Maybe (Binder Term)
other -> forall a. HasCallStack => String -> a
error (String
"Value not a let binding: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe (Binder Term)
other))
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
elab' ElabCtxt
ina Maybe FC
_ (PGoal FC
fc PTerm
r Name
n PTerm
sc) = do
Term
rty <- forall aux. Elab' aux Term
goal
forall aux. Elab' aux ()
attack
Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
forall aux. Name -> Elab' aux ()
focus Name
valn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc PTerm
r [forall {t}. t -> PArg' t
pexp (IState -> Term -> PTerm
delab IState
ist Term
rty)])
Env
env <- forall aux. Elab' aux Env
get_env
forall aux. Name -> Elab' aux ()
computeLet Name
n
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
sc
forall aux. Elab' aux ()
solve
elab' ElabCtxt
ina Maybe FC
_ tm :: PTerm
tm@(PApp FC
fc (PInferRef FC
_ [FC]
_ Name
f) [PArg]
args) = do
Term
rty <- forall aux. Elab' aux Term
goal
[Name]
ds <- forall aux. Elab' aux [Name]
get_deferred
Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
[(Name, (Bool, Raw))]
argTys <- forall {aux}.
Env -> [PArg] -> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
claimArgTys Env
env [PArg]
args
Name
fn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"inf_fn")
let fty :: Raw
fty = forall {a}. [(Name, (a, Raw))] -> Term -> Raw
fnTy [(Name, (Bool, Raw))]
argTys Term
rty
forall aux. Elab' aux ()
attack; forall aux. Name -> Raw -> [Name] -> Elab' aux ()
deferType (Name -> Name
mkN Name
f) Raw
fty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, (Bool, Raw))]
argTys); forall aux. Elab' aux ()
solve
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {b}. ((Name, (Bool, b)), PArg) -> ElabD ()
elabIArg (forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, (Bool, Raw))]
argTys [PArg]
args)
where claimArgTys :: Env -> [PArg] -> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
claimArgTys Env
env [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
claimArgTys Env
env (PArg
arg : [PArg]
xs) | Just Name
n <- Env -> PTerm -> Maybe Name
localVar Env
env (forall t. PArg' t -> t
getTm PArg
arg)
= do Term
nty <- forall aux. Raw -> Elab' aux Term
get_type (Name -> Raw
Var Name
n)
[(Name, (Bool, Raw))]
ans <- Env -> [PArg] -> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
claimArgTys Env
env [PArg]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n, (Bool
False, Term -> Raw
forget Term
nty)) forall a. a -> [a] -> [a]
: [(Name, (Bool, Raw))]
ans)
claimArgTys Env
env (PArg
_ : [PArg]
xs)
= do Name
an <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"inf_argTy")
Name
aval <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"inf_arg")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
an Raw
RType
forall aux. Name -> Raw -> Elab' aux ()
claim Name
aval (Name -> Raw
Var Name
an)
[(Name, (Bool, Raw))]
ans <- Env -> [PArg] -> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
claimArgTys Env
env [PArg]
xs
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
aval, (Bool
True, (Name -> Raw
Var Name
an))) forall a. a -> [a] -> [a]
: [(Name, (Bool, Raw))]
ans)
fnTy :: [(Name, (a, Raw))] -> Term -> Raw
fnTy [] Term
ret = Term -> Raw
forget Term
ret
fnTy ((Name
x, (a
_, Raw
xt)) : [(Name, (a, Raw))]
xs) Term
ret = Name -> Binder Raw -> Raw -> Raw
RBind Name
x (forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW forall a. Maybe a
Nothing Raw
xt Raw
RType) ([(Name, (a, Raw))] -> Term -> Raw
fnTy [(Name, (a, Raw))]
xs Term
ret)
localVar :: Env -> PTerm -> Maybe Name
localVar Env
env (PRef FC
_ [FC]
_ Name
x)
= case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
x Env
env of
Just Binder Term
_ -> forall a. a -> Maybe a
Just Name
x
Maybe (Binder Term)
_ -> forall a. Maybe a
Nothing
localVar Env
env PTerm
_ = forall a. Maybe a
Nothing
elabIArg :: ((Name, (Bool, b)), PArg) -> ElabD ()
elabIArg ((Name
n, (Bool
True, b
ty)), PArg
def) =
do forall aux. Name -> Elab' aux ()
focus Name
n; ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (forall t. PArg' t -> t
getTm PArg
def)
elabIArg ((Name, (Bool, b)), PArg)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
mkN :: Name -> Name
mkN n :: Name
n@(NS Name
_ [Text]
_) = Name
n
mkN n :: Name
n@(SN SpecialName
_) = Name
n
mkN Name
n = case ElabInfo -> [String]
namespace ElabInfo
info of
xs :: [String]
xs@(String
_:[String]
_) -> Name -> [String] -> Name
sNS Name
n [String]
xs
[String]
_ -> Name
n
elab' ElabCtxt
ina Maybe FC
_ (PMatchApp FC
fc Name
fn)
= do (Name
fn', [Bool]
imps) <- case forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
[(Name
n, [PArg]
args)] -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Bool
True) [PArg]
args)
[(Name, [PArg])]
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail (forall t. Name -> Err' t
NoSuchVariable Name
fn)
[(Name, Name)]
ns <- forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
match_apply (Name -> Raw
Var Name
fn') (forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x,Int
0)) [Bool]
imps)
forall aux. Elab' aux ()
solve
elab' ElabCtxt
ina Maybe FC
topfc tm :: PTerm
tm@(PApp FC
fc (PRef FC
ffc [FC]
hls Name
f) [PArg]
args_in)
| Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& ElabCtxt -> Bool
e_nomatching ElabCtxt
ina
= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
| Bool
otherwise = ElabD [ImplicitInfo] -> ElabD ()
implicitApp forall a b. (a -> b) -> a -> b
$
do Env
env <- forall aux. Elab' aux Env
get_env
Term
ty <- forall aux. Elab' aux Term
goal
Term
fty <- forall aux. Raw -> Elab' aux Term
get_type (Name -> Raw
Var Name
f)
Context
ctxt <- forall aux. Elab' aux Context
get_context
let dataCon :: Bool
dataCon = Name -> Context -> Bool
isDConName Name
f Context
ctxt
OutputAnnotation
annot <- Name -> ElabD OutputAnnotation
findHighlight Name
f
[Maybe Name]
knowns_m <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {t}. Monad m => PArg' t -> m (Maybe Name)
getKnownImplicit [PArg]
args_in
let knowns :: [Name]
knowns = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. a -> a
id [Maybe Name]
knowns_m
[PArg]
args <- FC -> Name -> [Name] -> Term -> [PArg] -> ElabD [PArg]
insertScopedImps FC
fc Name
f [Name]
knowns (Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
fty) [PArg]
args_in
let unmatchableArgs :: [Bool]
unmatchableArgs = if Bool
pattern
then Context -> Name -> [Bool]
getUnmatchable (IState -> Context
tt_ctxt IState
ist) Name
f
else []
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_intype ElabCtxt
ina)
Bool -> Bool -> Bool
&& Name -> Context -> Bool
isTConName Name
f (IState -> Context
tt_ctxt IState
ist)) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
if (Name
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
env Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [PArg]
args forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [PArg]
args_in forall a. Eq a => a -> a -> Bool
== Int
1)
then
do forall aux.
Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
simple_app Bool
False
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_isfn :: Bool
e_isfn = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
ffc [FC]
hls Name
f))
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True,
e_guarded :: Bool
e_guarded = Bool
dataCon }) (forall a. a -> Maybe a
Just FC
fc) (forall t. PArg' t -> t
getTm (forall a. [a] -> a
head [PArg]
args)))
(forall a. Show a => a -> String
show PTerm
tm)
forall aux. Elab' aux ()
solve
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FC -> OutputAnnotation -> ElabD ()
highlightSource) forall a b. (a -> b) -> a -> b
$
(FC
ffc, OutputAnnotation
annot) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\FC
f -> (FC
f, OutputAnnotation
annot)) [FC]
hls
forall (m :: * -> *) a. Monad m => a -> m a
return []
else
do [Name]
ivs <- forall aux. Elab' aux [Name]
get_implementations
Fails
ps <- forall aux. Elab' aux Fails
get_probs
let isinf :: Bool
isinf = Name
f forall a. Eq a => a -> a -> Bool
== Name
inferCon Bool -> Bool -> Bool
|| Name -> Bool
tcname Name
f
case forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
f (IState -> Ctxt InterfaceInfo
idris_interfaces IState
ist) of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[InterfaceInfo]
_ -> do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {aux}. PTerm -> Elab' aux ()
setInjective (forall a b. (a -> b) -> [a] -> [b]
map forall t. PArg' t -> t
getTm [PArg]
args)
forall aux. Elab' aux ()
unifyProblems
[(Name, Name)]
ns <- forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
f) (forall a b. (a -> b) -> [a] -> [b]
map PArg -> (Bool, Int)
isph [PArg]
args)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall aux. Name -> Elab' aux ()
checkIfInjective (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, Name)]
ns)
forall aux. Elab' aux ()
unifyProblems
Bool
ulog <- forall aux. Elab' aux Bool
getUnifyLog
OutputAnnotation
annot <- Name -> ElabD OutputAnnotation
findHighlight Name
f
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FC -> OutputAnnotation -> ElabD ()
highlightSource) forall a b. (a -> b) -> a -> b
$
(FC
ffc, OutputAnnotation
annot) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\FC
f -> (FC
f, OutputAnnotation
annot)) [FC]
hls
IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist (ElabCtxt
ina { e_inarg :: Bool
e_inarg = ElabCtxt -> Bool
e_inarg ElabCtxt
ina Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
isinf,
e_guarded :: Bool
e_guarded = Bool
dataCon })
[] FC
fc Bool
False Name
f
(forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, Name)]
ns ([Bool]
unmatchableArgs forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Bool
False))
(Name
f forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"Force")
(forall a b. (a -> b) -> [a] -> [b]
map (\PArg
x -> forall t. PArg' t -> t
getTm PArg
x) [PArg]
args)
[ImplicitInfo]
imp <- if (ElabCtxt -> Bool
e_isfn ElabCtxt
ina) then
do Term
guess <- forall aux. Elab' aux Term
get_guess
Env
env <- forall aux. Elab' aux Env
get_env
case [Name] -> Term -> Maybe Raw
safeForgetEnv (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
env) Term
guess of
Maybe Raw
Nothing ->
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Raw
rguess -> do
Term
gty <- forall aux. Raw -> Elab' aux Term
get_type Raw
rguess
let ty_n :: Term
ty_n = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
gty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {n}. TT n -> [ImplicitInfo]
getReqImps Term
ty_n
else forall (m :: * -> *) a. Monad m => a -> m a
return []
case [ImplicitInfo]
imp of
rs :: [ImplicitInfo]
rs@(ImplicitInfo
_:[ImplicitInfo]
_) | Bool -> Bool
not Bool
pattern -> forall (m :: * -> *) a. Monad m => a -> m a
return [ImplicitInfo]
rs
[ImplicitInfo]
_ -> do forall aux. Elab' aux ()
solve
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
[Name]
ivs' <- forall aux. Elab' aux [Name]
get_implementations
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern Bool -> Bool -> Bool
|| (ElabCtxt -> Bool
e_inarg ElabCtxt
ina Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
tcgen)) forall a b. (a -> b) -> a -> b
$
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> do forall aux. Name -> Elab' aux ()
focus Name
n
Term
g <- forall aux. Elab' aux Term
goal
Env
env <- forall aux. Elab' aux Env
get_env
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Name
n -> Bool -> Bool
not (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs)) (forall n. Eq n => TT n -> [n]
freeNames Term
g)
then forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError (ElabMode -> Err -> Bool
tcRecoverable ElabMode
emode)
(Bool
-> Bool
-> Int
-> Term
-> Name
-> (PTerm -> ElabD ())
-> IState
-> ElabD ()
resolveTC Bool
False Bool
False Int
10 Term
g Name
fn PTerm -> ElabD ()
elabRec IState
ist)
(forall aux. Name -> Elab' aux ()
movelast Name
n)
else forall aux. Name -> Elab' aux ()
movelast Name
n)
([Name]
ivs' forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
ivs)
forall (m :: * -> *) a. Monad m => a -> m a
return []
where
implicitApp :: ElabD [ImplicitInfo] -> ElabD ()
implicitApp :: ElabD [ImplicitInfo] -> ElabD ()
implicitApp ElabD [ImplicitInfo]
elab
| Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform = do ElabD [ImplicitInfo]
elab; forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do ElabState EState
s <- forall s (m :: * -> *). MonadState s m => m s
get
[ImplicitInfo]
imps <- ElabD [ImplicitInfo]
elab
case [ImplicitInfo]
imps of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[ImplicitInfo]
es -> do forall s (m :: * -> *). MonadState s m => s -> m ()
put ElabState EState
s
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
topfc (PTerm -> [ImplicitInfo] -> PTerm
PAppImpl PTerm
tm [ImplicitInfo]
es)
getKnownImplicit :: PArg' t -> m (Maybe Name)
getKnownImplicit PArg' t
imp
| ArgOpt
UnknownImp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall t. PArg' t -> [ArgOpt]
argopts PArg' t
imp
= forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall t. PArg' t -> Name
pname PArg' t
imp))
getReqImps :: TT n -> [ImplicitInfo]
getReqImps (Bind n
x (Pi RigCount
_ (Just ImplicitInfo
i) TT n
ty TT n
_) TT n
sc)
= ImplicitInfo
i forall a. a -> [a] -> [a]
: TT n -> [ImplicitInfo]
getReqImps TT n
sc
getReqImps TT n
_ = []
checkIfInjective :: Name -> StateT (ElabState aux) TC ()
checkIfInjective Name
n = do
Env
env <- forall aux. Elab' aux Env
get_env
case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Maybe (Binder Term)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Binder Term
b ->
case forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env (forall b. Binder b -> b
binderTy Binder Term
b)) of
(P NameType
_ Name
c Term
_, [Term]
args) ->
case forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
c (IState -> Ctxt InterfaceInfo
idris_interfaces IState
ist) of
Maybe InterfaceInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just InterfaceInfo
ci ->
do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {aux}. Term -> Elab' aux ()
setinjArg (forall {t :: * -> *} {t} {a}.
(Foldable t, Eq t, Num t) =>
t -> t t -> [a] -> [a]
getDets Int
0 (InterfaceInfo -> [Int]
interface_determiners InterfaceInfo
ci) [Term]
args)
Bool
ulog <- forall aux. Elab' aux Bool
getUnifyLog
Fails
probs <- forall aux. Elab' aux Fails
get_probs
[Name]
inj <- forall aux. Elab' aux [Name]
get_inj
forall {a}. Bool -> String -> a -> a
traceWhen Bool
ulog (String
"Injective now " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Term]
args forall a. [a] -> [a] -> [a]
++ String
"\nAll: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Name]
inj
forall a. [a] -> [a] -> [a]
++ String
"\nProblems: " forall a. [a] -> [a] -> [a]
++ Fails -> String
qshow Fails
probs) forall a b. (a -> b) -> a -> b
$
forall aux. Elab' aux ()
unifyProblems
Fails
probs <- forall aux. Elab' aux Fails
get_probs
forall {a}. Bool -> String -> a -> a
traceWhen Bool
ulog (Fails -> String
qshow Fails
probs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Term, [Term])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
setinjArg :: Term -> Elab' aux ()
setinjArg (P NameType
_ Name
n Term
_) = forall aux. Name -> Elab' aux ()
setinj Name
n
setinjArg Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
getDets :: t -> t t -> [a] -> [a]
getDets t
i t t
ds [] = []
getDets t
i t t
ds (a
a : [a]
as) | t
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t t
ds = a
a forall a. a -> [a] -> [a]
: t -> t t -> [a] -> [a]
getDets (t
i forall a. Num a => a -> a -> a
+ t
1) t t
ds [a]
as
| Bool
otherwise = t -> t t -> [a] -> [a]
getDets (t
i forall a. Num a => a -> a -> a
+ t
1) t t
ds [a]
as
setInjective :: PTerm -> Elab' aux ()
setInjective (PRef FC
_ [FC]
_ Name
n) = forall aux. Name -> Elab' aux ()
setinj Name
n
setInjective (PApp FC
_ (PRef FC
_ [FC]
_ Name
n) [PArg]
_) = forall aux. Name -> Elab' aux ()
setinj Name
n
setInjective PTerm
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
elab' ElabCtxt
ina Maybe FC
_ tm :: PTerm
tm@(PApp FC
fc PTerm
f [PArg
arg]) =
forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc forall a b. (a -> b) -> a -> b
$
do forall aux.
Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
simple_app (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ PTerm -> Bool
headRef PTerm
f)
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_isfn :: Bool
e_isfn = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
f)
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) (forall t. PArg' t -> t
getTm PArg
arg))
(forall a. Show a => a -> String
show PTerm
tm)
forall aux. Elab' aux ()
solve
where headRef :: PTerm -> Bool
headRef (PRef FC
_ [FC]
_ Name
_) = Bool
True
headRef (PApp FC
_ PTerm
f [PArg]
_) = PTerm -> Bool
headRef PTerm
f
headRef (PAlternative [(Name, Name)]
_ PAltType
_ [PTerm]
as) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PTerm -> Bool
headRef [PTerm]
as
headRef PTerm
_ = Bool
False
elab' ElabCtxt
ina Maybe FC
fc (PAppImpl PTerm
f [ImplicitInfo]
es) = do forall {a}. [a] -> ElabD ()
appImpl (forall a. [a] -> [a]
reverse [ImplicitInfo]
es)
forall aux. Elab' aux ()
solve
where appImpl :: [a] -> ElabD ()
appImpl [] = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' (ElabCtxt
ina { e_isfn :: Bool
e_isfn = Bool
False }) Maybe FC
fc PTerm
f
appImpl (a
e : [a]
es) = forall aux.
Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
simple_app Bool
False
([a] -> ElabD ()
appImpl [a]
es)
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder)
(forall a. Show a => a -> String
show PTerm
f)
elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder
= do ~(Name
h : [Name]
hs) <- forall aux. Elab' aux [Name]
get_holes
forall aux. Name -> Elab' aux ()
movelast Name
h
elab' ElabCtxt
ina Maybe FC
fc (PMetavar FC
nfc Name
n) =
do Term
ptm <- forall aux. Elab' aux Term
get_term
Env
env <- forall aux. Elab' aux Env
get_env
let unique_used :: [Name]
unique_used = Context -> Term -> [Name]
getUniqueUsed (IState -> Context
tt_ctxt IState
ist) Term
ptm
let lin_used :: [Name]
lin_used = Context -> Term -> [Name]
getLinearUsed (IState -> Context
tt_ctxt IState
ist) Term
ptm
let n' :: Name
n' = [String] -> Name -> Name
metavarName (ElabInfo -> [String]
namespace ElabInfo
info) Name
n
forall aux. Elab' aux ()
attack
[Name]
psns <- forall aux. Elab' aux [Name]
getPSnames
Name
n' <- forall aux. [Name] -> [Name] -> Name -> Elab' aux Name
defer [Name]
unique_used [Name]
lin_used Name
n'
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n' (forall a. a -> Maybe a
Just NameOutput
MetavarOutput) forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
elab' ElabCtxt
ina Maybe FC
fc (PProof [PTactic]
ts) = do forall aux. Elab' aux ()
compute; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
True IState
ist (ElabInfo -> Maybe FC
elabFC ElabInfo
info) Name
fn) [PTactic]
ts
elab' ElabCtxt
ina Maybe FC
fc (PTactics [PTactic]
ts)
| Bool -> Bool
not Bool
pattern = do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
False IState
ist Maybe FC
fc Name
fn) [PTactic]
ts
| Bool
otherwise = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder
elab' ElabCtxt
ina Maybe FC
fc (PElabError Err
e) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail Err
e
elab' ElabCtxt
ina Maybe FC
mfc (PRewrite FC
fc Maybe Name
substfn PTerm
rule PTerm
sc Maybe PTerm
newg)
= (PTerm -> ElabD ())
-> IState
-> FC
-> Maybe Name
-> PTerm
-> PTerm
-> Maybe PTerm
-> ElabD ()
elabRewrite (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
mfc) IState
ist FC
fc Maybe Name
substfn PTerm
rule PTerm
sc Maybe PTerm
newg
elab' ElabCtxt
ina Maybe FC
_ c :: PTerm
c@(PCase FC
fc PTerm
Placeholder [(PTerm, PTerm)]
opts)
= forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail (forall t. String -> Err' t
Msg String
"No expression for the case to inspect.\nYou need to replace the _ with an expression.")
elab' ElabCtxt
ina Maybe FC
_ c :: PTerm
c@(PCase FC
fc PTerm
scr [(PTerm, PTerm)]
opts)
= do forall aux. Elab' aux ()
attack
Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scval")
Name
scvn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scvar")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Env
env <- forall aux. Elab' aux Env
get_env
let scrnames :: [Name]
scrnames = PTerm -> [Name]
allNamesIn PTerm
scr
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
scvn (forall {t :: * -> *} {a} {c}.
(Foldable t, Eq a) =>
t a -> [(a, RigCount, c)] -> RigCount
letrig [Name]
scrnames Env
env) (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
let scrTy :: Maybe PTerm
scrTy = [PTerm] -> Maybe PTerm
getScrType (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(PTerm, PTerm)]
opts)
case Maybe PTerm
scrTy of
Maybe PTerm
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PTerm
ty -> do forall aux. Name -> Elab' aux ()
focus Name
tyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) PTerm
ty
forall aux. Name -> Elab' aux ()
focus Name
valn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
scr
forall aux. Elab' aux ()
unifyProblems
forall aux. Bool -> Elab' aux ()
matchProblems Bool
True
Env
args <- forall aux. Elab' aux Env
get_env
[(Name, Bool)]
envU <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {b} {c} {aux}.
Env -> (Name, b, c) -> StateT (ElabState aux) TC (Name, Bool)
getKind Env
args) Env
args
Term
ptm <- forall aux. Elab' aux Term
get_term
let inOpts :: [Name]
inOpts = (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Name
scvn) (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
args)) forall a. Eq a => [a] -> [a] -> [a]
\\ (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PTerm, PTerm)
x -> PTerm -> [Name]
allNamesIn (forall a b. (a, b) -> b
snd (PTerm, PTerm)
x)) [(PTerm, PTerm)]
opts)
let argsDropped :: [Name]
argsDropped = forall a. (a -> Bool) -> [a] -> [a]
filter (\Name
t -> forall {a}. Eq a => [(a, Bool)] -> a -> Bool
isUnique [(Name, Bool)]
envU Name
t Bool -> Bool -> Bool
|| Env -> Name -> Bool
isNotLift Env
args Name
t)
(forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ [Name]
scrnames forall a. [a] -> [a] -> [a]
++ forall {a}. TT a -> [a]
inApp Term
ptm forall a. [a] -> [a] -> [a]
++
[Name]
inOpts)
let lin_used :: [Name]
lin_used = Context -> Term -> [Name]
getLinearUsed (IState -> Context
tt_ctxt IState
ist) Term
ptm
let args' :: Env
args' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name
n, RigCount
_, Binder Term
_) -> Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
argsDropped) Env
args
forall aux. Elab' aux ()
attack
Name
cname' <- forall aux. [Name] -> [Name] -> Name -> Elab' aux Name
defer [Name]
argsDropped [Name]
lin_used (Name -> Name
mkN (FC -> Name -> Name
mkCaseName FC
fc Name
fn))
forall aux. Elab' aux ()
solve
let newdef :: PDecl
newdef = forall t. FC -> FnOpts -> Name -> [PClause' t] -> PDecl' t
PClauses FC
fc [] Name
cname'
(FC
-> Name
-> PTerm
-> [(Name, (Bool, Binder Term))]
-> [(PTerm, PTerm)]
-> [PClause]
caseBlock FC
fc Name
cname' PTerm
scr
(forall a b. (a -> b) -> [a] -> [b]
map (PTerm
-> (Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term))
isScr PTerm
scr) (forall a. [a] -> [a]
reverse Env
args')) [(PTerm, PTerm)]
opts)
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
e -> EState
e { case_decls :: [(Name, PDecl)]
case_decls = (Name
cname', PDecl
newdef) forall a. a -> [a] -> [a]
: EState -> [(Name, PDecl)]
case_decls EState
e } )
forall aux. Name -> Elab' aux ()
movelast Name
tyn
forall aux. Elab' aux ()
solve
where mkCaseName :: FC -> Name -> Name
mkCaseName FC
fc (NS Name
n [Text]
ns) = Name -> [Text] -> Name
NS (FC -> Name -> Name
mkCaseName FC
fc Name
n) [Text]
ns
mkCaseName FC
fc Name
n = SpecialName -> Name
SN (FC' -> Name -> SpecialName
CaseN (FC -> FC'
FC' FC
fc) Name
n)
mkN :: Name -> Name
mkN n :: Name
n@(NS Name
_ [Text]
_) = Name
n
mkN Name
n = case ElabInfo -> [String]
namespace ElabInfo
info of
xs :: [String]
xs@(String
_:[String]
_) -> Name -> [String] -> Name
sNS Name
n [String]
xs
[String]
_ -> Name
n
letrig :: t a -> [(a, RigCount, c)] -> RigCount
letrig t a
ns [] = RigCount
RigW
letrig t a
ns [(a, RigCount, c)]
env = forall {t :: * -> *} {a} {c}.
(Foldable t, Eq a) =>
RigCount -> t a -> [(a, RigCount, c)] -> RigCount
letrig' RigCount
Rig1 t a
ns [(a, RigCount, c)]
env
letrig' :: RigCount -> t a -> [(a, RigCount, c)] -> RigCount
letrig' RigCount
def t a
ns [] = RigCount
def
letrig' RigCount
def t a
ns ((a
n, RigCount
r, c
_) : [(a, RigCount, c)]
env)
| a
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
ns = RigCount -> t a -> [(a, RigCount, c)] -> RigCount
letrig' (RigCount -> RigCount -> RigCount
rigMult RigCount
def RigCount
r) t a
ns [(a, RigCount, c)]
env
| Bool
otherwise = RigCount -> t a -> [(a, RigCount, c)] -> RigCount
letrig' RigCount
def t a
ns [(a, RigCount, c)]
env
getScrType :: [PTerm] -> Maybe PTerm
getScrType [] = forall a. Maybe a
Nothing
getScrType (PTerm
f : [PTerm]
os) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([PTerm] -> Maybe PTerm
getScrType [PTerm]
os) forall a. a -> Maybe a
Just (PTerm -> Maybe PTerm
getAppType PTerm
f)
getAppType :: PTerm -> Maybe PTerm
getAppType (PRef FC
_ [FC]
_ Name
n) =
case Name -> Context -> [(Name, Term)]
lookupTyName Name
n (IState -> Context
tt_ctxt IState
ist) of
[(Name
n', Term
ty)] | Name -> Context -> Bool
isDConName Name
n' (IState -> Context
tt_ctxt IState
ist) ->
case forall n. TT n -> (TT n, [TT n])
unApply (forall n. TT n -> TT n
getRetTy Term
ty) of
(P NameType
_ Name
tyn Term
_, [Term]
args) ->
forall a. a -> Maybe a
Just (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
tyn)
(forall a b. (a -> b) -> [a] -> [b]
map forall {t}. t -> PArg' t
pexp (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const PTerm
Placeholder) [Term]
args)))
(Term, [Term])
_ -> forall a. Maybe a
Nothing
[(Name, Term)]
_ -> forall a. Maybe a
Nothing
getAppType (PApp FC
_ PTerm
t [PArg]
as) = PTerm -> Maybe PTerm
getAppType PTerm
t
getAppType PTerm
_ = forall a. Maybe a
Nothing
inApp :: TT a -> [a]
inApp (P NameType
_ a
n TT a
_) = [a
n]
inApp (App AppStatus a
_ TT a
f TT a
a) = TT a -> [a]
inApp TT a
f forall a. [a] -> [a] -> [a]
++ TT a -> [a]
inApp TT a
a
inApp (Bind a
n (Let RigCount
_ TT a
_ TT a
v) TT a
sc) = TT a -> [a]
inApp TT a
v forall a. [a] -> [a] -> [a]
++ TT a -> [a]
inApp TT a
sc
inApp (Bind a
n (Guess TT a
_ TT a
v) TT a
sc) = TT a -> [a]
inApp TT a
v forall a. [a] -> [a] -> [a]
++ TT a -> [a]
inApp TT a
sc
inApp (Bind a
n Binder (TT a)
b TT a
sc) = TT a -> [a]
inApp TT a
sc
inApp TT a
_ = []
isUnique :: [(a, Bool)] -> a -> Bool
isUnique [(a, Bool)]
envk a
n = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
n [(a, Bool)]
envk of
Just Bool
u -> Bool
u
Maybe Bool
_ -> Bool
False
getKind :: Env -> (Name, b, c) -> StateT (ElabState aux) TC (Name, Bool)
getKind Env
env (Name
n, b
_, c
_)
= case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Maybe (Binder Term)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
False)
Just Binder Term
b ->
do Term
ty <- forall aux. Raw -> Elab' aux Term
get_type (Term -> Raw
forget (forall b. Binder b -> b
binderTy Binder Term
b))
case Term
ty of
UType Universe
UniqueType -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
True)
UType Universe
AllTypes -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
True)
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
False)
isNotLift :: Env -> Name -> Bool
isNotLift Env
env Name
n
= case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Just Binder Term
ty ->
case forall n. TT n -> (TT n, [TT n])
unApply (forall b. Binder b -> b
binderTy Binder Term
ty) of
(P NameType
_ Name
n Term
_, [Term]
_) -> Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ElabInfo -> [Name]
noCaseLift ElabInfo
info
(Term, [Term])
_ -> Bool
False
Maybe (Binder Term)
_ -> Bool
False
elab' ElabCtxt
ina Maybe FC
fc (PUnifyLog PTerm
t) = do forall aux. Bool -> Elab' aux ()
unifyLog Bool
True
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
forall aux. Bool -> Elab' aux ()
unifyLog Bool
False
elab' ElabCtxt
ina Maybe FC
fc (PQuasiquote PTerm
t Maybe PTerm
goalt)
= do
Term
finalTy <- forall aux. Elab' aux Term
goal
(PTerm
t, [(Name, PTerm)]
unq) <- forall aux. Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])
extractUnquotes Int
0 PTerm
t
let unquoteNames :: [Name]
unquoteNames = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, PTerm)]
unq
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
uqn -> forall aux. Name -> Raw -> Elab' aux ()
claim Name
uqn (Term -> Raw
forget Term
finalTy)) [Name]
unquoteNames
Context
ctxt <- forall aux. Elab' aux Context
get_context
Ctxt TypeInfo
datatypes <- forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
Int
g_nextname <- forall aux. Elab' aux Int
get_global_nextname
forall aux. Elab' aux ()
saveState
forall aux. (ProofState -> ProofState) -> Elab' aux ()
updatePS (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Name
-> String -> Context -> Ctxt TypeInfo -> Int -> Term -> ProofState
newProof (Int -> String -> Name
sMN Int
0 String
"q") (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt Ctxt TypeInfo
datatypes Int
g_nextname forall a b. (a -> b) -> a -> b
$
forall n. NameType -> n -> TT n -> TT n
P NameType
Ref (String -> Name
reflm String
"TT") forall n. TT n
Erased)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> do Name
ty <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"unqTy")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
ty Raw
RType
forall aux. Name -> Elab' aux ()
movelast Name
ty
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n (Name -> Raw
Var Name
ty)
forall aux. Name -> Elab' aux ()
movelast Name
n)
[Name]
unquoteNames
Name
qTy <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"qquoteTy")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
qTy Raw
RType
forall aux. Name -> Elab' aux ()
movelast Name
qTy
Name
qTm <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"qquoteTm")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
qTm (Name -> Raw
Var Name
qTy)
Name
nTm <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"quotedTerm")
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
nTm RigCount
RigW (Name -> Raw
Var Name
qTy) (Name -> Raw
Var Name
qTm)
case Maybe PTerm
goalt of
Maybe PTerm
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PTerm
gTy -> do forall aux. Name -> Elab' aux ()
focus Name
qTy
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_qq :: Bool
e_qq = Bool
True }) Maybe FC
fc PTerm
gTy
forall aux. Name -> Elab' aux ()
focus Name
qTm
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_qq :: Bool
e_qq = Bool
True }) Maybe FC
fc PTerm
t
forall aux. Elab' aux ()
end_unify
Env
env <- forall aux. Elab' aux Env
get_env
EState [(Name, PDecl)]
_ [(Int, ElabD ())]
_ [RDeclInstructions]
_ Set (FC', OutputAnnotation)
hs [Name]
_ [(FC, Name)]
_ <- forall aux. Elab' aux aux
getAux
forall aux. Elab' aux ()
loadState
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
aux -> EState
aux { highlighting :: Set (FC', OutputAnnotation)
highlighting = Set (FC', OutputAnnotation)
hs })
let quoted :: Maybe Term
quoted = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall n. TT n -> TT n
explicitNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Binder b -> b
binderVal) forall a b. (a -> b) -> a -> b
$ forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
nTm Env
env
isRaw :: Bool
isRaw = case forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env Term
finalTy) of
(P NameType
_ Name
n Term
_, []) | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
reflm String
"Raw" -> Bool
True
(Term, [Term])
_ -> Bool
False
case Maybe Term
quoted of
Just Term
q -> do Context
ctxt <- forall aux. Elab' aux Context
get_context
(Term
q', Term
_, UCs
_) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> Context -> Env -> Raw -> Term -> TC (Term, Term, UCs)
recheck (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt [(Name
uq, RigCount
RigW, forall b. RigCount -> b -> Binder b
Lam RigCount
RigW forall n. TT n
Erased) | Name
uq <- [Name]
unquoteNames] (Term -> Raw
forget Term
q) Term
q
if Bool
pattern
then if Bool
isRaw
then [Name] -> Raw -> ElabD ()
reflectRawQuotePattern [Name]
unquoteNames (Term -> Raw
forget Term
q')
else [Name] -> Term -> ElabD ()
reflectTTQuotePattern [Name]
unquoteNames Term
q'
else do if Bool
isRaw
then
forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ [Name] -> Raw -> Raw
reflectRawQuote [Name]
unquoteNames (Term -> Raw
forget Term
q')
else forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ [Name] -> Term -> Raw
reflectTTQuote [Name]
unquoteNames Term
q'
forall aux. Elab' aux ()
solve
Maybe Term
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Broken elaboration of quasiquote"
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, PTerm) -> ElabD ()
elabUnquote [(Name, PTerm)]
unq
where elabUnquote :: (Name, PTerm) -> ElabD ()
elabUnquote (Name
n, PTerm
tm)
= do forall aux. Name -> Elab' aux ()
focus Name
n
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_qq :: Bool
e_qq = Bool
False }) Maybe FC
fc PTerm
tm
elab' ElabCtxt
ina Maybe FC
fc (PUnquote PTerm
t) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Found unquote outside of quasiquote"
elab' ElabCtxt
ina Maybe FC
fc (PQuoteName Name
n Bool
False FC
nfc) =
do forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n
forall aux. Elab' aux ()
solve
elab' ElabCtxt
ina Maybe FC
fc (PQuoteName Name
n Bool
True FC
nfc) =
do Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Just Binder Term
_ -> do forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
Maybe (Binder Term)
Nothing ->
case Name -> Context -> [(Name, Def)]
lookupNameDef Name
n Context
ctxt of
[(Name
n', Def
_)] -> do forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n'
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n' forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
[] -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Name -> Err' t
NoSuchVariable forall a b. (a -> b) -> a -> b
$ Name
n
[(Name, Def)]
more -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. [Name] -> Err' t
CantResolveAlts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, Def)]
more
elab' ElabCtxt
ina Maybe FC
fc (PAs FC
_ Name
n PTerm
t) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"@-pattern not allowed here"
elab' ElabCtxt
ina Maybe FC
fc (PHidden PTerm
t)
| Bool
reflection = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
| Bool
otherwise
= do ~(Name
h : [Name]
hs) <- forall aux. Elab' aux [Name]
get_holes
forall aux. Name -> Elab' aux ()
movelast Name
h
~(Name
h' : [Name]
hs) <- forall aux. Elab' aux [Name]
get_holes
if Name
h forall a. Eq a => a -> a -> Bool
== Name
h' then Name -> ElabD ()
elabHidden Name
h
else Int -> ElabD () -> ElabD ()
delayElab Int
10 forall a b. (a -> b) -> a -> b
$ Name -> ElabD ()
elabHidden Name
h
where
elabHidden :: Name -> ElabD ()
elabHidden Name
h = do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
h forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$ do
forall aux. Name -> Elab' aux ()
focus Name
h
forall aux. Elab' aux ()
dotterm
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
elab' ElabCtxt
ina Maybe FC
fc (PRunElab FC
fc' PTerm
tm [String]
ns) =
do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
ElabReflection forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist) forall a b. (a -> b) -> a -> b
$
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
fc' (forall t. String -> Err' t
Msg String
"You must turn on the ElabReflection extension to use %runElab")
forall aux. Elab' aux ()
attack
let elabName :: Name
elabName = Name -> [String] -> Name
sNS (String -> Name
sUN String
"Elab") [String
"Elab", String
"Reflection", String
"Language"]
Name
n <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"tacticScript")
let scriptTy :: Raw
scriptTy = Raw -> Raw -> Raw
RApp (Name -> Raw
Var Name
elabName) (Name -> Raw
Var Name
unitTy)
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n Raw
scriptTy
forall aux. Name -> Elab' aux ()
focus Name
n
Term
elabUnit <- forall aux. Elab' aux Term
goal
forall aux. Elab' aux ()
attack
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc') PTerm
tm
Term
script <- forall aux. Elab' aux Term
get_guess
Term -> ElabD ()
fullyElaborated Term
script
forall aux. Elab' aux ()
solve
Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
(Term
scriptTm, Term
scriptTy) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] (Term -> Raw
forget Term
script)
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term -> TC ()
converts Context
ctxt Env
env Term
elabUnit Term
scriptTy
Env
env <- forall aux. Elab' aux Env
get_env
ElabInfo -> IState -> FC -> Env -> Term -> [String] -> ElabD Term
runElabAction ElabInfo
info IState
ist (forall b a. b -> (a -> b) -> Maybe a -> b
maybe FC
fc' forall a. a -> a
id Maybe FC
fc) Env
env Term
script [String]
ns
forall aux. Elab' aux ()
solve
elab' ElabCtxt
ina Maybe FC
fc (PConstSugar FC
constFC PTerm
tm) =
do forall aux. Elab' aux ()
saveState
Name
n <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"cstI")
Name
n' <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"cstIhole")
Raw
g <- Term -> Raw
forget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall aux. Elab' aux Term
goal
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n' Raw
g
forall aux. Name -> Elab' aux ()
movelast Name
n'
forall aux. Elab' aux ()
attack
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n RigCount
RigW Raw
g (Name -> Raw
Var Name
n')
forall aux. Name -> Elab' aux ()
focus Name
n'
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
tm
Env
env <- forall aux. Elab' aux Env
get_env
Context
ctxt <- forall aux. Elab' aux Context
get_context
let v :: Maybe Term
v = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Eq n => TT n -> TT n
finalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Binder b -> b
binderVal)
(forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env)
forall aux. Elab' aux ()
loadState
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
tm
case Maybe Term
v of
Just Term
val -> FC -> Term -> ElabD ()
highlightConst FC
constFC Term
val
Maybe Term
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
where highlightConst :: FC -> Term -> ElabD ()
highlightConst FC
fc (P NameType
_ Name
n Term
_) =
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
highlightConst FC
fc (App AppStatus Name
_ Term
f Term
_) =
FC -> Term -> ElabD ()
highlightConst FC
fc Term
f
highlightConst FC
fc (Constant Const
c) =
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Const -> OutputAnnotation
AnnConst Const
c)
highlightConst FC
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unelaboratable syntactic form " forall a. [a] -> [a] -> [a]
++ PTerm -> String
showTmImpls PTerm
x
delayElab :: Int -> ElabD () -> ElabD ()
delayElab Int
pri ElabD ()
t
= forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
e -> EState
e { delayed_elab :: [(Int, ElabD ())]
delayed_elab = EState -> [(Int, ElabD ())]
delayed_elab EState
e forall a. [a] -> [a] -> [a]
++ [(Int
pri, ElabD ()
t)] })
isScr :: PTerm -> (Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term))
isScr :: PTerm
-> (Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term))
isScr (PRef FC
_ [FC]
_ Name
n) (Name
n', RigCount
RigW, Binder Term
b) = (Name
n', (Name
n forall a. Eq a => a -> a -> Bool
== Name
n', Binder Term
b))
isScr PTerm
_ (Name
n', RigCount
_, Binder Term
b) = (Name
n', (Bool
False, Binder Term
b))
caseBlock :: FC -> Name
-> PTerm
-> [(Name, (Bool, Binder Term))] -> [(PTerm, PTerm)] -> [PClause]
caseBlock :: FC
-> Name
-> PTerm
-> [(Name, (Bool, Binder Term))]
-> [(PTerm, PTerm)]
-> [PClause]
caseBlock FC
fc Name
n PTerm
scr [(Name, (Bool, Binder Term))]
env [(PTerm, PTerm)]
opts
= let args' :: [(Name, (Bool, Binder Term))]
args' = forall {a} {b}. [(a, (Bool, b))] -> [(a, (Bool, b))]
findScr [(Name, (Bool, Binder Term))]
env
args :: [(PTerm, Bool)]
args = forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (Name, b) -> (PTerm, b)
mkarg (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {b}. (a, (b, b)) -> (a, b)
getNmScr [(Name, (Bool, Binder Term))]
args') in
forall a b. (a -> b) -> [a] -> [b]
map ([(PTerm, Bool)] -> (PTerm, PTerm) -> PClause
mkClause [(PTerm, Bool)]
args) [(PTerm, PTerm)]
opts
where
findScr :: [(a, (Bool, b))] -> [(a, (Bool, b))]
findScr ((a
n, (Bool
True, b
t)) : [(a, (Bool, b))]
xs)
= (a
n, (Bool
True, b
t)) forall a. a -> [a] -> [a]
: forall {t} {b}. t -> [(t, b)] -> [(t, b)]
scrName a
n [(a, (Bool, b))]
xs
findScr [(a
n, (Bool
_, b
t))] = [(a
n, (Bool
True, b
t))]
findScr ((a, (Bool, b))
x : [(a, (Bool, b))]
xs) = (a, (Bool, b))
x forall a. a -> [a] -> [a]
: [(a, (Bool, b))] -> [(a, (Bool, b))]
findScr [(a, (Bool, b))]
xs
findScr [] = forall a. HasCallStack => String -> a
error String
"The impossible happened - the scrutinee was not in the environment"
scrName :: t -> [(t, b)] -> [(t, b)]
scrName t
n [] = []
scrName t
n [(t
_, b
t)] = [(t
n, b
t)]
scrName t
n ((t, b)
x : [(t, b)]
xs) = (t, b)
x forall a. a -> [a] -> [a]
: t -> [(t, b)] -> [(t, b)]
scrName t
n [(t, b)]
xs
getNmScr :: (a, (b, b)) -> (a, b)
getNmScr (a
n, (b
s, b
_)) = (a
n, b
s)
mkarg :: (Name, b) -> (PTerm, b)
mkarg (Name
n, b
s) = (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
n, b
s)
mkClause :: [(PTerm, Bool)] -> (PTerm, PTerm) -> PClause
mkClause [(PTerm, Bool)]
args (PTerm
l, PTerm
r)
= let args' :: [(PTerm, Bool)]
args' = forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {b}.
Foldable t =>
t Name -> (PTerm, b) -> (PTerm, b)
shadowed (PTerm -> [Name]
allNamesIn PTerm
l)) [(PTerm, Bool)]
args
args'' :: [(PTerm, Bool)]
args'' = forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {b}.
Foldable t =>
t Name -> (PTerm, b) -> (PTerm, b)
implicitable (PTerm -> [Name]
allNamesIn PTerm
r forall a. [a] -> [a] -> [a]
++
PTerm -> [Name]
keepscrName PTerm
scr)) [(PTerm, Bool)]
args'
lhs :: PTerm
lhs = FC -> PTerm -> [PArg] -> PTerm
PApp (FC -> PTerm -> FC
getFC FC
fc PTerm
l) (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
n)
(forall a b. (a -> b) -> [a] -> [b]
map (forall {t}. t -> (t, Bool) -> PArg' t
mkLHSarg PTerm
l) [(PTerm, Bool)]
args'') in
forall t. FC -> Name -> t -> [t] -> t -> [PDecl' t] -> PClause' t
PClause (FC -> PTerm -> FC
getFC FC
fc PTerm
l) Name
n PTerm
lhs [] PTerm
r []
keepscrName :: PTerm -> [Name]
keepscrName (PRef FC
_ [FC]
_ Name
n) = [Name
n]
keepscrName PTerm
_ = []
mkLHSarg :: t -> (t, Bool) -> PArg' t
mkLHSarg t
l (t
tm, Bool
True) = forall {t}. t -> PArg' t
pexp t
l
mkLHSarg t
l (t
tm, Bool
False) = forall {t}. t -> PArg' t
pexp t
tm
shadowed :: t Name -> (PTerm, b) -> (PTerm, b)
shadowed t Name
new (PRef FC
_ [FC]
_ Name
n, b
s) | Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Name
new = (PTerm
Placeholder, b
s)
shadowed t Name
new (PTerm, b)
t = (PTerm, b)
t
implicitable :: t Name -> (PTerm, b) -> (PTerm, b)
implicitable t Name
rhs (PRef FC
_ [FC]
_ Name
n, b
s) | Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t Name
rhs = (PTerm
Placeholder, b
s)
implicitable t Name
rhs (PTerm, b)
t = (PTerm, b)
t
getFC :: FC -> PTerm -> FC
getFC FC
d (PApp FC
fc PTerm
_ [PArg]
_) = FC
fc
getFC FC
d (PRef FC
fc [FC]
_ Name
_) = FC
fc
getFC FC
d (PAlternative [(Name, Name)]
_ PAltType
_ (PTerm
x:[PTerm]
_)) = FC -> PTerm -> FC
getFC FC
d PTerm
x
getFC FC
d PTerm
x = FC
d
fullyElaborated :: Term -> ElabD ()
fullyElaborated :: Term -> ElabD ()
fullyElaborated (P NameType
_ Name
n Term
_) =
do EState
estate <- forall aux. Elab' aux aux
getAux
case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n (EState -> [(Name, PDecl)]
case_decls EState
estate) of
Maybe PDecl
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PDecl
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. Name -> Err' t
ElabScriptStaging Name
n
fullyElaborated (Bind Name
n Binder Term
b Term
body) = Term -> ElabD ()
fullyElaborated Term
body forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Binder Term
b Term -> ElabD ()
fullyElaborated
fullyElaborated (App AppStatus Name
_ Term
l Term
r) = Term -> ElabD ()
fullyElaborated Term
l forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Term -> ElabD ()
fullyElaborated Term
r
fullyElaborated (Proj Term
t Int
_) = Term -> ElabD ()
fullyElaborated Term
t
fullyElaborated Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertLazy :: ElabCtxt -> PTerm -> ElabD PTerm
insertLazy :: ElabCtxt -> PTerm -> ElabD PTerm
insertLazy ElabCtxt
ina t :: PTerm
t@(PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg]
_) | Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delay" = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertLazy ElabCtxt
ina t :: PTerm
t@(PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg]
_) | Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Force" = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertLazy ElabCtxt
ina (PCoerced PTerm
t) = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertLazy ElabCtxt
ina t :: PTerm
t@(PPatvar FC
_ Name
_) | Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_guarded ElabCtxt
ina) = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertLazy ElabCtxt
ina PTerm
t =
do Term
ty <- forall aux. Elab' aux Term
goal
Env
env <- forall aux. Elab' aux Env
get_env
let (Term
tyh, [Term]
_) = forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty)
let tries :: [PTerm]
tries = [forall {b} {c}. [(Name, b, c)] -> PTerm -> PTerm
mkDelay Env
env PTerm
t, PTerm
t]
case Term
tyh of
P NameType
_ (UN Text
l) Term
_ | Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed"
-> forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [] PAltType
FirstSuccess [PTerm]
tries)
Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
where
mkDelay :: [(Name, b, c)] -> PTerm -> PTerm
mkDelay [(Name, b, c)]
env (PAlternative [(Name, Name)]
ms PAltType
b [PTerm]
xs) = [(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms PAltType
b (forall a b. (a -> b) -> [a] -> [b]
map ([(Name, b, c)] -> PTerm -> PTerm
mkDelay [(Name, b, c)]
env) [PTerm]
xs)
mkDelay [(Name, b, c)]
env PTerm
t
= let fc :: FC
fc = String -> FC
fileFC String
"Delay" in
IState -> [Name] -> PTerm -> PTerm
addImplBound IState
ist (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv [(Name, b, c)]
env) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] (String -> Name
sUN String
"Delay"))
[forall {t}. t -> PArg' t
pexp PTerm
t])
notImplicitable :: PTerm -> Bool
notImplicitable (PApp FC
_ PTerm
f [PArg]
_) = PTerm -> Bool
notImplicitable PTerm
f
notImplicitable (PRef FC
_ [FC]
_ Name
n)
| [FnOpts
opts] <- forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
n (IState -> Ctxt FnOpts
idris_flags IState
ist)
= FnOpt
NoImplicit forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts
notImplicitable (PAlternative [(Name, Name)]
_ PAltType
_ [PTerm]
as) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PTerm -> Bool
notImplicitable [PTerm]
as
notImplicitable (PCase FC
_ PTerm
_ [(PTerm, PTerm)]
_) = Bool
True
notImplicitable PTerm
_ = Bool
False
expandToArity :: PTerm -> StateT (ElabState aux) TC PTerm
expandToArity tm :: PTerm
tm@(PApp FC
fc PTerm
f [PArg]
a) = do
Env
env <- forall aux. Elab' aux Env
get_env
case PTerm -> PTerm
fullApp PTerm
tm of
PApp FC
fc ftm :: PTerm
ftm@(PRef FC
_ [FC]
_ Name
f) [PArg]
args | Just Binder Term
aty <- forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
f Env
env ->
do let a :: Int
a = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env (forall b. Binder b -> b
binderTy Binder Term
aty)))
forall (m :: * -> *) a. Monad m => a -> m a
return (FC -> Int -> PTerm -> [PArg] -> PTerm
mkPApp FC
fc Int
a PTerm
ftm [PArg]
args)
PTerm
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
tm
expandToArity PTerm
t = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
fullApp :: PTerm -> PTerm
fullApp (PApp FC
_ (PApp FC
fc PTerm
f [PArg]
args) [PArg]
xs) = PTerm -> PTerm
fullApp (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc PTerm
f ([PArg]
args forall a. [a] -> [a] -> [a]
++ [PArg]
xs))
fullApp PTerm
x = PTerm
x
findImplicit :: Name -> [PArg] -> (Maybe PArg, [PArg])
findImplicit :: Name -> [PArg] -> (Maybe PArg, [PArg])
findImplicit Name
n [] = (forall a. Maybe a
Nothing, [])
findImplicit Name
n (i :: PArg
i@(PImp Int
_ Bool
_ [ArgOpt]
_ Name
n' PTerm
_) : [PArg]
args)
| Name
n forall a. Eq a => a -> a -> Bool
== Name
n' = (forall a. a -> Maybe a
Just PArg
i, [PArg]
args)
findImplicit Name
n (i :: PArg
i@(PTacImplicit Int
_ [ArgOpt]
_ Name
n' PTerm
_ PTerm
_) : [PArg]
args)
| Name
n forall a. Eq a => a -> a -> Bool
== Name
n' = (forall a. a -> Maybe a
Just PArg
i, [PArg]
args)
findImplicit Name
n (PArg
x : [PArg]
xs) = let (Maybe PArg
arg, [PArg]
rest) = Name -> [PArg] -> (Maybe PArg, [PArg])
findImplicit Name
n [PArg]
xs in
(Maybe PArg
arg, PArg
x forall a. a -> [a] -> [a]
: [PArg]
rest)
insertScopedImps :: FC -> Name -> [Name] -> Type -> [PArg] -> ElabD [PArg]
insertScopedImps :: FC -> Name -> [Name] -> Term -> [PArg] -> ElabD [PArg]
insertScopedImps FC
fc Name
f [Name]
knowns Term
ty [PArg]
xs =
do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {t :: * -> *} {t :: (* -> *) -> * -> *} {t}.
(Foldable t, Monad (t TC), MonadTrans t) =>
t Name -> PArg' t -> t TC ()
checkKnownImplicit (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall n. TT n -> [(n, TT n)]
getArgTys Term
ty) forall a. [a] -> [a] -> [a]
++ [Name]
knowns)) [PArg]
xs
forall {m :: * -> *}. Monad m => Term -> [PArg] -> m [PArg]
doInsert Term
ty [PArg]
xs
where
doInsert :: Term -> [PArg] -> m [PArg]
doInsert ty :: Term
ty@(Bind Name
n (Pi RigCount
_ im :: Maybe ImplicitInfo
im@(Just ImplicitInfo
i) Term
_ Term
_) Term
sc) [PArg]
xs
| (Just PArg
arg, [PArg]
xs') <- Name -> [PArg] -> (Maybe PArg, [PArg])
findImplicit Name
n [PArg]
xs,
Bool -> Bool
not (ImplicitInfo -> Bool
toplevel_imp ImplicitInfo
i)
= forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PArg
arg forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs')
| ImplicitInfo -> Bool
tcimplementation ImplicitInfo
i Bool -> Bool -> Bool
&& Bool -> Bool
not (ImplicitInfo -> Bool
toplevel_imp ImplicitInfo
i)
= forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall {t}. Name -> t -> Bool -> PArg' t
pimp Name
n (FC -> PTerm
PResolveTC FC
fc) Bool
True forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs)
| Bool -> Bool
not (ImplicitInfo -> Bool
toplevel_imp ImplicitInfo
i)
= forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall {t}. Name -> t -> Bool -> PArg' t
pimp Name
n PTerm
Placeholder Bool
True forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs)
doInsert (Bind Name
n (Pi RigCount
_ Maybe ImplicitInfo
_ Term
_ Term
_) Term
sc) (PArg
x : [PArg]
xs)
= forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PArg
x forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs)
doInsert Term
ty [PArg]
xs = forall (m :: * -> *) a. Monad m => a -> m a
return [PArg]
xs
checkKnownImplicit :: t Name -> PArg' t -> t TC ()
checkKnownImplicit t Name
ns imp :: PArg' t
imp@(PImp{})
| forall t. PArg' t -> Name
pname PArg' t
imp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Name
ns = forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
fc forall a b. (a -> b) -> a -> b
$ forall t. Name -> Name -> Err' t
UnknownImplicit (forall t. PArg' t -> Name
pname PArg' t
imp) Name
f
checkKnownImplicit t Name
ns PArg' t
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertImpLam :: p -> PTerm -> StateT (ElabState aux) TC PTerm
insertImpLam p
ina PTerm
t =
do Term
ty <- forall aux. Elab' aux Term
goal
Env
env <- forall aux. Elab' aux Env
get_env
let ty' :: Term
ty' = Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty
forall {aux}. Term -> PTerm -> StateT (ElabState aux) TC PTerm
addLam Term
ty' PTerm
t
where
addLam :: Term -> PTerm -> StateT (ElabState aux) TC PTerm
addLam goal :: Term
goal@(Bind Name
n (Pi RigCount
_ (Just ImplicitInfo
_) Term
_ Term
_) Term
sc) PTerm
t =
do Name
impn <- forall aux. Name -> Elab' aux Name
unique_hole Name
n
forall (m :: * -> *) a. Monad m => a -> m a
return (FC -> Name -> FC -> PTerm -> PTerm -> PTerm
PLam FC
emptyFC Name
impn FC
NoFC PTerm
Placeholder PTerm
t)
addLam Term
_ PTerm
t = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertCoerce :: p -> PTerm -> StateT (ElabState aux) TC PTerm
insertCoerce p
ina t :: PTerm
t@(PCase FC
_ PTerm
_ [(PTerm, PTerm)]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertCoerce p
ina PTerm
t | PTerm -> Bool
notImplicitable PTerm
t = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertCoerce p
ina PTerm
t =
do Term
ty <- forall aux. Elab' aux Term
goal
Env
env <- forall aux. Elab' aux Env
get_env
let ty' :: Term
ty' = Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty
let cs :: [Name]
cs = IState -> Term -> [Name]
getCoercionsTo IState
ist Term
ty'
let t' :: PTerm
t' = case (PTerm
t, [Name]
cs) of
(PCoerced PTerm
tm, [Name]
_) -> PTerm
tm
(PTerm
_, []) -> PTerm
t
(PTerm
_, [Name]
cs) -> [(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [] PAltType
TryImplicit
(PTerm
t forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall {b} {c}. [(Name, b, c)] -> PTerm -> Name -> PTerm
mkCoerce Env
env PTerm
t) [Name]
cs)
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t'
where
mkCoerce :: [(Name, b, c)] -> PTerm -> Name -> PTerm
mkCoerce [(Name, b, c)]
env (PAlternative [(Name, Name)]
ms PAltType
aty [PTerm]
tms) Name
n
= [(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms PAltType
aty (forall a b. (a -> b) -> [a] -> [b]
map (\PTerm
t -> [(Name, b, c)] -> PTerm -> Name -> PTerm
mkCoerce [(Name, b, c)]
env PTerm
t Name
n) [PTerm]
tms)
mkCoerce [(Name, b, c)]
env PTerm
t Name
n = let fc :: FC
fc = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> FC
fileFC String
"Coercion") forall a. a -> a
id (PTerm -> Maybe FC
highestFC PTerm
t) in
IState -> [Name] -> PTerm -> PTerm
addImplBound IState
ist (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv [(Name, b, c)]
env)
(FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
n) [forall {t}. t -> PArg' t
pexp (PTerm -> PTerm
PCoerced PTerm
t)])
elabRef :: ElabCtxt -> Maybe FC -> FC -> [FC] -> Name -> PTerm -> ElabD ()
elabRef :: ElabCtxt -> Maybe FC -> FC -> [FC] -> Name -> PTerm -> ElabD ()
elabRef ElabCtxt
ina Maybe FC
fc' FC
fc [FC]
hls Name
n PTerm
tm =
do Term
fty <- forall aux. Raw -> Elab' aux Term
get_type (Name -> Raw
Var Name
n)
Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
[PArg]
a' <- FC -> Name -> [Name] -> Term -> [PArg] -> ElabD [PArg]
insertScopedImps FC
fc Name
n [] (Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
fty) []
if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PArg]
a'
then forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc forall a b. (a -> b) -> a -> b
$
do forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
n) []
OutputAnnotation
hilite <- Name -> ElabD OutputAnnotation
findHighlight Name
n
forall aux. Elab' aux ()
solve
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FC -> OutputAnnotation -> ElabD ()
highlightSource) forall a b. (a -> b) -> a -> b
$
(FC
fc, OutputAnnotation
hilite) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\FC
f -> (FC
f, OutputAnnotation
hilite)) [FC]
hls
else ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc' (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc PTerm
tm [])
elabArgs :: IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs :: IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
retry Name
f [] Bool
force [PTerm]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f (((Name
argName, Name
holeName), Bool
unm):[((Name, Name), Bool)]
ns) Bool
force (PTerm
t : [PTerm]
args)
= do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
if Name
holeName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs then
do forall aux. Name -> Elab' aux ()
focus Name
holeName
case PTerm
t of
PTerm
Placeholder -> do forall aux. Name -> Elab' aux ()
movelast Name
holeName
IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f [((Name, Name), Bool)]
ns Bool
force [PTerm]
args
PTerm
_ -> PTerm -> ElabD ()
elabArg PTerm
t
else IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f [((Name, Name), Bool)]
ns Bool
force [PTerm]
args
where elabArg :: PTerm -> ElabD ()
elabArg PTerm
t =
do
forall aux. FC -> Name -> Name -> Elab' aux ()
now_elaborating FC
fc Name
f Name
argName
forall {aux} {b}.
Name
-> Name
-> StateT (ElabState aux) TC b
-> StateT (ElabState aux) TC b
wrapErr Name
f Name
argName forall a b. (a -> b) -> a -> b
$ do
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
Term
tm <- forall aux. Elab' aux Term
get_term
let elab :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab = if Bool
force then ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' else ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE
[Bool]
failed' <-
do forall aux. Name -> Elab' aux ()
focus Name
holeName;
Term
g <- forall aux. Elab' aux Term
goal
Bool
poly <- ElabD Bool
goal_polymorphic
Bool
ulog <- forall aux. Elab' aux Bool
getUnifyLog
forall {a}. Bool -> String -> a -> a
traceWhen Bool
ulog (String
"Elaborating argument " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Name
argName, Name
holeName, Term
g)) forall a b. (a -> b) -> a -> b
$
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab (ElabCtxt
ina { e_nomatching :: Bool
e_nomatching = Bool
unm Bool -> Bool -> Bool
&& Bool
poly }) (forall a. a -> Maybe a
Just FC
fc) PTerm
t
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool]
failed
forall aux. Name -> Name -> Elab' aux ()
done_elaborating_arg Name
f Name
argName
IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f [((Name, Name), Bool)]
ns Bool
force [PTerm]
args
wrapErr :: Name
-> Name
-> StateT (ElabState aux) TC b
-> StateT (ElabState aux) TC b
wrapErr Name
f Name
argName StateT (ElabState aux) TC b
action =
do ElabState aux
elabState <- forall s (m :: * -> *). MonadState s m => m s
get
[(FC, Name, Name)]
while <- forall aux. Elab' aux [(FC, Name, Name)]
elaborating_app
let while' :: [(Name, Name)]
while' = forall a b. (a -> b) -> [a] -> [b]
map (\(FC
x, Name
y, Name
z)-> (Name
y, Name
z)) [(FC, Name, Name)]
while
(b
result, ElabState aux
newState) <- case forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (ElabState aux) TC b
action ElabState aux
elabState of
OK (b
res, ElabState aux
newState) -> forall (m :: * -> *) a. Monad m => a -> m a
return (b
res, ElabState aux
newState)
Error Err
e -> do forall aux. Name -> Name -> Elab' aux ()
done_elaborating_arg Name
f Name
argName
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
tfail ([(Name, Name)] -> Err -> Err
elaboratingArgErr [(Name, Name)]
while' Err
e))
forall s (m :: * -> *). MonadState s m => s -> m ()
put ElabState aux
newState
forall (m :: * -> *) a. Monad m => a -> m a
return b
result
elabArgs IState
_ ElabCtxt
_ [Bool]
_ FC
_ Bool
_ Name
_ (((Name
arg, Name
hole), Bool
_) : [((Name, Name), Bool)]
_) Bool
_ [] =
forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Can't elaborate these args: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
arg forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
hole
addAutoBind :: Plicity -> Name -> ElabD ()
addAutoBind :: Plicity -> Name -> ElabD ()
addAutoBind (Imp [ArgOpt]
_ Static
_ Bool
_ Maybe ImplicitInfo
_ Bool
False RigCount
_) Name
n
= forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
est -> EState
est { auto_binds :: [Name]
auto_binds = Name
n forall a. a -> [a] -> [a]
: EState -> [Name]
auto_binds EState
est })
addAutoBind Plicity
_ Name
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
testImplicitWarning :: FC -> Name -> Type -> ElabD ()
testImplicitWarning :: FC -> Name -> Term -> ElabD ()
testImplicitWarning FC
fc Name
n Term
goal
| Name -> Bool
implicitable Name
n Bool -> Bool -> Bool
&& ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl
= do Env
env <- forall aux. Elab' aux Env
get_env
EState
est <- forall aux. Elab' aux aux
getAux
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` EState -> [Name]
auto_binds EState
est) forall a b. (a -> b) -> a -> b
$
Env -> [(Name, Term)] -> ElabD ()
tryUnify Env
env (Name -> Context -> [(Name, Term)]
lookupTyName Name
n (IState -> Context
tt_ctxt IState
ist))
| Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
tryUnify :: Env -> [(Name, Term)] -> ElabD ()
tryUnify Env
env [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
tryUnify Env
env ((Name
nm, Term
ty) : [(Name, Term)]
ts)
= do [Name]
inj <- forall aux. Elab' aux [Name]
get_inj
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
case Context
-> Env
-> (Term, Maybe Provenance)
-> (Term, Maybe Provenance)
-> [Name]
-> [Name]
-> [Name]
-> [FailContext]
-> TC ([(Name, Term)], Fails)
unify (IState -> Context
tt_ctxt IState
ist) Env
env (Term
ty, forall a. Maybe a
Nothing) (Term
goal, forall a. Maybe a
Nothing)
[Name]
inj [Name]
hs [] [] of
OK ([(Name, Term)], Fails)
_ ->
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
est -> EState
est { implicit_warnings :: [(FC, Name)]
implicit_warnings =
(FC
fc, Name
nm) forall a. a -> [a] -> [a]
: EState -> [(FC, Name)]
implicit_warnings EState
est })
TC ([(Name, Term)], Fails)
_ -> Env -> [(Name, Term)] -> ElabD ()
tryUnify Env
env [(Name, Term)]
ts
pruneAlt :: [PTerm] -> [PTerm]
pruneAlt :: [PTerm] -> [PTerm]
pruneAlt [PTerm]
xs = forall a b. (a -> b) -> [a] -> [b]
map PTerm -> PTerm
prune [PTerm]
xs
where
prune :: PTerm -> PTerm
prune (PApp FC
fc1 (PRef FC
fc2 [FC]
hls Name
f) [PArg]
as)
= FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc1 (FC -> [FC] -> Name -> PTerm
PRef FC
fc2 [FC]
hls Name
f) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> PTerm -> PTerm
choose Name
f)) [PArg]
as)
prune PTerm
t = PTerm
t
choose :: Name -> PTerm -> PTerm
choose Name
f (PAlternative [(Name, Name)]
ms PAltType
a [PTerm]
as)
= let as' :: [PTerm]
as' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> PTerm -> PTerm
choose Name
f) [PTerm]
as
fs :: [PTerm]
fs = forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> PTerm -> Bool
headIs Name
f) [PTerm]
as' in
case [PTerm]
fs of
[PTerm
a] -> PTerm
a
[PTerm]
_ -> [(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms PAltType
a [PTerm]
as'
choose Name
f (PApp FC
fc PTerm
f' [PArg]
as) = FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (Name -> PTerm -> PTerm
choose Name
f PTerm
f') (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> PTerm -> PTerm
choose Name
f)) [PArg]
as)
choose Name
f PTerm
t = PTerm
t
headIs :: Name -> PTerm -> Bool
headIs Name
f (PApp FC
_ (PRef FC
_ [FC]
_ Name
f') [PArg]
_) = Name
f forall a. Eq a => a -> a -> Bool
== Name
f'
headIs Name
f (PApp FC
_ PTerm
f' [PArg]
_) = Name -> PTerm -> Bool
headIs Name
f PTerm
f'
headIs Name
f PTerm
_ = Bool
True
findHighlight :: Name -> ElabD OutputAnnotation
findHighlight :: Name -> ElabD OutputAnnotation
findHighlight Name
n = do Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Just Binder Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False
Maybe (Binder Term)
Nothing -> case Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt of
Just Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
Maybe Term
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$
String
"Can't find name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n
solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
solveAuto IState
ist Name
fn Bool
ambigok (Name
n, [FailContext]
failc)
= do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
hs)) forall a b. (a -> b) -> a -> b
$ do
Env
env <- forall aux. Elab' aux Env
get_env
Term
g <- forall aux. Elab' aux Term
goal
forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError forall {t}. Err' t -> Bool
cantsolve (forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$ do
forall aux. Name -> Elab' aux ()
focus Name
n
Bool
isg <- forall aux. Elab' aux Bool
is_guess
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isg) forall a b. (a -> b) -> a -> b
$
IState
-> Bool
-> Bool
-> Int
-> Bool
-> Maybe Name
-> Name
-> [Name]
-> [Name]
-> ElabD ()
proofSearch' IState
ist Bool
True Bool
ambigok Int
100 Bool
True forall a. Maybe a
Nothing Name
fn [] [])
(forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
Error (forall {t}. [FailContext] -> Err' t -> Err' t
addLoc [FailContext]
failc
(forall t. t -> [(Name, t)] -> Err' t
CantSolveGoal Term
g (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, forall b. Binder b -> b
binderTy Binder Term
b)) Env
env))))
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where addLoc :: [FailContext] -> Err' t -> Err' t
addLoc (FailContext FC
fc Name
f Name
x : [FailContext]
prev) Err' t
err
= forall t. FC -> Err' t -> Err' t
At FC
fc (forall t. Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
ElaboratingArg Name
f Name
x
(forall a b. (a -> b) -> [a] -> [b]
map (\(FailContext FC
_ Name
f' Name
x') -> (Name
f', Name
x')) [FailContext]
prev) Err' t
err)
addLoc [FailContext]
_ Err' t
err = Err' t
err
cantsolve :: Err' t -> Bool
cantsolve (CantSolveGoal t
_ [(Name, t)]
_) = Bool
True
cantsolve (InternalMsg String
_) = Bool
True
cantsolve (At FC
_ Err' t
e) = Err' t -> Bool
cantsolve Err' t
e
cantsolve (Elaborating String
_ Name
_ Maybe t
_ Err' t
e) = Err' t -> Bool
cantsolve Err' t
e
cantsolve (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err' t
e) = Err' t -> Bool
cantsolve Err' t
e
cantsolve Err' t
_ = Bool
False
solveAutos :: IState -> Name -> Bool -> ElabD ()
solveAutos :: IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
ambigok
= do [(Name, ([FailContext], [Name]))]
autos <- forall aux. Elab' aux [(Name, ([FailContext], [Name]))]
get_autos
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
solveAuto IState
ist Name
fn Bool
ambigok) (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, ([FailContext]
fc, [Name]
_)) -> (Name
n, [FailContext]
fc)) [(Name, ([FailContext], [Name]))]
autos)
tcRecoverable :: ElabMode -> Err -> Bool
tcRecoverable :: ElabMode -> Err -> Bool
tcRecoverable ElabMode
ERHS (CantResolve Bool
f Term
g Err
_) = Bool
f
tcRecoverable ElabMode
ETyDecl (CantResolve Bool
f Term
g Err
_) = Bool
f
tcRecoverable ElabMode
e (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err
err) = ElabMode -> Err -> Bool
tcRecoverable ElabMode
e Err
err
tcRecoverable ElabMode
e (At FC
_ Err
err) = ElabMode -> Err -> Bool
tcRecoverable ElabMode
e Err
err
tcRecoverable ElabMode
_ Err
_ = Bool
True
trivial' :: IState -> ElabD ()
trivial' IState
ist
= (PTerm -> ElabD ()) -> IState -> ElabD ()
trivial (IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")) IState
ist
trivialHoles' :: [Name] -> [(Name, Int)] -> IState -> ElabD ()
trivialHoles' [Name]
psn [(Name, Int)]
h IState
ist
= [Name]
-> [(Name, Int)] -> (PTerm -> ElabD ()) -> IState -> ElabD ()
trivialHoles [Name]
psn [(Name, Int)]
h (IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")) IState
ist
proofSearch' :: IState
-> Bool
-> Bool
-> Int
-> Bool
-> Maybe Name
-> Name
-> [Name]
-> [Name]
-> ElabD ()
proofSearch' IState
ist Bool
rec Bool
ambigok Int
depth Bool
prv Maybe Name
top Name
n [Name]
psns [Name]
hints
= do forall aux. Elab' aux ()
unifyProblems
Bool
-> Bool
-> Bool
-> Bool
-> Int
-> (PTerm -> ElabD ())
-> Maybe Name
-> Name
-> [Name]
-> [Name]
-> IState
-> ElabD ()
proofSearch Bool
rec Bool
prv Bool
ambigok (Bool -> Bool
not Bool
prv) Int
depth
(IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")) Maybe Name
top Name
n [Name]
psns [Name]
hints IState
ist
resolveTC' :: Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
resolveTC' Bool
di Bool
mv Int
depth Term
tm Name
n IState
ist
= Bool
-> Bool
-> Int
-> Term
-> Name
-> (PTerm -> ElabD ())
-> IState
-> ElabD ()
resolveTC Bool
di Bool
mv Int
depth Term
tm Name
n (IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")) IState
ist
collectDeferred :: Maybe Name -> [Name] -> Context ->
Term -> State [(Name, (Int, Maybe Name, Type, [Name]))] Term
collectDeferred :: Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred Maybe Name
top [Name]
casenames Context
ctxt Term
tm = [(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [] Term
tm
where
cd :: [(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env (Bind Name
n (GHole Int
i [Name]
psns Term
t) Term
app) =
do [(Name, (Int, Maybe Name, Term, [Name]))]
ds <- forall s (m :: * -> *). MonadState s m => m s
get
Term
t' <- Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred Maybe Name
top [Name]
casenames Context
ctxt Term
t
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, (Int, Maybe Name, Term, [Name]))]
ds)) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put ([(Name, (Int, Maybe Name, Term, [Name]))]
ds forall a. [a] -> [a] -> [a]
++ [(Name
n, (Int
i, Maybe Name
top, Term
t', [Name]
psns))])
[(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
app
cd [(Name, Binder Term)]
env (Bind Name
n Binder Term
b Term
t)
= do Binder Term
b' <- Binder Term
-> StateT
[(Name, (Int, Maybe Name, Term, [Name]))] Identity (Binder Term)
cdb Binder Term
b
Term
t' <- [(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd ((Name
n, Binder Term
b) forall a. a -> [a] -> [a]
: [(Name, Binder Term)]
env) Term
t
forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. n -> Binder (TT n) -> TT n -> TT n
Bind Name
n Binder Term
b' Term
t')
where
cdb :: Binder Term
-> StateT
[(Name, (Int, Maybe Name, Term, [Name]))] Identity (Binder Term)
cdb (Let RigCount
rig Term
t Term
v) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall b. RigCount -> b -> b -> Binder b
Let RigCount
rig) ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
t) ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
v)
cdb (Guess Term
t Term
v) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall b. b -> b -> Binder b
Guess ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
t) ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
v)
cdb Binder Term
b = do Term
ty' <- [(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env (forall b. Binder b -> b
binderTy Binder Term
b)
forall (m :: * -> *) a. Monad m => a -> m a
return (Binder Term
b { binderTy :: Term
binderTy = Term
ty' })
cd [(Name, Binder Term)]
env (App AppStatus Name
s Term
f Term
a) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall n. AppStatus n -> TT n -> TT n -> TT n
App AppStatus Name
s) ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
f)
([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
a)
cd [(Name, Binder Term)]
env Term
t = forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
metavarName :: [String] -> Name -> Name
metavarName :: [String] -> Name -> Name
metavarName [String]
_ n :: Name
n@(NS Name
_ [Text]
_) = Name
n
metavarName (ns :: [String]
ns@(String
_:[String]
_)) Name
n = Name -> [String] -> Name
sNS Name
n [String]
ns
metavarName [String]
_ Name
n = Name
n
runElabAction :: ElabInfo -> IState -> FC -> Env -> Term -> [String] -> ElabD Term
runElabAction :: ElabInfo -> IState -> FC -> Env -> Term -> [String] -> ElabD Term
runElabAction ElabInfo
info IState
ist FC
fc Env
env Term
tm [String]
ns = do Term
tm' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
tm
Term -> ElabD Term
runTacTm Term
tm'
where
eval :: Term -> StateT (ElabState aux) TC Term
eval Term
tm = do Context
ctxt <- forall aux. Elab' aux Context
get_context
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env (forall n. Eq n => TT n -> TT n
finalise Term
tm)
returnUnit :: ElabD Term
returnUnit = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. NameType -> n -> TT n -> TT n
P (Int -> Int -> Bool -> NameType
DCon Int
0 Int
0 Bool
False) Name
unitCon (forall n. NameType -> n -> TT n -> TT n
P (Int -> Int -> NameType
TCon Int
0 Int
0) Name
unitTy forall n. TT n
Erased)
patvars :: [(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars :: [(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [(Name, Term)]
ns (Bind Name
n (PVar RigCount
_ Term
t) Term
sc) = [(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars ((Name
n, Term
t) forall a. a -> [a] -> [a]
: [(Name, Term)]
ns) (forall n. TT n -> TT n -> TT n
instantiate (forall n. NameType -> n -> TT n -> TT n
P NameType
Bound Name
n Term
t) Term
sc)
patvars [(Name, Term)]
ns Term
tm = ([(Name, Term)]
ns, Term
tm)
pullVars :: (Term, Term) -> ([(Name, Term)], Term, Term)
pullVars :: (Term, Term) -> ([(Name, Term)], Term, Term)
pullVars (Term
lhs, Term
rhs) = (forall a b. (a, b) -> a
fst ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs), forall a b. (a, b) -> b
snd ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs), forall a b. (a, b) -> b
snd ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
rhs))
requireError :: Err -> ElabD a -> ElabD ()
requireError :: forall a. Err -> ElabD a -> ElabD ()
requireError Err
orErr ElabD a
elab =
do ElabState EState
state <- forall s (m :: * -> *). MonadState s m => m s
get
case forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ElabD a
elab ElabState EState
state of
OK (a
_, ElabState EState
state') -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
tfail Err
orErr)
Error Err
e -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
fakeTT :: Raw -> Term
fakeTT :: Raw -> Term
fakeTT (Var Name
n) =
case Name -> Context -> [(Name, Def)]
lookupNameDef Name
n (IState -> Context
tt_ctxt IState
ist) of
[(Name
n', TyDecl NameType
nt Term
_)] -> forall n. NameType -> n -> TT n -> TT n
P NameType
nt Name
n' forall n. TT n
Erased
[(Name, Def)]
_ -> forall n. NameType -> n -> TT n -> TT n
P NameType
Ref Name
n forall n. TT n
Erased
fakeTT (RBind Name
n Binder Raw
b Raw
body) = forall n. n -> Binder (TT n) -> TT n -> TT n
Bind Name
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Raw -> Term
fakeTT Binder Raw
b) (Raw -> Term
fakeTT Raw
body)
fakeTT (RApp Raw
f Raw
a) = forall n. AppStatus n -> TT n -> TT n -> TT n
App forall n. AppStatus n
Complete (Raw -> Term
fakeTT Raw
f) (Raw -> Term
fakeTT Raw
a)
fakeTT Raw
RType = forall n. UExp -> TT n
TType (String -> Int -> UExp
UVar [] (-Int
1))
fakeTT (RUType Universe
u) = forall n. Universe -> TT n
UType Universe
u
fakeTT (RConstant Const
c) = forall n. Const -> TT n
Constant Const
c
defineFunction :: RFunDefn Raw -> ElabD ()
defineFunction :: RFunDefn Raw -> ElabD ()
defineFunction (RDefineFun Name
n [RFunClause Raw]
clauses) =
do Context
ctxt <- forall aux. Elab' aux Context
get_context
Term
ty <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no type decl") forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt
let info :: CaseInfo
info = Bool -> Bool -> Bool -> CaseInfo
CaseInfo Bool
True Bool
True Bool
False
[Either Term (Term, Term)]
clauses' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RFunClause Raw]
clauses (\case
RMkFunClause Raw
lhs Raw
rhs ->
do (Term
lhs', Term
lty) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
lhs
(Term
rhs', Term
rty) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
rhs
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term -> TC ()
converts Context
ctxt [] Term
lty Term
rty
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Term
lhs', Term
rhs')
RMkImpossibleClause Raw
lhs ->
do forall a. Err -> ElabD a -> ElabD ()
requireError (forall t. String -> Err' t
Msg String
"Not an impossible case") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
lhs
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (Raw -> Term
fakeTT Raw
lhs))
let clauses'' :: [([(Name, Term)], Term, Term)]
clauses'' = forall a b. (a -> b) -> [a] -> [b]
map (\case Right (Term, Term)
c -> (Term, Term) -> ([(Name, Term)], Term, Term)
pullVars (Term, Term)
c
Left Term
lhs -> let ([(Name, Term)]
ns, Term
lhs') = [(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs
in ([(Name, Term)]
ns, Term
lhs', forall n. TT n
Impossible))
[Either Term (Term, Term)]
clauses'
let clauses''' :: [([Name], Term, Term)]
clauses''' = forall a b. (a -> b) -> [a] -> [b]
map (\([(Name, Term)]
ns, Term
lhs, Term
rhs) -> (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, Term)]
ns, Term
lhs, Term
rhs)) [([(Name, Term)], Term, Term)]
clauses''
let argtys :: [(Term, Bool)]
argtys = forall a b. (a -> b) -> [a] -> [b]
map (\Term
x -> (Term
x, Term -> Context -> Bool
isCanonical Term
x Context
ctxt))
(forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise Context
ctxt [] Term
ty)))
Context
ctxt'<- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
Name
-> ErasureInfo
-> CaseInfo
-> Bool
-> SC
-> Bool
-> Bool
-> [(Term, Bool)]
-> [Int]
-> [Either Term (Term, Term)]
-> [([Name], Term, Term)]
-> [([Name], Term, Term)]
-> Term
-> Context
-> TC Context
addCasedef Name
n (forall a b. a -> b -> a
const [])
CaseInfo
info Bool
False (forall t. t -> SC' t
STerm forall n. TT n
Erased)
Bool
True Bool
False
[(Term, Bool)]
argtys []
[Either Term (Term, Term)]
clauses'
[([Name], Term, Term)]
clauses'''
[([Name], Term, Term)]
clauses'''
Term
ty
Context
ctxt
forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = Name -> [([(Name, Term)], Term, Term)] -> RDeclInstructions
RClausesInstrs Name
n [([(Name, Term)], Term, Term)]
clauses'' forall a. a -> [a] -> [a]
: EState -> [RDeclInstructions]
new_tyDecls EState
e}
forall (m :: * -> *) a. Monad m => a -> m a
return ()
checkClosed :: Raw -> Elab' aux (Term, Type)
checkClosed :: forall aux. Raw -> Elab' aux (Term, Term)
checkClosed Raw
tm = do Context
ctxt <- forall aux. Elab' aux Context
get_context
(Term
val, Term
ty) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
tm
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall n. Eq n => TT n -> TT n
finalise Term
val, forall n. Eq n => TT n -> TT n
finalise Term
ty)
mkPi :: RFunArg -> Raw -> Raw
mkPi :: RFunArg -> Raw -> Raw
mkPi RFunArg
arg Raw
rTy = Name -> Binder Raw -> Raw -> Raw
RBind (RFunArg -> Name
argName RFunArg
arg) (forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW forall a. Maybe a
Nothing (RFunArg -> Raw
argTy RFunArg
arg) (Universe -> Raw
RUType Universe
AllTypes)) Raw
rTy
mustBeType :: Context -> a -> Term -> t TC ()
mustBeType Context
ctxt a
tm Term
ty =
case Context -> Env -> Term -> Term
normaliseAll Context
ctxt [] (forall n. Eq n => TT n -> TT n
finalise Term
ty) of
UType Universe
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
TType UExp
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Term
ty' -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$
forall a. Show a => a -> String
show a
tm forall a. [a] -> [a] -> [a]
++ String
" is not a type: it's " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
ty'
mustNotBeDefined :: Context -> Name -> t TC ()
mustNotBeDefined Context
ctxt Name
n =
case Name -> Context -> Maybe Def
lookupDefExact Name
n Context
ctxt of
Just Def
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$
forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" is already defined."
Maybe Def
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
prepareConstructor :: Name -> RConstructorDefn -> ElabD (Name, [PArg], Type)
prepareConstructor :: Name -> RConstructorDefn -> ElabD (Name, [PArg], Term)
prepareConstructor Name
tyn (RConstructor Name
cn [RFunArg]
args Raw
resTy) =
do Context
ctxt <- forall aux. Elab' aux Context
get_context
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Name -> t TC ()
notQualified Name
cn
let qcn :: Name
qcn = Name -> Name
qualify Name
cn
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Context -> Name -> t TC ()
mustNotBeDefined Context
ctxt Name
qcn
let cty :: Raw
cty = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RFunArg -> Raw -> Raw
mkPi Raw
resTy [RFunArg]
args
(Term
checkedTy, Term
ctyTy) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
cty
forall {t :: (* -> *) -> * -> *} {a}.
(Monad (t TC), MonadTrans t, Show a) =>
Context -> a -> Term -> t TC ()
mustBeType Context
ctxt Term
checkedTy Term
ctyTy
case forall n. TT n -> (TT n, [TT n])
unApply (Term -> Term
getRetTy (Context -> Env -> Term -> Term
normaliseAll Context
ctxt [] (forall n. Eq n => TT n -> TT n
finalise Term
checkedTy))) of
(P NameType
_ Name
n Term
_, [Term]
_) | Name
n forall a. Eq a => a -> a -> Bool
== Name
tyn -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Term, [Term])
t -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"The constructor " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
cn forall a. [a] -> [a] -> [a]
++
String
" doesn't construct " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
tyn forall a. [a] -> [a] -> [a]
++
String
" (return type is " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Term, [Term])
t forall a. [a] -> [a] -> [a]
++ String
")"
forall aux. Context -> Elab' aux ()
set_context (Name -> NameType -> Term -> Context -> Context
addTyDecl Name
qcn (Int -> Int -> Bool -> NameType
DCon Int
0 Int
0 Bool
False) Term
checkedTy Context
ctxt)
let impls :: [PArg]
impls = forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> PArg
rFunArgToPArg [RFunArg]
args
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
qcn, [PArg]
impls, Term
checkedTy)
where
notQualified :: Name -> t TC ()
notQualified (NS Name
_ [Text]
_) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Constructor names may not be qualified"
notQualified Name
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
qualify :: Name -> Name
qualify Name
n = case Name
tyn of
(NS Name
_ [Text]
ns) -> Name -> [Text] -> Name
NS Name
n [Text]
ns
Name
_ -> Name
n
getRetTy :: Type -> Type
getRetTy :: Term -> Term
getRetTy (Bind Name
_ (Pi RigCount
_ Maybe ImplicitInfo
_ Term
_ Term
_) Term
sc) = Term -> Term
getRetTy Term
sc
getRetTy Term
ty = Term
ty
elabScriptStuck :: Term -> ElabD a
elabScriptStuck :: forall a. Term -> ElabD a
elabScriptStuck Term
x = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. t -> Err' t
ElabScriptStuck Term
x
tacTmArgs :: Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs :: Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
l Term
t [Term]
args | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
args forall a. Eq a => a -> a -> Bool
== Int
l = forall (m :: * -> *) a. Monad m => a -> m a
return [Term]
args
| Bool
otherwise = forall a. Term -> ElabD a
elabScriptStuck Term
t
runTacTm :: Term -> ElabD Term
runTacTm :: Term -> ElabD Term
runTacTm tac :: Term
tac@(forall n. TT n -> (TT n, [TT n])
unApply -> (P NameType
_ Name
n Term
_, [Term]
args))
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Solve"
= do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
forall aux. Elab' aux ()
solve
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Goal"
= do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
case [Name]
hs of
(Name
h : [Name]
_) -> do Term
t <- forall aux. Elab' aux Term
goal
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
(Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var (String -> Name
reflm String
"TTName"), Name -> Raw
Var (String -> Name
reflm String
"TT"))
(Name -> Raw
reflectName Name
h, Term -> Raw
reflect Term
t)
[] -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$
String
"Elaboration is complete. There are no goals."
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Holes"
= do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
mkList (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName") (forall a b. (a -> b) -> [a] -> [b]
map Name -> Raw
reflectName [Name]
hs)
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Guess"
= do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
Term
g <- forall aux. Elab' aux Term
get_guess
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Term -> Raw
reflect Term
g
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupTy"
= do ~[Term
name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
Context
ctxt <- forall aux. Elab' aux Context
get_context
let getNameTypeAndType :: Def -> (NameType, Term)
getNameTypeAndType = \case Function Term
ty Term
_ -> (NameType
Ref, Term
ty)
TyDecl NameType
nt Term
ty -> (NameType
nt, Term
ty)
Operator Term
ty Int
_ [Value] -> Maybe Value
_ -> (NameType
Ref, Term
ty)
CaseOp CaseInfo
_ Term
ty [(Term, Bool)]
_ [Either Term (Term, Term)]
_ [([Name], Term, Term)]
_ CaseDefs
_ -> (NameType
Ref, Term
ty)
reflectTriple :: (Raw, Raw, Raw) -> Raw
reflectTriple (Raw
x, Raw
y, Raw
z) =
Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairCon) [ Name -> Raw
Var (String -> Name
reflm String
"TTName")
, Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [Name -> Raw
Var (String -> Name
reflm String
"NameType"), Name -> Raw
Var (String -> Name
reflm String
"TT")]
, Raw
x
, Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairCon) [ Name -> Raw
Var (String -> Name
reflm String
"NameType"), Name -> Raw
Var (String -> Name
reflm String
"TT")
, Raw
y, Raw
z]]
let defs :: [Raw]
defs = [ (Raw, Raw, Raw) -> Raw
reflectTriple (Name -> Raw
reflectName Name
n, NameType -> Raw
reflectNameType NameType
nt, Term -> Raw
reflect Term
ty)
| (Name
n, Def
def) <- Name -> Context -> [(Name, Def)]
lookupNameDef Name
n' Context
ctxt
, let (NameType
nt, Term
ty) = Def -> (NameType, Term)
getNameTypeAndType Def
def ]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [ Name -> Raw
Var (String -> Name
reflm String
"TTName")
, Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [ Name -> Raw
Var (String -> Name
reflm String
"NameType")
, Name -> Raw
Var (String -> Name
reflm String
"TT")]])
[Raw]
defs
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupDatatype"
= do ~[Term
name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
Ctxt TypeInfo
datatypes <- forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
Context
ctxt <- forall aux. Elab' aux Context
get_context
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Name -> Raw
Var (String -> Name
tacN String
"Datatype"))
(forall a b. (a -> b) -> [a] -> [b]
map RDatatype -> Raw
reflectDatatype (IState -> Name -> [RDatatype]
buildDatatypes IState
ist Name
n'))
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupFunDefn"
= do ~[Term
name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Raw -> Raw -> Raw
RApp (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
tacN String
"FunDefn") (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT"))
(forall a b. (a -> b) -> [a] -> [b]
map RFunDefn Term -> Raw
reflectFunDefn (IState -> Name -> [RFunDefn Term]
buildFunDefns IState
ist Name
n'))
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupArgs"
= do ~[Term
name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
let listTy :: Raw
listTy = Name -> Raw
Var (Name -> [String] -> Name
sNS (String -> Name
sUN String
"List") [String
"List", String
"Prelude"])
listFunArg :: Raw
listFunArg = Raw -> Raw -> Raw
RApp Raw
listTy (Name -> Raw
Var (String -> Name
tacN String
"FunArg"))
let reflectTriple :: (Raw, Raw, Raw) -> Raw
reflectTriple (Raw
x, Raw
y, Raw
z) =
Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairCon) [ Name -> Raw
Var (String -> Name
reflm String
"TTName")
, Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [Raw
listFunArg, Name -> Raw
Var (String -> Name
reflm String
"Raw")]
, Raw
x
, Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairCon) [Raw
listFunArg, Name -> Raw
Var (String -> Name
reflm String
"Raw")
, Raw
y, Raw
z]]
let out :: [Raw]
out =
[ (Raw, Raw, Raw) -> Raw
reflectTriple (Name -> Raw
reflectName Name
fn, Raw -> [Raw] -> Raw
reflectList (Name -> Raw
Var (String -> Name
tacN String
"FunArg")) (forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> Raw
reflectArg [RFunArg]
args), Raw -> Raw
reflectRaw Raw
res)
| (Name
fn, [PArg]
pargs) <- forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
n' (IState -> Ctxt [PArg]
idris_implicits IState
ist)
, ([RFunArg]
args, Raw
res) <- [PArg] -> Raw -> ([RFunArg], Raw)
getArgs [PArg]
pargs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Raw
forget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
forall a. Maybe a -> [a]
maybeToList (Name -> Context -> Maybe Term
lookupTyExact Name
fn (IState -> Context
tt_ctxt IState
ist))
]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [Name -> Raw
Var (String -> Name
reflm String
"TTName")
, Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [ Raw -> Raw -> Raw
RApp Raw
listTy
(Name -> Raw
Var (String -> Name
tacN String
"FunArg"))
, Name -> Raw
Var (String -> Name
reflm String
"Raw")]])
[Raw]
out
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__SourceLocation"
= do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
FC -> Raw
reflectFC FC
fc
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Namespace"
= do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Const -> Raw
RConstant Const
StrType) (forall a b. (a -> b) -> [a] -> [b]
map (Const -> Raw
RConstant forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Const
Str) [String]
ns)
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Env"
= do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
Env
env <- forall aux. Elab' aux Env
get_env
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Env -> Raw
reflectEnv Env
env
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Fail"
= do ~[Term
_a, Term
errs] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Term
errs' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
errs
[ErrorReportPart]
parts <- Term -> ElabD [ErrorReportPart]
reifyReportParts Term
errs'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. [[ErrorReportPart]] -> Err' t -> Err' t
ReflectionError [[ErrorReportPart]
parts] (forall t. String -> Err' t
Msg String
"")
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__PureElab"
= do ~[Term
_a, Term
tm] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
forall (m :: * -> *) a. Monad m => a -> m a
return Term
tm
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__BindElab"
= do ~[Term
_a, Term
_b, Term
first, Term
andThen] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
4 Term
tac [Term]
args
Term
first' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
first
Term
res <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> ElabD Term
runTacTm Term
first'
Term
next <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval (forall n. AppStatus n -> TT n -> TT n -> TT n
App forall n. AppStatus n
Complete Term
andThen Term
res)
Term -> ElabD Term
runTacTm Term
next
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Try"
= do ~[Term
_a, Term
first, Term
alt] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
3 Term
tac [Term]
args
Term
first' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
first
Term
alt' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
alt
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (Term -> ElabD Term
runTacTm Term
first') (Term -> ElabD Term
runTacTm Term
alt') Bool
True
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__TryCatch"
= do ~[Term
_a, Term
first, Term
f] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
3 Term
tac [Term]
args
Term
first' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
first
Term
f' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
f
forall aux a. Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
tryCatch (Term -> ElabD Term
runTacTm Term
first') forall a b. (a -> b) -> a -> b
$ \Err
err ->
do (Term
err', Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Err -> Raw
reflectErr Err
err)
Term
f' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval (forall n. AppStatus n -> TT n -> TT n -> TT n
App forall n. AppStatus n
Complete Term
f Term
err')
Term -> ElabD Term
runTacTm Term
f'
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Fill"
= do ~[Term
raw] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Raw
raw' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
raw
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply Raw
raw' []
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Apply" Bool -> Bool -> Bool
|| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__MatchApply"
= do ~[Term
raw, Term
argSpec] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Raw
raw' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
raw
[(Bool, Int)]
argSpec' <- forall a b. (a -> b) -> [a] -> [b]
map (\Bool
b -> (Bool
b, Int
0)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Term -> ElabD a) -> Term -> ElabD [a]
reifyList Term -> ElabD Bool
reifyBool Term
argSpec
let op :: Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
op = if Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Apply"
then forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply
else forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
match_apply
[(Name, Name)]
ns <- forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
op Raw
raw' [(Bool, Int)]
argSpec'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Raw -> Raw -> Raw
rawPairTy (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName") (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName"))
[ (Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName", Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName")
(Name -> Raw
reflectName Name
n1, Name -> Raw
reflectName Name
n2)
| (Name
n1, Name
n2) <- [(Name, Name)]
ns
]
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Gensym"
= do ~[Term
hint] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Term
hintStr <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
hint
case Term
hintStr of
Constant (Str String
h) -> do
Name
n <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
h)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
reflectName Name
n)
Term
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no hint"
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Claim"
= do ~[Term
n, Term
ty] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
Raw
ty' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
ty
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n' Raw
ty'
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Check"
= do ~[Term
env', Term
raw] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Env
env <- Term -> ElabD Env
reifyEnv Term
env'
Raw
raw' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
raw
Context
ctxt <- forall aux. Elab' aux Context
get_context
(Term
tm, Term
ty) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt Env
env Raw
raw'
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
(Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var (String -> Name
reflm String
"TT"), Name -> Raw
Var (String -> Name
reflm String
"TT"))
(Term -> Raw
reflect Term
tm, Term -> Raw
reflect Term
ty)
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Attack"
= do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
forall aux. Elab' aux ()
attack
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Rewrite"
= do ~[Term
rule] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Raw
r <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
rule
forall aux. Raw -> Elab' aux ()
rewrite Raw
r
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Focus"
= do ~[Term
what] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
what
[Name]
hs <- forall aux. Elab' aux [Name]
get_holes
if forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
n' [Name]
hs
then forall aux. Name -> Elab' aux ()
focus Name
n' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ElabD Term
returnUnit
else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"The name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n' forall a. [a] -> [a] -> [a]
++ String
" does not denote a hole"
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Unfocus"
= do ~[Term
what] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
what
forall aux. Name -> Elab' aux ()
movelast Name
n'
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Intro"
= do ~[Term
mn] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Maybe Name
n <- case Term -> Maybe Term
fromTTMaybe Term
mn of
Maybe Term
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
Just Term
name -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
forall aux. Maybe Name -> Elab' aux ()
intro Maybe Name
n
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Forall"
= do ~[Term
n, Term
ty] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
Raw
ty' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
ty
forall aux.
Name -> RigCount -> Maybe ImplicitInfo -> Raw -> Elab' aux ()
forAll Name
n' RigCount
RigW forall a. Maybe a
Nothing Raw
ty'
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__PatVar"
= do ~[Term
n] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
forall aux. Name -> Elab' aux ()
patvar' Name
n'
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__PatBind"
= do ~[Term
n] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
forall aux. Name -> RigCount -> Elab' aux ()
patbind Name
n' RigCount
RigW
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LetBind"
= do ~[Term
n, Term
ty, Term
tm] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
3 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
Raw
ty' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
ty
Raw
tm' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
tm
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n' RigCount
RigW Raw
ty' Raw
tm'
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Compute"
= do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args; forall aux. Elab' aux ()
compute ; ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Normalise"
= do ~[Term
env, Term
tm] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Env
env' <- Term -> ElabD Env
reifyEnv Term
env
Term
tm' <- Term -> ElabD Term
reifyTT Term
tm
Context
ctxt <- forall aux. Elab' aux Context
get_context
let out :: Term
out = Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env' (forall n. Eq n => TT n -> TT n
finalise Term
tm')
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Term -> Raw
reflect Term
out
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Whnf"
= do ~[Term
tm] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Term
tm' <- Term -> ElabD Term
reifyTT Term
tm
Context
ctxt <- forall aux. Elab' aux Context
get_context
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Raw
reflect forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term
whnf Context
ctxt [] Term
tm'
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Converts"
= do ~[Term
env, Term
tm1, Term
tm2] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
3 Term
tac [Term]
args
Env
env' <- Term -> ElabD Env
reifyEnv Term
env
Term
tm1' <- Term -> ElabD Term
reifyTT Term
tm1
Term
tm2' <- Term -> ElabD Term
reifyTT Term
tm2
Context
ctxt <- forall aux. Elab' aux Context
get_context
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term -> TC ()
converts Context
ctxt Env
env' Term
tm1' Term
tm2'
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__DeclareType"
= do ~[Term
decl] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
(RDeclare Name
n [RFunArg]
args Raw
res) <- Term -> ElabD RTyDecl
reifyTyDecl Term
decl
Context
ctxt <- forall aux. Elab' aux Context
get_context
let rty :: Raw
rty = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RFunArg -> Raw -> Raw
mkPi Raw
res [RFunArg]
args
(Term
checked, Term
ty') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
rty
forall {t :: (* -> *) -> * -> *} {a}.
(Monad (t TC), MonadTrans t, Show a) =>
Context -> a -> Term -> t TC ()
mustBeType Context
ctxt Term
checked Term
ty'
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Context -> Name -> t TC ()
mustNotBeDefined Context
ctxt Name
n
let decl :: Def
decl = NameType -> Term -> Def
TyDecl NameType
Ref Term
checked
ctxt' :: Context
ctxt' = Name -> Def -> Context -> Context
addCtxtDef Name
n Def
decl Context
ctxt
forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = (Name -> FC -> [PArg] -> Term -> RDeclInstructions
RTyDeclInstrs Name
n FC
fc (forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> PArg
rFunArgToPArg [RFunArg]
args) Term
checked) forall a. a -> [a] -> [a]
:
EState -> [RDeclInstructions]
new_tyDecls EState
e }
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__DefineFunction"
= do ~[Term
decl] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
RFunDefn Raw
defn <- Term -> ElabD (RFunDefn Raw)
reifyFunDefn Term
decl
RFunDefn Raw -> ElabD ()
defineFunction RFunDefn Raw
defn
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__DeclareDatatype"
= do ~[Term
decl] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
RDeclare Name
n [RFunArg]
args Raw
resTy <- Term -> ElabD RTyDecl
reifyTyDecl Term
decl
Context
ctxt <- forall aux. Elab' aux Context
get_context
let tcTy :: Raw
tcTy = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RFunArg -> Raw -> Raw
mkPi Raw
resTy [RFunArg]
args
(Term
checked, Term
ty') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
tcTy
forall {t :: (* -> *) -> * -> *} {a}.
(Monad (t TC), MonadTrans t, Show a) =>
Context -> a -> Term -> t TC ()
mustBeType Context
ctxt Term
checked Term
ty'
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Context -> Name -> t TC ()
mustNotBeDefined Context
ctxt Name
n
let ctxt' :: Context
ctxt' = Name -> NameType -> Term -> Context -> Context
addTyDecl Name
n (Int -> Int -> NameType
TCon Int
0 Int
0) Term
checked Context
ctxt
forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = Name -> [PArg] -> RDeclInstructions
RDatatypeDeclInstrs Name
n (forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> PArg
rFunArgToPArg [RFunArg]
args) forall a. a -> [a] -> [a]
: EState -> [RDeclInstructions]
new_tyDecls EState
e }
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__DefineDatatype"
= do ~[Term
defn] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
RDefineDatatype Name
n [RConstructorDefn]
ctors <- Term -> ElabD RDataDefn
reifyRDataDefn Term
defn
Context
ctxt <- forall aux. Elab' aux Context
get_context
Term
tyconTy <- case Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt of
Just Term
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
Maybe Term
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Type not previously declared"
Ctxt TypeInfo
datatypes <- forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
case forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
n Ctxt TypeInfo
datatypes of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(Name, TypeInfo)]
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" is already defined as a datatype."
[(Name, [PArg], Term)]
ctors' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> RConstructorDefn -> ElabD (Name, [PArg], Term)
prepareConstructor Name
n) [RConstructorDefn]
ctors
Int
ttag <- do ES (ProofState
ps, EState
aux) String
str Maybe (ElabState EState)
prev <- forall s (m :: * -> *). MonadState s m => m s
get
let i :: Int
i = ProofState -> Int
global_nextname ProofState
ps
forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ forall aux.
(ProofState, aux)
-> String -> Maybe (ElabState aux) -> ElabState aux
ES (ProofState
ps { global_nextname :: Int
global_nextname = ProofState -> Int
global_nextname ProofState
ps forall a. Num a => a -> a -> a
+ Int
1 },
EState
aux)
String
str
Maybe (ElabState EState)
prev
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
let ctxt' :: Context
ctxt' = Datatype Name -> Context -> Context
addDatatype (forall n. n -> Int -> TT n -> Bool -> [(n, TT n)] -> Datatype n
Data Name
n Int
ttag Term
tyconTy Bool
False (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
cn, [PArg]
_, Term
cty) -> (Name
cn, Term
cty)) [(Name, [PArg], Term)]
ctors')) Context
ctxt
forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = Name -> Term -> [(Name, [PArg], Term)] -> RDeclInstructions
RDatatypeDefnInstrs Name
n Term
tyconTy [(Name, [PArg], Term)]
ctors' forall a. a -> [a] -> [a]
: EState -> [RDeclInstructions]
new_tyDecls EState
e }
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__AddImplementation"
= do ~[Term
cls, Term
impl] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Name
interfaceName <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
cls
Name
implName <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
impl
forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = Name -> Name -> RDeclInstructions
RAddImplementation Name
interfaceName Name
implName forall a. a -> [a] -> [a]
:
EState -> [RDeclInstructions]
new_tyDecls EState
e }
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__IsTCName"
= do ~[Term
n] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
case forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n' (IState -> Ctxt InterfaceInfo
idris_interfaces IState
ist) of
Just InterfaceInfo
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Name -> Raw
Var (Name -> [String] -> Name
sNS (String -> Name
sUN String
"True") [String
"Bool", String
"Prelude"])
Maybe InterfaceInfo
Nothing -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Name -> Raw
Var (Name -> [String] -> Name
sNS (String -> Name
sUN String
"False") [String
"Bool", String
"Prelude"])
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__ResolveTC"
= do ~[Term
fn] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Term
g <- forall aux. Elab' aux Term
goal
Name
fn <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
fn
Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
resolveTC' Bool
False Bool
True Int
100 Term
g Name
fn IState
ist
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Search"
= do ~[Term
depth, Term
hints] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Term
d <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
depth
Term
hints' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
hints
case (Term
d, Term -> Maybe [Term]
unList Term
hints') of
(Constant (I Int
i), Just [Term]
hs) ->
do [Name]
actualHints <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Term -> StateT (ElabState EState) TC Name
reifyTTName [Term]
hs
forall aux. Elab' aux ()
unifyProblems
let psElab :: PTerm -> ElabD ()
psElab = IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")
Bool
-> Bool
-> Bool
-> Bool
-> Int
-> (PTerm -> ElabD ())
-> Maybe Name
-> Name
-> [Name]
-> [Name]
-> IState
-> ElabD ()
proofSearch Bool
True Bool
True Bool
False Bool
False Int
i PTerm -> ElabD ()
psElab forall a. Maybe a
Nothing (Int -> String -> Name
sMN Int
0 String
"search ") [] [Name]
actualHints IState
ist
ElabD Term
returnUnit
(Constant (I Int
_), Maybe [Term]
Nothing ) ->
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$ String
"Not a list: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
hints'
(Term
_, Maybe [Term]
_) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$ String
"Can't reify int " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
d
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__RecursiveElab"
= do ~[Term
goal, Term
script] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Raw
goal' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
goal
Context
ctxt <- forall aux. Elab' aux Context
get_context
Term
script <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
script
(Term
goalTT, Term
goalTy) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
goal'
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> TC ()
isType Context
ctxt [] Term
goalTy
Name
recH <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"recElabHole")
EState
aux <- forall aux. Elab' aux aux
getAux
Ctxt TypeInfo
datatypes <- forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
Env
env <- forall aux. Elab' aux Env
get_env
Int
g_next <- forall aux. Elab' aux Int
get_global_nextname
(Context
ctxt', ES (ProofState
p, EState
aux') String
_ Maybe (ElabState EState)
_) <-
do (ES (ProofState
current_p, EState
_) String
_ Maybe (ElabState EState)
_) <- forall s (m :: * -> *). MonadState s m => m s
get
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall aux a.
aux -> Elab' aux a -> ProofState -> TC (a, ElabState aux)
runElab EState
aux
(do ElabInfo -> IState -> FC -> Env -> Term -> [String] -> ElabD Term
runElabAction ElabInfo
info IState
ist FC
fc [] Term
script [String]
ns
Context
ctxt' <- forall aux. Elab' aux Context
get_context
forall (m :: * -> *) a. Monad m => a -> m a
return Context
ctxt')
((Name
-> String -> Context -> Ctxt TypeInfo -> Int -> Term -> ProofState
newProof Name
recH (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt Ctxt TypeInfo
datatypes Int
g_next Term
goalTT)
{ nextname :: Int
nextname = ProofState -> Int
nextname ProofState
current_p })
forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
let tm_out :: Term
tm_out = ProofTerm -> Term
getProofTerm (ProofState -> ProofTerm
pterm ProofState
p)
do (ES (ProofState
prf, EState
_) String
s Maybe (ElabState EState)
e) <- forall s (m :: * -> *). MonadState s m => m s
get
let p' :: ProofState
p' = ProofState
prf { nextname :: Int
nextname = ProofState -> Int
nextname ProofState
p
, global_nextname :: Int
global_nextname = ProofState -> Int
global_nextname ProofState
p
}
forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall aux.
(ProofState, aux)
-> String -> Maybe (ElabState aux) -> ElabState aux
ES (ProofState
p', EState
aux') String
s Maybe (ElabState EState)
e)
Env
env' <- forall aux. Elab' aux Env
get_env
(Term
tm, Term
ty, UCs
_) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> Context -> Env -> Raw -> Term -> TC (Term, Term, UCs)
recheck (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt' Env
env (Term -> Raw
forget Term
tm_out) Term
tm_out
let (Raw
tm', Raw
ty') = (Term -> Raw
reflect Term
tm, Term -> Raw
reflect Term
ty)
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
(Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT", Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT")
(Raw
tm', Raw
ty')
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Metavar"
= do ~[Term
n] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
Context
ctxt <- forall aux. Elab' aux Context
get_context
Term
ptm <- forall aux. Elab' aux Term
get_term
let unique_used :: [Name]
unique_used = Context -> Term -> [Name]
getUniqueUsed Context
ctxt Term
ptm
let lin_used :: [Name]
lin_used = Context -> Term -> [Name]
getLinearUsed Context
ctxt Term
ptm
let mvn :: Name
mvn = [String] -> Name -> Name
metavarName [String]
ns Name
n'
forall aux. Elab' aux ()
attack
forall aux. [Name] -> [Name] -> Name -> Elab' aux Name
defer [Name]
unique_used [Name]
lin_used Name
mvn
forall aux. Elab' aux ()
solve
ElabD Term
returnUnit
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Fixity"
= do ~[Term
op'] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
Term
opTm <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
op'
case Term
opTm of
Constant (Str String
op) ->
let opChars :: String
opChars = String
":!#$%&*+./<=>?@\\^|-~"
invalidOperators :: [String]
invalidOperators = [String
":", String
"=>", String
"->", String
"<-", String
"=", String
"?=", String
"|", String
"**", String
"==>", String
"\\", String
"%", String
"~", String
"?", String
"!"]
fixities :: [FixDecl]
fixities = IState -> [FixDecl]
idris_infixes IState
ist
in if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
opChars) String
op) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
op [String]
invalidOperators
then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"'" forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ String
"' is not a valid operator name."
else case forall a. Eq a => [a] -> [a]
nub [Fixity
f | Fix Fixity
f String
someOp <- [FixDecl]
fixities, String
someOp forall a. Eq a => a -> a -> Bool
== String
op] of
[] -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"No fixity found for operator '" forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ String
"'."
[Fixity
f] -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Fixity -> Raw
reflectFixity Fixity
f
[Fixity]
many -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$ String
"Ambiguous fixity for '" forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ String
"'! Found " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Fixity]
many
Term
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Not a constant string for an operator name: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
opTm
| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Debug"
= do ~[Term
ty, Term
msg] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
Term
msg' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
msg
[ErrorReportPart]
parts <- Term -> ElabD [ErrorReportPart]
reifyReportParts Term
msg
forall aux a. [ErrorReportPart] -> Elab' aux a
debugElaborator [ErrorReportPart]
parts
runTacTm Term
x = forall a. Term -> ElabD a
elabScriptStuck Term
x
runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac :: Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
autoSolve IState
ist Maybe FC
perhapsFC Name
fn PTactic
tac
= do Env
env <- forall aux. Elab' aux Env
get_env
Term
g <- forall aux. Elab' aux Term
goal
let tac' :: PTactic
tac' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IState -> [Name] -> PTerm -> PTerm
addImplBound IState
ist (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
env)) PTactic
tac
if Bool
autoSolve
then PTactic -> ElabD ()
runT PTactic
tac'
else forall aux. Elab' aux () -> Maybe Err -> Elab' aux ()
no_errors (PTactic -> ElabD ()
runT PTactic
tac')
(forall a. a -> Maybe a
Just (forall t. t -> [(Name, t)] -> Err' t
CantSolveGoal Term
g (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, forall b. Binder b -> b
binderTy Binder Term
b)) Env
env)))
where
runT :: PTactic -> ElabD ()
runT (Intro []) = do Term
g <- forall aux. Elab' aux Term
goal
forall aux. Elab' aux ()
attack; forall aux. Maybe Name -> Elab' aux ()
intro (forall {a}. TT a -> Maybe a
bname Term
g)
where
bname :: TT a -> Maybe a
bname (Bind a
n Binder (TT a)
_ TT a
_) = forall a. a -> Maybe a
Just a
n
bname TT a
_ = forall a. Maybe a
Nothing
runT (Intro [Name]
xs) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
x -> do forall aux. Elab' aux ()
attack; forall aux. Maybe Name -> Elab' aux ()
intro (forall a. a -> Maybe a
Just Name
x)) [Name]
xs
runT PTactic
Intros = do Term
g <- forall aux. Elab' aux Term
goal
forall aux. Elab' aux ()
attack;
forall aux. Maybe Name -> Elab' aux ()
intro (forall {a}. TT a -> Maybe a
bname Term
g)
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (PTactic -> ElabD ()
runT forall t. PTactic' t
Intros)
(forall (m :: * -> *) a. Monad m => a -> m a
return ()) Bool
True
where
bname :: TT a -> Maybe a
bname (Bind a
n Binder (TT a)
_ TT a
_) = forall a. a -> Maybe a
Just a
n
bname TT a
_ = forall a. Maybe a
Nothing
runT (Exact PTerm
tm) = do IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
runT (MatchRefine Name
fn)
= do [(Name, [Bool])]
fnimps <-
case forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
[] -> do [Bool]
a <- forall {aux}. Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
fn
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
fn, [Bool]
a)]
[(Name, [PArg])]
ns -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
n, [PArg]
a) -> (Name
n, forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Bool
True) [PArg]
a)) [(Name, [PArg])]
ns)
let tacs :: [(Elab' aux [(Name, Name)], Name)]
tacs = forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
fn', [Bool]
imps) ->
(forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
match_apply (Name -> Raw
Var Name
fn') (forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x, Int
0)) [Bool]
imps),
Name
fn')) [(Name, [Bool])]
fnimps
forall aux a. [(Elab' aux a, Name)] -> Elab' aux a
tryAll forall {aux}. [(Elab' aux [(Name, Name)], Name)]
tacs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
where envArgs :: Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
n = do Env
e <- forall aux. Elab' aux Env
get_env
case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
e of
Just Binder Term
t -> 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 b. a -> b -> a
const Bool
False)
(forall n. TT n -> [(n, TT n)]
getArgTys (forall b. Binder b -> b
binderTy Binder Term
t))
Maybe (Binder Term)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
runT (Refine Name
fn [])
= do [(Name, [Bool])]
fnimps <-
case forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
[] -> do [Bool]
a <- forall {aux}. Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
fn
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
fn, [Bool]
a)]
[(Name, [PArg])]
ns -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
n, [PArg]
a) -> (Name
n, forall a b. (a -> b) -> [a] -> [b]
map forall {t}. PArg' t -> Bool
isImp [PArg]
a)) [(Name, [PArg])]
ns)
let tacs :: [(Elab' aux [(Name, Name)], Name)]
tacs = forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
fn', [Bool]
imps) ->
(forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
fn') (forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x, Int
0)) [Bool]
imps),
Name
fn')) [(Name, [Bool])]
fnimps
forall aux a. [(Elab' aux a, Name)] -> Elab' aux a
tryAll forall {aux}. [(Elab' aux [(Name, Name)], Name)]
tacs
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
where isImp :: PArg' t -> Bool
isImp (PImp Int
_ Bool
_ [ArgOpt]
_ Name
_ t
_) = Bool
True
isImp PArg' t
_ = Bool
False
envArgs :: Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
n = do Env
e <- forall aux. Elab' aux Env
get_env
case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
e of
Just Binder Term
t -> 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 b. a -> b -> a
const Bool
False)
(forall n. TT n -> [(n, TT n)]
getArgTys (forall b. Binder b -> b
binderTy Binder Term
t))
Maybe (Binder Term)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
runT (Refine Name
fn [Bool]
imps) = do [(Name, Name)]
ns <- forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
fn) (forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x,Int
0)) [Bool]
imps)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
runT PTactic
DoUnify = do forall aux. Elab' aux ()
unify_all
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
runT (Claim Name
n PTerm
tm) = do Name
tmHole <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"newGoal")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tmHole Raw
RType
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n (Name -> Raw
Var Name
tmHole)
forall aux. Name -> Elab' aux ()
focus Name
tmHole
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
forall aux. Name -> Elab' aux ()
focus Name
n
runT (Equiv PTerm
tm)
= do forall aux. Elab' aux ()
attack
Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"ety")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"eqval")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"equiv_val")
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
forall aux. Name -> Elab' aux ()
focus Name
tyn
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
forall aux. Name -> Elab' aux ()
focus Name
valn
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
runT (Rewrite PTerm
tm)
= do forall aux. Elab' aux ()
attack;
Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rval")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rewrite_rule")
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
forall aux. Name -> Elab' aux ()
focus Name
valn
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
forall aux. Raw -> Elab' aux ()
rewrite (Name -> Raw
Var Name
letn)
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
runT (LetTac Name
n PTerm
tm)
= do forall aux. Elab' aux ()
attack
Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- forall aux. Name -> Elab' aux Name
unique_hole Name
n
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
forall aux. Name -> Elab' aux ()
focus Name
valn
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
runT (LetTacTy Name
n PTerm
ty PTerm
tm)
= do forall aux. Elab' aux ()
attack
Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- forall aux. Name -> Elab' aux Name
unique_hole Name
n
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
forall aux. Name -> Elab' aux ()
focus Name
tyn
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
ty
forall aux. Name -> Elab' aux ()
focus Name
valn
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
runT PTactic
Compute = forall aux. Elab' aux ()
compute
runT PTactic
Trivial = do IState -> ElabD ()
trivial' IState
ist; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
runT PTactic
TCImplementation = PTactic -> ElabD ()
runT (forall t. t -> PTactic' t
Exact (FC -> PTerm
PResolveTC FC
emptyFC))
runT (ProofSearch Bool
rec Bool
prover Int
depth Maybe Name
top [Name]
psns [Name]
hints)
= do IState
-> Bool
-> Bool
-> Int
-> Bool
-> Maybe Name
-> Name
-> [Name]
-> [Name]
-> ElabD ()
proofSearch' IState
ist Bool
rec Bool
False Int
depth Bool
prover Maybe Name
top Name
fn [Name]
psns [Name]
hints
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
runT (Focus Name
n) = forall aux. Name -> Elab' aux ()
focus Name
n
runT PTactic
Unfocus = do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
case [Name]
hs of
[] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Name
h : [Name]
_) -> forall aux. Name -> Elab' aux ()
movelast Name
h
runT PTactic
Solve = forall aux. Elab' aux ()
solve
runT (Try PTactic
l PTactic
r) = do forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (PTactic -> ElabD ()
runT PTactic
l) (PTactic -> ElabD ()
runT PTactic
r) Bool
True
runT (TSeq PTactic
l PTactic
r) = do PTactic -> ElabD ()
runT PTactic
l; PTactic -> ElabD ()
runT PTactic
r
runT (ApplyTactic PTerm
tm) = do Env
tenv <- forall aux. Elab' aux Env
get_env
Term
tgoal <- forall aux. Elab' aux Term
goal
forall aux. Elab' aux ()
attack
Name
script <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"script")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
script Raw
scriptTy
Name
scriptvar <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scriptvar" )
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
scriptvar RigCount
RigW Raw
scriptTy (Name -> Raw
Var Name
script)
forall aux. Name -> Elab' aux ()
focus Name
script
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
(Term
script', Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
scriptvar)
Name
restac <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"restac")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
restac Raw
tacticTy
forall aux. Name -> Elab' aux ()
focus Name
restac
forall aux. Raw -> Elab' aux ()
fill (Raw -> [Raw] -> Raw
raw_apply (Term -> Raw
forget Term
script')
[Env -> Raw
reflectEnv Env
tenv, Term -> Raw
reflect Term
tgoal])
Term
restac' <- forall aux. Elab' aux Term
get_guess
forall aux. Elab' aux ()
solve
Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
let tactic :: Term
tactic = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
restac'
Term -> ElabD ()
runReflected Term
tactic
where tacticTy :: Raw
tacticTy = Name -> Raw
Var (String -> Name
reflm String
"Tactic")
listTy :: Raw
listTy = Name -> Raw
Var (Name -> [String] -> Name
sNS (String -> Name
sUN String
"List") [String
"List", String
"Prelude"])
scriptTy :: Raw
scriptTy = (Name -> Binder Raw -> Raw -> Raw
RBind (Int -> String -> Name
sMN Int
0 String
"__pi_arg")
(forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW forall a. Maybe a
Nothing (Raw -> Raw -> Raw
RApp Raw
listTy Raw
envTupleType) Raw
RType)
(Name -> Binder Raw -> Raw -> Raw
RBind (Int -> String -> Name
sMN Int
1 String
"__pi_arg")
(forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW forall a. Maybe a
Nothing (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT") Raw
RType) Raw
tacticTy))
runT (ByReflection PTerm
tm)
= do Term
tgoal <- forall aux. Elab' aux Term
goal
forall aux. Elab' aux ()
attack
Name
script <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"script")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
script Raw
scriptTy
Name
scriptvar <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scriptvar" )
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
scriptvar RigCount
RigW Raw
scriptTy (Name -> Raw
Var Name
script)
forall aux. Name -> Elab' aux ()
focus Name
script
Term
ptm <- forall aux. Elab' aux Term
get_term
Env
env <- forall aux. Elab' aux Env
get_env
let denv :: [(Name, Term)]
denv = forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, forall b. Binder b -> b
binderTy Binder Term
b)) Env
env
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")
(FC -> PTerm -> [PArg] -> PTerm
PApp FC
emptyFC PTerm
tm [forall {t}. t -> PArg' t
pexp (IState
-> [PArg]
-> [(Name, Term)]
-> Term
-> Bool
-> Bool
-> Bool
-> PTerm
delabTy' IState
ist [] [(Name, Term)]
denv Term
tgoal Bool
True Bool
True Bool
True)])
(Term
script', Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
scriptvar)
Name
restac <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"restac")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
restac Raw
tacticTy
forall aux. Name -> Elab' aux ()
focus Name
restac
forall aux. Raw -> Elab' aux ()
fill (Term -> Raw
forget Term
script')
Term
restac' <- forall aux. Elab' aux Term
get_guess
forall aux. Elab' aux ()
solve
Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
let tactic :: Term
tactic = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
restac'
Term -> ElabD ()
runReflected Term
tactic
where tacticTy :: Raw
tacticTy = Name -> Raw
Var (String -> Name
reflm String
"Tactic")
scriptTy :: Raw
scriptTy = Raw
tacticTy
runT (Reflect PTerm
v) = do forall aux. Elab' aux ()
attack
Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letvar")
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
forall aux. Name -> Elab' aux ()
focus Name
valn
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
v
(Term
value, Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
letn)
Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
let value' :: Term
value' = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
value
Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
autoSolve IState
ist Maybe FC
perhapsFC Name
fn (forall t. t -> PTactic' t
Exact forall a b. (a -> b) -> a -> b
$ Raw -> PTerm
PQuote (Term -> Raw
reflect Term
value'))
runT (Fill PTerm
v) = do forall aux. Elab' aux ()
attack
Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letvar")
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
forall aux. Name -> Elab' aux ()
focus Name
valn
IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
v
(Term
value, Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
letn)
Context
ctxt <- forall aux. Elab' aux Context
get_context
Env
env <- forall aux. Elab' aux Env
get_env
let value' :: Term
value' = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
value
Raw
rawValue <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
value'
Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
autoSolve IState
ist Maybe FC
perhapsFC Name
fn (forall t. t -> PTactic' t
Exact forall a b. (a -> b) -> a -> b
$ Raw -> PTerm
PQuote Raw
rawValue)
runT (GoalType String
n PTactic
tac) = do Term
g <- forall aux. Elab' aux Term
goal
case forall n. TT n -> (TT n, [TT n])
unApply Term
g of
(P NameType
_ Name
n' Term
_, [Term]
_) ->
if Name -> Name
nsroot Name
n' forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
n
then PTactic -> ElabD ()
runT PTactic
tac
else forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong goal type"
(Term, [Term])
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong goal type"
runT PTactic
ProofState = do Term
g <- forall aux. Elab' aux Term
goal
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runT PTactic
Skip = forall (m :: * -> *) a. Monad m => a -> m a
return ()
runT (TFail [ErrorReportPart]
err) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. [[ErrorReportPart]] -> Err' t -> Err' t
ReflectionError [[ErrorReportPart]
err] (forall t. String -> Err' t
Msg String
"")
runT PTactic
SourceFC =
case Maybe FC
perhapsFC of
Maybe FC
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg String
"There is no source location available."
Just FC
fc ->
do forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ FC -> Raw
reflectFC FC
fc
forall aux. Elab' aux ()
solve
runT PTactic
Qed = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg String
"The qed command is only valid in the interactive prover"
runT PTactic
x = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not implemented " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTactic
x
runReflected :: Term -> ElabD ()
runReflected Term
t = do PTactic
t' <- IState -> Term -> ElabD PTactic
reify IState
ist Term
t
Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
autoSolve IState
ist Maybe FC
perhapsFC Name
fn PTactic
t'
elaboratingArgErr :: [(Name, Name)] -> Err -> Err
elaboratingArgErr :: [(Name, Name)] -> Err -> Err
elaboratingArgErr [] Err
err = Err
err
elaboratingArgErr ((Name
f,Name
x):[(Name, Name)]
during) Err
err = forall a. a -> Maybe a -> a
fromMaybe Err
err (forall {t}. Err' t -> Maybe (Err' t)
rewrite Err
err)
where rewrite :: Err' t -> Maybe (Err' t)
rewrite (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err' t
_) = forall a. Maybe a
Nothing
rewrite (ProofSearchFail Err' t
e) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t. Err' t -> Err' t
ProofSearchFail (Err' t -> Maybe (Err' t)
rewrite Err' t
e)
rewrite (At FC
fc Err' t
e) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall t. FC -> Err' t -> Err' t
At FC
fc) (Err' t -> Maybe (Err' t)
rewrite Err' t
e)
rewrite Err' t
err = forall a. a -> Maybe a
Just (forall t. Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
ElaboratingArg Name
f Name
x [(Name, Name)]
during Err' t
err)
withErrorReflection :: Idris a -> Idris a
withErrorReflection :: forall a. Idris a -> Idris a
withErrorReflection Idris a
x = forall a. Idris a -> (Err -> Idris a) -> Idris a
idrisCatch Idris a
x (\ Err
e -> Err -> Idris Err
handle Err
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Err -> Idris a
ierror)
where handle :: Err -> Idris Err
handle :: Err -> Idris Err
handle e :: Err
e@(ReflectionError [[ErrorReportPart]]
_ Err
_) = do Int -> String -> Idris ()
logElab Int
3 String
"Skipping reflection of error reflection result"
forall (m :: * -> *) a. Monad m => a -> m a
return Err
e
handle e :: Err
e@(ReflectionFailed String
_ Err
_) = do Int -> String -> Idris ()
logElab Int
3 String
"Skipping reflection of reflection failure"
forall (m :: * -> *) a. Monad m => a -> m a
return Err
e
handle e :: Err
e@(At FC
fc Err
err) = do Int -> String -> Idris ()
logElab Int
3 String
"Reflecting body of At"
Err
err' <- Err -> Idris Err
handle Err
err
forall (m :: * -> *) a. Monad m => a -> m a
return (forall t. FC -> Err' t -> Err' t
At FC
fc Err
err')
handle e :: Err
e@(Elaborating String
what Name
n Maybe Term
ty Err
err) = do Int -> String -> Idris ()
logElab Int
3 String
"Reflecting body of Elaborating"
Err
err' <- Err -> Idris Err
handle Err
err
forall (m :: * -> *) a. Monad m => a -> m a
return (forall t. String -> Name -> Maybe t -> Err' t -> Err' t
Elaborating String
what Name
n Maybe Term
ty Err
err')
handle e :: Err
e@(ElaboratingArg Name
f Name
a [(Name, Name)]
prev Err
err) = do Int -> String -> Idris ()
logElab Int
3 String
"Reflecting body of ElaboratingArg"
[Name]
hs <- Name -> Name -> Idris [Name]
getFnHandlers Name
f Name
a
Err
err' <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
hs
then Err -> Idris Err
handle Err
err
else Err -> [Name] -> Idris Err
applyHandlers Err
err [Name]
hs
forall (m :: * -> *) a. Monad m => a -> m a
return (forall t. Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
ElaboratingArg Name
f Name
a [(Name, Name)]
prev Err
err')
handle (ProofSearchFail Err
e) = Err -> Idris Err
handle Err
e
handle Err
e = do IState
ist <- Idris IState
getIState
Int -> String -> Idris ()
logElab Int
2 String
"Starting error reflection"
Int -> String -> Idris ()
logElab Int
5 (forall a. Show a => a -> String
show Err
e)
let handlers :: [Name]
handlers = IState -> [Name]
idris_errorhandlers IState
ist
Err -> [Name] -> Idris Err
applyHandlers Err
e [Name]
handlers
getFnHandlers :: Name -> Name -> Idris [Name]
getFnHandlers :: Name -> Name -> Idris [Name]
getFnHandlers Name
f Name
arg = do IState
ist <- Idris IState
getIState
let funHandlers :: Map Name (Set Name)
funHandlers = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall k a. Map k a
M.empty forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
.
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.
IState -> Ctxt (Map Name (Set Name))
idris_function_errorhandlers forall a b. (a -> b) -> a -> b
$ IState
ist
forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
arg forall a b. (a -> b) -> a -> b
$ Map Name (Set Name)
funHandlers
applyHandlers :: Err -> [Name] -> Idris Err
applyHandlers Err
e [Name]
handlers =
do IState
ist <- Idris IState
getIState
let err :: Err
err = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IState -> Term -> Term
errReverse IState
ist) Err
e
Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
"Using reflection handlers " forall a. [a] -> [a] -> [a]
++
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Name]
handlers))
let reports :: [Raw]
reports = forall a b. (a -> b) -> [a] -> [b]
map (\Name
n -> Raw -> Raw -> Raw
RApp (Name -> Raw
Var Name
n) (Err -> Raw
reflectErr Err
err)) [Name]
handlers
[(Term, Term)]
handlers <- case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Context -> Env -> Raw -> TC (Term, Term)
check (IState -> Context
tt_ctxt IState
ist) []) [Raw]
reports of
Error Err
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
OK [(Term, Term)]
hs -> forall (m :: * -> *) a. Monad m => a -> m a
return [(Term, Term)]
hs
Context
ctxt <- Idris Context
getContext
let results :: [Term]
results = forall a b. (a -> b) -> [a] -> [b]
map (Context -> Env -> Term -> Term
normaliseAll Context
ctxt []) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Term, Term)]
handlers)
Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
"New error message info: " forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
" and " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Term]
results))
let errorpartsTT :: [[Term]]
errorpartsTT = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Term -> Maybe [Term]
unList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Term -> Maybe Term
fromTTMaybe [Term]
results)
[[ErrorReportPart]]
errorparts <- case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Term -> Either Err ErrorReportPart
reifyReportPart) [[Term]]
errorpartsTT of
Left Err
err -> forall a. Err -> Idris a
ierror Err
err
Right [[ErrorReportPart]]
ok -> forall (m :: * -> *) a. Monad m => a -> m a
return [[ErrorReportPart]]
ok
forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [[ErrorReportPart]]
errorparts of
[] -> Err
e
[[ErrorReportPart]]
parts -> forall t. [[ErrorReportPart]] -> Err' t -> Err' t
ReflectionError [[ErrorReportPart]]
errorparts Err
e
solveAll :: Elab' aux ()
solveAll = forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do forall aux. Elab' aux ()
solve; Elab' aux ()
solveAll) (forall (m :: * -> *) a. Monad m => a -> m a
return ())
processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()
processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()
processTacticDecls ElabInfo
info [RDeclInstructions]
steps =
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse [RDeclInstructions]
steps) forall a b. (a -> b) -> a -> b
$ \case
RTyDeclInstrs Name
n FC
fc [PArg]
impls Term
ty ->
do Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
"Declaration from tactics: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
ty
Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
" It has impls " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [PArg]
impls
(IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits :: Ctxt [PArg]
idris_implicits =
forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
n [PArg]
impls (IState -> Ctxt [PArg]
idris_implicits IState
i) }
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCImp Name
n)
[(Name, (Int, Maybe Name, Term, [Name]))]
ds <- ElabInfo
-> FC
-> (Name -> Err -> Err)
-> Bool
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> Idris [(Name, (Int, Maybe Name, Term, [Name]))]
checkDef ElabInfo
info FC
fc (\Name
_ Err
e -> Err
e) Bool
True [(Name
n, (-Int
1, forall a. Maybe a
Nothing, Term
ty, []))]
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCDef Name
n)
Context
ctxt <- Idris Context
getContext
case Name -> Context -> [Def]
lookupDef Name
n Context
ctxt of
(TyDecl NameType
_ Term
_ : [Def]
_) ->
let ds' :: [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))]
ds' = forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, (Int
i, Maybe Name
top, Term
t, [Name]
ns)) -> (Name
n, (Int
i, Maybe Name
top, Term
t, [Name]
ns, Bool
True, Bool
True))) [(Name, (Int, Maybe Name, Term, [Name]))]
ds
in [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))] -> Idris ()
addDeferred [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))]
ds'
[Def]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RDatatypeDeclInstrs Name
n [PArg]
impls ->
do IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCDef Name
n)
(IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits :: Ctxt [PArg]
idris_implicits = forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
n [PArg]
impls (IState -> Ctxt [PArg]
idris_implicits IState
i) }
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCImp Name
n)
RDatatypeDefnInstrs Name
tyn Term
tyconTy [(Name, [PArg], Term)]
ctors ->
do let cn :: (a, b, c) -> a
cn (a
n, b
_, c
_) = a
n
cty :: (a, b, c) -> c
cty (a
_, b
_, c
t) = c
t
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCDef Name
tyn)
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IBCWrite -> Idris ()
addIBC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IBCWrite
IBCDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> a
cn) [(Name, [PArg], Term)]
ctors
Context
ctxt <- Idris Context
getContext
let params :: [Int]
params = Name -> Term -> [Term] -> [Int]
findParams Name
tyn (Context -> Env -> Term -> Term
normalise Context
ctxt [] Term
tyconTy) (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> c
cty [(Name, [PArg], Term)]
ctors)
let typeInfo :: TypeInfo
typeInfo = [Name] -> Bool -> DataOpts -> [Int] -> [Name] -> Bool -> TypeInfo
TI (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
cn [(Name, [PArg], Term)]
ctors) Bool
False [] [Int]
params [] Bool
False
(IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_datatypes :: Ctxt TypeInfo
idris_datatypes =
forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
tyn TypeInfo
typeInfo (IState -> Ctxt TypeInfo
idris_datatypes IState
i) }
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCData Name
tyn)
Int
ttag <- Idris Int
getName
let metainf :: MetaInformation
metainf = [Int] -> MetaInformation
DataMI [Int]
params
IBCWrite -> Idris ()
addIBC (Name -> MetaInformation -> IBCWrite
IBCMetaInformation Name
tyn MetaInformation
metainf)
(Context -> Context) -> Idris ()
updateContext (Name -> MetaInformation -> Context -> Context
setMetaInformation Name
tyn MetaInformation
metainf)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Name, [PArg], Term)]
ctors forall a b. (a -> b) -> a -> b
$ \(Name
cn, [PArg]
impls, Term
_) ->
do (IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits :: Ctxt [PArg]
idris_implicits = forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
cn [PArg]
impls (IState -> Ctxt [PArg]
idris_implicits IState
i) }
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCImp Name
cn)
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Name, [PArg], Term)]
ctors forall a b. (a -> b) -> a -> b
$ \(Name
ctorN, [PArg]
_, Term
_) ->
do (FC, Name) -> Idris ()
totcheck (FC
NoFC, Name
ctorN)
Context
ctxt <- IState -> Context
tt_ctxt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Idris IState
getIState
case Name -> Context -> Maybe Term
lookupTyExact Name
ctorN Context
ctxt of
Just Term
cty -> do [Name] -> (Name, Term) -> Idris Totality
checkPositive (Name
tyn forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
cn [(Name, [PArg], Term)]
ctors) (Name
ctorN, Term
cty)
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Term
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
case [(Name, [PArg], Term)]
ctors of
[(Name, [PArg], Term)
ctor] -> do Name -> Idris ()
setDetaggable (forall {a} {b} {c}. (a, b, c) -> a
cn (Name, [PArg], Term)
ctor); Name -> Idris ()
setDetaggable Name
tyn
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCOpt (forall {a} {b} {c}. (a, b, c) -> a
cn (Name, [PArg], Term)
ctor)); IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCOpt Name
tyn)
[(Name, [PArg], Term)]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
RAddImplementation Name
interfaceName Name
implName ->
do
Int -> String -> Idris ()
logElab Int
2 forall a b. (a -> b) -> a -> b
$ String
"Adding elab script implementation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
implName forall a. [a] -> [a] -> [a]
++
String
" for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
interfaceName
Bool -> Bool -> Name -> Name -> Idris ()
addImplementation Bool
False Bool
True Name
interfaceName Name
implName
IBCWrite -> Idris ()
addIBC (Bool -> Bool -> Name -> Name -> IBCWrite
IBCImplementation Bool
False Bool
True Name
interfaceName Name
implName)
RClausesInstrs Name
n [([(Name, Term)], Term, Term)]
cs ->
do Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
"Pattern-matching definition from tactics: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n
FC -> Name -> Idris ()
solveDeferred FC
emptyFC Name
n
let lhss :: [([Name], Term)]
lhss = forall a b. (a -> b) -> [a] -> [b]
map (\([(Name, Term)]
ns, Term
lhs, Term
_) -> (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, Term)]
ns, Term
lhs)) [([(Name, Term)], Term, Term)]
cs
let fc :: FC
fc = String -> FC
fileFC String
"elab_reflected"
[PTerm]
pmissing <-
do IState
ist <- Idris IState
getIState
[PTerm]
possible <- FC
-> Name
-> [([Name], Term)]
-> [PTerm]
-> StateT IState (ExceptT Err IO) [PTerm]
genClauses FC
fc Name
n [([Name], Term)]
lhss
(forall a b. (a -> b) -> [a] -> [b]
map (\ ([Name]
ns, Term
lhs) ->
IState -> Term -> Bool -> Bool -> PTerm
delab' IState
ist Term
lhs Bool
True Bool
True) [([Name], Term)]
lhss)
[PTerm]
missing <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Name -> PTerm -> Idris Bool
checkPossible Name
n) [PTerm]
possible
let undef :: [PTerm]
undef = forall a. (a -> Bool) -> [a] -> [a]
filter (forall {t :: * -> *}.
Foldable t =>
IState -> t Term -> PTerm -> Bool
noMatch IState
ist (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [([Name], Term)]
lhss)) [PTerm]
missing
forall (m :: * -> *) a. Monad m => a -> m a
return [PTerm]
undef
let tot :: Totality
tot = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PTerm]
pmissing
then Totality
Unchecked
else PReason -> Totality
Partial PReason
NotCovering
Name -> Totality -> Idris ()
setTotality Name
n Totality
tot
(IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_patdefs :: Ctxt ([([(Name, Term)], Term, Term)], [PTerm])
idris_patdefs =
forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
n ([([(Name, Term)], Term, Term)]
cs, [PTerm]
pmissing) forall a b. (a -> b) -> a -> b
$ IState -> Ctxt ([([(Name, Term)], Term, Term)], [PTerm])
idris_patdefs IState
i }
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCDef Name
n)
Context
ctxt <- Idris Context
getContext
case Name -> Context -> Maybe Def
lookupDefExact Name
n Context
ctxt of
Just (CaseOp CaseInfo
_ Term
_ [(Term, Bool)]
_ [Either Term (Term, Term)]
_ [([Name], Term, Term)]
_ CaseDefs
cd) ->
let ([Name]
scargs, SC
sc) = CaseDefs -> ([Name], SC)
cases_compiletime CaseDefs
cd
calls :: [Name]
calls = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ SC -> [Name] -> [(Name, [[Name]])]
findCalls SC
sc [Name]
scargs
in do Int -> String -> Idris ()
logElab Int
2 forall a b. (a -> b) -> a -> b
$ String
"Called names in reflected elab: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Name]
calls
Name -> [Name] -> Idris ()
addCalls Name
n [Name]
calls
IBCWrite -> Idris ()
addIBC forall a b. (a -> b) -> a -> b
$ Name -> IBCWrite
IBCCG Name
n
Just Def
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Def
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
(FC, Name) -> Idris ()
buildSCG (FC
fc, Name
n)
Totality
tot' <- (FC, Name) -> Idris Totality
checkDeclTotality (FC
fc, Name
n)
Name -> Totality -> Idris ()
setTotality Name
n Totality
tot'
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Totality
tot' forall a. Eq a => a -> a -> Bool
/= Totality
Unchecked) forall a b. (a -> b) -> a -> b
$ IBCWrite -> Idris ()
addIBC (Name -> Totality -> IBCWrite
IBCTotal Name
n Totality
tot')
where
checkPossible :: Name -> PTerm -> Idris Bool
checkPossible :: Name -> PTerm -> Idris Bool
checkPossible Name
fname PTerm
lhs_in =
do Context
ctxt <- Idris Context
getContext
IState
ist <- Idris IState
getIState
let lhs :: PTerm
lhs = IState -> PTerm -> PTerm
addImplPat IState
ist PTerm
lhs_in
let fc :: FC
fc = String -> FC
fileFC String
"elab_reflected_totality"
case forall aux a.
String
-> Context
-> Ctxt TypeInfo
-> Int
-> Name
-> Term
-> aux
-> Elab' aux a
-> TC (a, String)
elaborate (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt (IState -> Ctxt TypeInfo
idris_datatypes IState
ist) (IState -> Int
idris_name IState
ist) (Int -> String -> Name
sMN Int
0 String
"refPatLHS") Term
infP EState
initEState
(forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc (IState
-> ElabInfo
-> ElabMode
-> FnOpts
-> Name
-> [Name]
-> PTerm
-> ElabD ElabResult
buildTC IState
ist ElabInfo
info ElabMode
EImpossible [] Name
fname (PTerm -> [Name]
allNamesIn PTerm
lhs_in)
(PTerm -> PTerm
infTerm PTerm
lhs))) of
OK (ElabResult Term
lhs' [(Name, (Int, Maybe Name, Term, [Name]))]
_ [PDecl]
_ Context
_ [RDeclInstructions]
_ Set (FC', OutputAnnotation)
_ Int
name', String
_) ->
do
let lhs_tm :: Term
lhs_tm = Term -> Term
orderPats (Term -> Term
getInferTerm Term
lhs')
(IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_name :: Int
idris_name = Int
name' }
case String -> Context -> Env -> Raw -> Term -> TC (Term, Term, UCs)
recheck (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt [] (Term -> Raw
forget Term
lhs_tm) Term
lhs_tm of
OK (Term, Term, UCs)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
TC (Term, Term, UCs)
err -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Error Err
err -> forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Err -> Bool
recoverableCoverage Context
ctxt Err
err)
noMatch :: IState -> t Term -> PTerm -> Bool
noMatch IState
i t Term
cs PTerm
tm = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Term
x -> case IState -> PTerm -> PTerm -> Either (PTerm, PTerm) [(Name, PTerm)]
matchClause IState
i (IState -> Term -> Bool -> Bool -> PTerm
delab' IState
i Term
x Bool
True Bool
True) PTerm
tm of
Right [(Name, PTerm)]
_ -> Bool
False
Left (PTerm, PTerm)
_ -> Bool
True) t Term
cs