{-# 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
(ElabMode -> ElabMode -> Bool)
-> (ElabMode -> ElabMode -> Bool) -> Eq ElabMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ElabMode -> ElabMode -> Bool
== :: ElabMode -> ElabMode -> Bool
$c/= :: ElabMode -> ElabMode -> Bool
/= :: 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 Name -> Ctxt TIData -> [TIData]
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 <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
[Name]
ivs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_implementations
Term
ptm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
(Name -> ElabD ()) -> [Name] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
ElabD () -> ElabD () -> ElabD ()
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)
(Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
n)) [Name]
ivs
[Name]
ivs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_implementations
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
(Name -> ElabD ()) -> [Name] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
Term
ptm <- Elab' EState Term
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
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
False
Term
tm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Fails
probs <- Elab' EState Fails
forall aux. Elab' aux Fails
get_probs
Bool
u <- Elab' EState Bool
forall aux. Elab' aux Bool
getUnifyLog
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
Bool -> String -> ElabD () -> ElabD ()
forall {a}. Bool -> String -> a -> a
traceWhen Bool
u (String
"Remaining holes:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Name] -> String
forall a. Show a => a -> String
show [Name]
hs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
"Remaining problems:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Fails -> String
qshow Fails
probs) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
do ElabD ()
forall aux. Elab' aux ()
unify_all; Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
matchProblems Bool
True; ElabD ()
forall aux. Elab' aux ()
unifyProblems
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
True
Fails
probs <- Elab' EState Fails
forall aux. Elab' aux Fails
get_probs
case Fails
probs of
[] -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
((Term
_,Term
_,Bool
_,Env
_,Err
e,[FailContext]
_,FailAt
_):Fails
es) -> Bool -> String -> ElabD () -> ElabD ()
forall {a}. Bool -> String -> a -> a
traceWhen Bool
u (String
"Final problems:\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Fails -> String
qshow Fails
probs String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nin\n" String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
tm) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
if Bool
inf then () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Err -> TC ()
forall a. Err -> TC a
Error Err
e)
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tydecl (do ElabD ()
forall aux. Elab' aux ()
mkPat
(Term -> Term) -> ElabD ()
forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
(Term -> Term) -> ElabD ()
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)]
_ <- Elab' EState EState
forall aux. Elab' aux aux
getAux
Term
tt <- Elab' EState Term
forall aux. Elab' aux Term
get_term
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
let (Term
tm, [(Name, (Int, Maybe Name, Term, [Name]))]
ds) = State [(Name, (Int, Maybe Name, Term, [Name]))] Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> (Term, [(Name, (Int, Maybe Name, Term, [Name]))])
forall s a. State s a -> s -> (a, s)
runState (Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
fn) (((Name, PDecl) -> Name) -> [(Name, PDecl)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PDecl) -> Name
forall a b. (a, b) -> a
fst [(Name, PDecl)]
is) Context
ctxt Term
tt) []
String
log <- Elab' EState String
forall aux. Elab' aux String
getLog
Int
g_nextname <- Elab' EState Int
forall aux. Elab' aux Int
get_global_nextname
if String
log String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
""
then String -> ElabD ElabResult -> ElabD ElabResult
forall a. String -> a -> a
trace String
log (ElabD ElabResult -> ElabD ElabResult)
-> ElabD ElabResult -> ElabD ElabResult
forall a b. (a -> b) -> a -> b
$ ElabResult -> ElabD ElabResult
forall a. a -> StateT (ElabState EState) TC a
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 (((Name, PDecl) -> PDecl) -> [(Name, PDecl)] -> [PDecl]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PDecl) -> PDecl
forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)
else ElabResult -> ElabD ElabResult
forall a. a -> StateT (ElabState EState) TC a
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 (((Name, PDecl) -> PDecl) -> [(Name, PDecl)] -> [PDecl]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PDecl) -> PDecl
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 ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
tydecl :: Bool
tydecl = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl
mkPat :: StateT (ElabState aux) TC ()
mkPat = do [Name]
hs <- Elab' aux [Name]
forall aux. Elab' aux [Name]
get_holes
Term
tm <- Elab' aux Term
forall aux. Elab' aux Term
get_term
case [Name]
hs of
(Name
h: [Name]
hs) -> do Name -> StateT (ElabState aux) TC ()
forall aux. Name -> Elab' aux ()
patvar Name
h; StateT (ElabState aux) TC ()
mkPat
[] -> () -> StateT (ElabState aux) TC ()
forall a. a -> StateT (ElabState aux) TC a
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 Name -> Ctxt TIData -> [TIData]
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] -> ElabD ()
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 <- Elab' EState Fails
forall aux. Elab' aux Fails
get_probs
Term
tm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
case Fails
probs of
[] -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
((Term
_,Term
_,Bool
_,Env
_,Err
e,[FailContext]
_,FailAt
_):Fails
es) -> if Bool
inf then () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
else TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Err -> TC ()
forall a. Err -> TC a
Error Err
e)
[(Name, [Name])]
dots <- Elab' EState [(Name, [Name])]
forall aux. Elab' aux [(Name, [Name])]
get_dotterm
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([(Name, [Name])] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, [Name])]
dots)) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Err -> TC ()
forall a. Err -> TC a
Error (Term -> Err
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)]
_ <- Elab' EState EState
forall aux. Elab' aux aux
getAux
Term
tt <- Elab' EState Term
forall aux. Elab' aux Term
get_term
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
let (Term
tm, [(Name, (Int, Maybe Name, Term, [Name]))]
ds) = State [(Name, (Int, Maybe Name, Term, [Name]))] Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> (Term, [(Name, (Int, Maybe Name, Term, [Name]))])
forall s a. State s a -> s -> (a, s)
runState (Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
fn) (((Name, PDecl) -> Name) -> [(Name, PDecl)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PDecl) -> Name
forall a b. (a, b) -> a
fst [(Name, PDecl)]
is) Context
ctxt Term
tt) []
String
log <- Elab' EState String
forall aux. Elab' aux String
getLog
Int
g_nextname <- Elab' EState Int
forall aux. Elab' aux Int
get_global_nextname
if (String
log String -> String -> Bool
forall a. Eq a => a -> a -> Bool
/= String
"")
then String -> ElabD ElabResult -> ElabD ElabResult
forall a. String -> a -> a
trace String
log (ElabD ElabResult -> ElabD ElabResult)
-> ElabD ElabResult -> ElabD ElabResult
forall a b. (a -> b) -> a -> b
$ ElabResult -> ElabD ElabResult
forall a. a -> StateT (ElabState EState) TC a
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 (((Name, PDecl) -> PDecl) -> [(Name, PDecl)] -> [PDecl]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PDecl) -> PDecl
forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)
else ElabResult -> ElabD ElabResult
forall a. a -> StateT (ElabState EState) TC a
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 (((Name, PDecl) -> PDecl) -> [(Name, PDecl)] -> [PDecl]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PDecl) -> PDecl
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 Name -> Name -> Bool
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 Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
env
Term
_ -> [Name]
env in
[Name] -> [[Name]] -> Term -> [Bool]
checkArgs [Name]
env' ([Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
intersect [Name]
env (Term -> [Name]
refsIn Term
t) [Name] -> [[Name]] -> [[Name]]
forall a. a -> [a] -> [a]
: [[Name]]
ns)
(Term -> Term -> Term
forall n. TT n -> TT n -> TT n
instantiate (NameType -> Name -> Term -> Term
forall n. NameType -> n -> TT n -> TT n
P NameType
Bound Name
n Term
t) Term
sc)
checkArgs [Name]
env [[Name]]
ns Term
t
= ([Name] -> Bool) -> [[Name]] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not (Bool -> Bool) -> ([Name] -> Bool) -> [Name] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Name]] -> [[Name]]
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 :: Elab' EState Bool
goal_polymorphic =
do Term
ty <- Elab' EState Term
forall aux. Elab' aux Term
goal
case Term
ty of
P NameType
_ Name
n Term
_ -> do Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
case Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Maybe (Binder Term)
Nothing -> Bool -> Elab' EState Bool
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Maybe (Binder Term)
_ -> Bool -> Elab' EState Bool
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
Term
_ -> Bool -> Elab' EState Bool
forall a. a -> StateT (ElabState EState) TC a
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)
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
loglvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
unifyLog Bool
True
ElabD ()
forall aux. Elab' aux ()
compute
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
initElabCtxt (ElabInfo -> Maybe FC
elabFC ElabInfo
info) PTerm
tm
EState
est <- Elab' EState EState
forall aux. Elab' aux aux
getAux
[ElabD ()] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (EState -> [ElabD ()]
get_delayed_elab EState
est)
ElabD ()
forall aux. Elab' aux ()
end_unify
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
do ElabD ()
forall aux. Elab' aux ()
unify_all
Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
matchProblems Bool
False
ElabD ()
forall aux. Elab' aux ()
unifyProblems
ElabD ()
forall aux. Elab' aux ()
mkPat
(Term -> Term) -> ElabD ()
forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
Term
ptm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pattern (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
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
(Term -> Term) -> ElabD ()
forall aux. (Term -> Term) -> Elab' aux ()
update_term ([(Name, RigCount)] -> Term -> Term
setLinear [(Name, RigCount)]
pnms)
where
pattern :: Bool
pattern = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
eimpossible :: Bool
eimpossible = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
intransform :: Bool
intransform = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ETransLHS
bindfree :: Bool
bindfree = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ETransLHS
Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
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
((Int, ElabD ()) -> ElabD ()) -> [(Int, ElabD ())] -> [ElabD ()]
forall a b. (a -> b) -> [a] -> [b]
map (Int, ElabD ()) -> ElabD ()
forall a b. (a, b) -> b
snd ([(Int, ElabD ())] -> [ElabD ()])
-> [(Int, ElabD ())] -> [ElabD ()]
forall a b. (a -> b) -> a -> b
$ ((Int, ElabD ()) -> (Int, ElabD ()) -> Ordering)
-> [(Int, ElabD ())] -> [(Int, ElabD ())]
forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Int
p1, ElabD ()
_) (Int
p2, ElabD ()
_) -> Int -> Int -> Ordering
forall a. Ord a => a -> a -> Ordering
compare Int
p1 Int
p2) [(Int, ElabD ())]
ds
tcgen :: Bool
tcgen = FnOpt
Dictionary FnOpt -> FnOpts -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts
reflection :: Bool
reflection = FnOpt
Reflection FnOpt -> FnOpts -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts
isph :: PArg -> (Bool, Int)
isph PArg
arg = case PArg -> PTerm
forall t. PArg' t -> t
getTm PArg
arg of
PTerm
Placeholder -> (Bool
True, PArg -> Int
forall t. PArg' t -> Int
priority PArg
arg)
PTerm
tm -> (Bool
False, PArg -> Int
forall t. PArg' t -> Int
priority PArg
arg)
mkPat :: StateT (ElabState aux) TC ()
mkPat = do [Name]
hs <- Elab' aux [Name]
forall aux. Elab' aux [Name]
get_holes
Term
tm <- Elab' aux Term
forall aux. Elab' aux Term
get_term
case [Name]
hs of
(Name
h: [Name]
hs) -> do Name -> StateT (ElabState aux) TC ()
forall aux. Name -> Elab' aux ()
patvar Name
h; StateT (ElabState aux) TC ()
mkPat
[] -> () -> StateT (ElabState aux) TC ()
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
elabRec :: PTerm -> ElabD ()
elabRec = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
initElabCtxt Maybe FC
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 <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_recents
[(Name, ([FailContext], [Name]))]
as <- Elab' EState [(Name, ([FailContext], [Name]))]
forall aux. Elab' aux [(Name, ([FailContext], [Name]))]
get_autos
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
((Name, ([FailContext], [Name])) -> ElabD ())
-> [(Name, ([FailContext], [Name]))] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Name
a, ([FailContext]
failc, [Name]
ns)) ->
if (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
n -> Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
solved) [Name]
ns Bool -> Bool -> Bool
&& [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
hs Name -> Name -> Bool
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 () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) [(Name, ([FailContext], [Name]))]
as
PTerm
apt <- PTerm -> StateT (ElabState EState) TC PTerm
forall {aux}. PTerm -> StateT (ElabState aux) TC PTerm
expandToArity PTerm
t
PTerm
itm <- if Bool -> Bool
not Bool
pattern then ElabCtxt -> PTerm -> StateT (ElabState EState) TC PTerm
forall {p} {aux}. p -> PTerm -> StateT (ElabState aux) TC PTerm
insertImpLam ElabCtxt
ina PTerm
apt else PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
apt
PTerm
ct <- ElabCtxt -> PTerm -> StateT (ElabState EState) TC PTerm
forall {p} {aux}. p -> PTerm -> StateT (ElabState aux) TC PTerm
insertCoerce ElabCtxt
ina PTerm
itm
PTerm
t' <- ElabCtxt -> PTerm -> StateT (ElabState EState) TC PTerm
insertLazy ElabCtxt
ina PTerm
ct
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
Term
tm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
Fails
ps <- Elab' EState Fails
forall aux. Elab' aux Fails
get_probs
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
let fc :: FC
fc = String -> FC
fileFC String
"Force"
(Err -> Bool) -> ElabD () -> ElabD () -> ElabD ()
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"))
[Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"t") PTerm
Placeholder Bool
True,
Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"a") PTerm
Placeholder Bool
True,
PTerm -> PArg
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]
_) <- Term -> (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 Text -> Text -> Bool
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]
_) <- Term -> (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 Text -> Text -> Bool
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]
_) <- Term -> (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 Text -> Text -> Bool
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 Text -> Text -> Bool
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 Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply Raw
RType []
ElabD ()
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 Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
UniquenessTypes LanguageExt -> [LanguageExt] -> Bool
forall a. Eq a => a -> [a] -> Bool
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) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ FC -> Err -> Err
forall t. FC -> Err' t -> Err' t
At FC
fc' (String -> Err
forall t. String -> Err' t
Msg String
"You must turn on the UniquenessTypes extension to use UniqueType or AnyType")
Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Universe -> Raw
RUType Universe
u) []
ElabD ()
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (String -> String -> OutputAnnotation
AnnType (Universe -> String
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
= TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
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
= TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
forall a. Show a => a -> String
show PTerm
tm)
| Bool
otherwise = do Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Const -> Raw
RConstant Const
c) []
ElabD ()
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 Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill Raw
r; ElabD ()
forall aux. Elab' aux ()
solve
elab' ElabCtxt
ina Maybe FC
_ (PTrue FC
fc PunInfo
_) =
do ElabD ()
forall aux. Elab' aux ()
compute
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
case Term
g of
TType UExp
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
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 (FC -> Maybe FC
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 (FC -> Maybe FC
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 <- Elab' EState Term
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 <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"__interface")
Name -> ElabD ()
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
eqTy, [PTerm
Placeholder, PTerm
Placeholder, PTerm
l, PTerm
r] <- (PArg -> PTerm) -> [PArg] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map PArg -> PTerm
forall t. PArg' t -> t
getTm [PArg]
args
= ElabD () -> ElabD () -> ElabD ()
forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"aqty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
tyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
eqTy)
[Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
tyn) Bool
True,
Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
tyn) Bool
False,
PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
l, PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
r]))
(do Name
atyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"aqty")
Name
btyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"bqty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
atyn Raw
RType
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
atyn
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
btyn Raw
RType
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
btyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
eqTy)
[Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
atyn) Bool
True,
Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
btyn) Bool
False,
PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
l, PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
r]))
elab' ElabCtxt
ina Maybe FC
_ (PPair FC
fc [FC]
hls PunInfo
_ PTerm
l PTerm
r)
= do ElabD ()
forall aux. Elab' aux ()
compute
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
let (Term
tc, [Term]
_) = Term -> (Term, [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 (FC -> Maybe FC
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)
[PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
l,PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
r])
UType Universe
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
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)
[PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
l,PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
r])
Term
_ -> case Term
tc of
P NameType
_ Name
n Term
_ | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
upairTy
-> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
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)
[Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") PTerm
Placeholder Bool
False,
Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") PTerm
Placeholder Bool
False,
PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
l, PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
r])
Term
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
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)
[Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") PTerm
Placeholder Bool
False,
Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") PTerm
Placeholder Bool
False,
PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
l, PTerm -> PArg
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 ElabD ()
forall aux. Elab' aux ()
compute
Term
g <- Elab' EState Term
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 (FC -> Maybe FC
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)
[PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
t,
PTerm -> PArg
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 (FC -> Maybe FC
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)
[Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"a") PTerm
t Bool
False,
Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"P") PTerm
Placeholder Bool
True,
PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
l, PTerm -> PArg
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 (FC -> Maybe FC
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)
[Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"a") PTerm
t Bool
False,
Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"P") PTerm
Placeholder Bool
True,
PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
l, PTerm -> PArg
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 <- [PTerm] -> StateT (ElabState EState) TC [PTerm]
forall {aux}. [PTerm] -> StateT (ElabState aux) TC [PTerm]
doPrune [PTerm]
as
[Name]
uns <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_usedns
let as' :: [PTerm]
as' = (PTerm -> PTerm) -> [PTerm] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> [(Name, Name)] -> PTerm -> PTerm
mkUniqueNames ([Name]
uns [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ ((Name, Name) -> Name) -> [(Name, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Name) -> Name
forall a b. (a, b) -> b
snd [(Name, Name)]
ms) [(Name, Name)]
ms) [PTerm]
as_pruned
~(Name
h : [Name]
hs) <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Term
ty <- Elab' EState Term
forall aux. Elab' aux Term
goal
case [PTerm]
as' of
[] -> do [Name]
hds <- (PTerm -> Elab' EState Name) -> [PTerm] -> Elab' EState [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PTerm -> Elab' EState Name
forall {aux}. PTerm -> StateT (ElabState aux) TC Name
showHd [PTerm]
as
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ [Name] -> Err
forall t. [Name] -> Err' t
NoValidAlts [Name]
hds
[PTerm
x] -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x
[PTerm]
_ -> (Err -> Bool) -> ElabD () -> ElabD () -> ElabD ()
forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError Err -> Bool
forall {t}. Err' t -> Bool
isAmbiguous
(do [Name]
hds <- (PTerm -> Elab' EState Name) -> [PTerm] -> Elab' EState [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PTerm -> Elab' EState Name
forall {aux}. PTerm -> StateT (ElabState aux) TC Name
showHd [PTerm]
as'
[(ElabD (), Name)] -> ElabD ()
forall aux a. [(Elab' aux a, Name)] -> Elab' aux a
tryAll ([ElabD ()] -> [Name] -> [(ElabD (), Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((PTerm -> ElabD ()) -> [PTerm] -> [ElabD ()]
forall a b. (a -> b) -> [a] -> [b]
map (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc) [PTerm]
as')
[Name]
hds))
(do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
h
Int -> ElabD () -> ElabD ()
delayElab Int
5 (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ do
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
h Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ do
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
h
[PTerm]
as'' <- [PTerm] -> StateT (ElabState EState) TC [PTerm]
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 <- (PTerm -> Elab' EState Name) -> [PTerm] -> Elab' EState [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PTerm -> Elab' EState Name
forall {aux}. PTerm -> StateT (ElabState aux) TC Name
showHd [PTerm]
as''
Bool -> [(ElabD (), Name)] -> ElabD ()
forall aux a. Bool -> [(Elab' aux a, Name)] -> Elab' aux a
tryAll' Bool
False ([ElabD ()] -> [Name] -> [(ElabD (), Name)]
forall a b. [a] -> [b] -> [(a, b)]
zip ((PTerm -> ElabD ()) -> [PTerm] -> [ElabD ()]
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delay" = PTerm -> StateT (ElabState aux) TC Name
showHd (PArg -> PTerm
forall t. PArg' t -> t
getTm PArg
arg)
showHd (PApp FC
_ (PRef FC
_ [FC]
_ Name
n) [PArg]
_) = Name -> StateT (ElabState aux) TC Name
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
showHd (PRef FC
_ [FC]
_ Name
n) = Name -> StateT (ElabState aux) TC Name
forall a. a -> StateT (ElabState aux) TC a
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 = Name -> StateT (ElabState aux) TC Name
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 Elab' aux ()
forall aux. Elab' aux ()
compute
Term
ty <- Elab' aux Term
forall aux. Elab' aux Term
goal
Context
ctxt <- Elab' aux Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' aux Env
forall aux. Elab' aux Env
get_env
let ty' :: Term
ty' = Term -> Term
unDelay Term
ty
let (Term
tc, [Term]
_) = Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply Term
ty'
[PTerm] -> StateT (ElabState aux) TC [PTerm]
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ([PTerm] -> StateT (ElabState aux) TC [PTerm])
-> [PTerm] -> StateT (ElabState aux) TC [PTerm]
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]) <- Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply Term
t,
Text
l Text -> Text -> Bool
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 <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_usedns
let as :: [PTerm]
as = (PTerm -> PTerm) -> [PTerm] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> [(Name, Name)] -> PTerm -> PTerm
mkUniqueNames ([Name]
uns [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ ((Name, Name) -> Name) -> [(Name, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Name) -> Name
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
ElabD () -> ElabD () -> Bool -> ElabD ()
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' ElabD ()
e1 (ElabD () -> [PTerm] -> ElabD ()
forall {a}. StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' ElabD ()
e1 [PTerm]
xs) Bool
True
trySeq [] = String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
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; ElabD ()
forall aux. Elab' aux ()
unifyProblems
trySeq' StateT (ElabState EState) TC a
deferr (PTerm
x : [PTerm]
xs)
= ElabD () -> ElabD () -> Bool -> ElabD ()
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (ElabD () -> (Err -> ElabD ()) -> ElabD ()
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
ElabD ()
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 <- Elab' EState Env
forall aux. Elab' aux Env
get_env
ElabD ()
forall aux. Elab' aux ()
compute
Term
ty <- Elab' EState Term
forall aux. Elab' aux Term
goal
let doelab :: ElabD ()
doelab = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
orig
ElabD () -> (Err -> ElabD ()) -> ElabD ()
forall aux a. Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
tryCatch ElabD ()
doelab
(\Err
err ->
if Err -> Bool
forall {t}. Err' t -> Bool
recoverableErr Err
err
then
case Err -> [PTerm] -> Env -> [PTerm]
pruneAlts Err
err [PTerm]
alts Env
env of
[] -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail Err
err
[PTerm]
alts' -> do
ElabD () -> ElabD () -> Bool -> ElabD ()
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'))
(TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail Err
err)
Bool
True
else TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
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 Term -> (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
inc) of
(P (TCon Int
_ Int
_) Name
n Term
_, [Term]
_) -> (PTerm -> Bool) -> [PTerm] -> [PTerm]
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])
_ -> (PTerm -> Bool) -> [PTerm] -> [PTerm]
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
_ = (PTerm -> Bool) -> [PTerm] -> [PTerm]
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 = ((Name, Term) -> Term) -> [(Name, Term)] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Term) -> Term
forall a b. (a, b) -> b
snd (Term -> [(Name, Term)]
forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty)) in
(Term -> Bool) -> [Term] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> Term -> Bool
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) = (PTerm -> Bool) -> [PTerm] -> Bool
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 Name -> Name -> Bool
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 TT a -> (TT a, [TT a])
forall n. TT n -> (TT n, [TT n])
unApply TT a
ty of
(P NameType
_ a
n' TT a
_, [TT a]
_) -> a
n a -> a -> Bool
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 Name -> ElabD ()
forall aux. Name -> Elab' aux ()
patvar Name
n
(Term -> Term) -> ElabD ()
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)
= TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
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
= TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
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 <- Elab' EState Term
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState 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 FC -> ElabD () -> ElabD ()
forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
patvar Name
n
(Term -> Term) -> ElabD ()
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 ElabD () -> ElabD () -> ElabD ()
forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
n) []
OutputAnnotation
annot <- Name -> ElabD OutputAnnotation
findHighlight Name
n
ElabD ()
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc OutputAnnotation
annot)
(do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
patvar Name
n
(Term -> Term) -> ElabD ()
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 Name -> Ctxt [Name] -> [(Name, [Name])]
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 (FC -> Maybe FC
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)
= TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
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
= TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
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) = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (String -> TC ()) -> String -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (String -> Err) -> String -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> ElabD ()) -> String -> ElabD ()
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Context -> Bool
isTConName Name
n Context
ctxt) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (String -> Err
forall t. String -> Err' t
Msg (String -> Err) -> String -> Err
forall a b. (a -> b) -> a -> b
$ String
"Can't use type constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" here")
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
checkPiGoal Name
n
ElabD ()
forall aux. Elab' aux ()
attack; Maybe Name -> ElabD ()
forall aux. Maybe Name -> Elab' aux ()
intro (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n);
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
addPSname Name
n
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg = True } ) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
sc; ElabD ()
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 <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"lamty")
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Context -> Bool
isTConName Name
n Context
ctxt) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (String -> Err
forall t. String -> Err' t
Msg (String -> Err) -> String -> Err
forall a b. (a -> b) -> a -> b
$ String
"Can't use type constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" here")
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
checkPiGoal Name
n
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
explicit Name
tyn
ElabD ()
forall aux. Elab' aux ()
attack
Term
ptm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Raw -> Maybe Name -> ElabD ()
forall aux. Raw -> Maybe Name -> Elab' aux ()
introTy (Name -> Raw
Var Name
tyn) (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
n)
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
addPSname Name
n
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
tyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ec { e_inarg = True, e_intype = True }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
ty
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ec { e_inarg = True }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
sc
ElabD ()
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 ElabD ()
forall aux. Elab' aux ()
attack;
case Plicity -> RigCount
pcount Plicity
p of
RigCount
RigW -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RigCount
_ -> Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
LinearTypes LanguageExt -> [LanguageExt] -> Bool
forall a. Eq a => a -> [a] -> Bool
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) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ FC -> Err -> Err
forall t. FC -> Err' t -> Err' t
At FC
nfc (String -> Err
forall t. String -> Err' t
Msg String
"You must turn on the LinearTypes extension to use a count")
Name -> RigCount -> Maybe ImplicitInfo -> Name -> ElabD ()
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
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
addPSname Name
n
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg = True, e_intype = True }) Maybe FC
fc PTerm
sc
ElabD ()
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 ElabD ()
forall aux. Elab' aux ()
attack; Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"piTy")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
n' <- case Name
n of
MN Int
_ Text
_ -> Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
unique_hole Name
n
Name
_ -> Name -> Elab' EState Name
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
case Plicity -> RigCount
pcount Plicity
p of
RigCount
RigW -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RigCount
_ -> Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
LinearTypes LanguageExt -> [LanguageExt] -> Bool
forall a. Eq a => a -> [a] -> Bool
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) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ FC -> Err -> Err
forall t. FC -> Err' t -> Err' t
At FC
nfc (String -> Err
forall t. String -> Err' t
Msg String
"You must turn on the LinearTypes extension to use a linear argument")
Name -> RigCount -> Maybe ImplicitInfo -> Raw -> ElabD ()
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'
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
addPSname Name
n'
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
tyn
let ec' :: ElabCtxt
ec' = ElabCtxt
ina { e_inarg = True, e_intype = 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
ElabD ()
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 ElabD ()
forall aux. Elab' aux ()
attack
[Name]
ivs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_implementations
Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
explicit Name
valn
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n RigCount
rig (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
addPSname Name
n
case PTerm
ty of
PTerm
Placeholder -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
PTerm
_ -> do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
tyn
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
explicit Name
tyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg = True, e_intype = True })
(FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
ty
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
valn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg = True, e_intype = True })
(FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
val
[Name]
ivs' <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_implementations
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg = True }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
sc
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform)) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
(Name -> ElabD ()) -> [Name] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
if (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Name
n -> Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tyn Bool -> Bool -> Bool
|| Bool -> Bool
not (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs)) (Term -> [Name]
forall n. Eq n => TT n -> [n]
freeNames Term
g)
then (Err -> Bool) -> ElabD () -> ElabD () -> ElabD ()
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)
(Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
n)
else Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
n)
([Name]
ivs' [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
ivs)
Name -> Term -> ElabD ()
forall aux. Name -> Term -> Elab' aux ()
expandLet Name
n (case Name -> Env -> Maybe (Binder Term)
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 -> String -> Term
forall a. HasCallStack => String -> a
error (String
"Value not a let binding: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Maybe (Binder Term) -> String
forall a. Show a => a -> String
show Maybe (Binder Term)
other))
ElabD ()
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 <- Elab' EState Term
forall aux. Elab' aux Term
goal
ElabD ()
forall aux. Elab' aux ()
attack
Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
valn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg = True, e_intype = True }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc PTerm
r [PTerm -> PArg
forall {t}. t -> PArg' t
pexp (IState -> Term -> PTerm
delab IState
ist Term
rty)])
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
computeLet Name
n
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg = True }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
sc
ElabD ()
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 <- Elab' EState Term
forall aux. Elab' aux Term
goal
[Name]
ds <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_deferred
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
[(Name, (Bool, Raw))]
argTys <- Env -> [PArg] -> StateT (ElabState EState) TC [(Name, (Bool, Raw))]
forall {aux}.
Env -> [PArg] -> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
claimArgTys Env
env [PArg]
args
Name
fn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"inf_fn")
let fty :: Raw
fty = [(Name, (Bool, Raw))] -> Term -> Raw
forall {a}. [(Name, (a, Raw))] -> Term -> Raw
fnTy [(Name, (Bool, Raw))]
argTys Term
rty
ElabD ()
forall aux. Elab' aux ()
attack; Name -> Raw -> [Name] -> ElabD ()
forall aux. Name -> Raw -> [Name] -> Elab' aux ()
deferType (Name -> Name
mkN Name
f) Raw
fty (((Name, (Bool, Raw)) -> Name) -> [(Name, (Bool, Raw))] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, (Bool, Raw)) -> Name
forall a b. (a, b) -> a
fst [(Name, (Bool, Raw))]
argTys); ElabD ()
forall aux. Elab' aux ()
solve
(((Name, (Bool, Raw)), PArg) -> ElabD ())
-> [((Name, (Bool, Raw)), PArg)] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((Name, (Bool, Raw)), PArg) -> ElabD ()
forall {b}. ((Name, (Bool, b)), PArg) -> ElabD ()
elabIArg ([(Name, (Bool, Raw))] -> [PArg] -> [((Name, (Bool, Raw)), PArg)]
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 [] = [(Name, (Bool, Raw))]
-> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
forall a. a -> StateT (ElabState aux) TC a
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 (PArg -> PTerm
forall t. PArg' t -> t
getTm PArg
arg)
= do Term
nty <- Raw -> Elab' aux Term
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
[(Name, (Bool, Raw))]
-> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n, (Bool
False, Term -> Raw
forget Term
nty)) (Name, (Bool, Raw))
-> [(Name, (Bool, Raw))] -> [(Name, (Bool, Raw))]
forall a. a -> [a] -> [a]
: [(Name, (Bool, Raw))]
ans)
claimArgTys Env
env (PArg
_ : [PArg]
xs)
= do Name
an <- Name -> Elab' aux Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"inf_argTy")
Name
aval <- Name -> Elab' aux Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"inf_arg")
Name -> Raw -> Elab' aux ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
an Raw
RType
Name -> Raw -> Elab' aux ()
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
[(Name, (Bool, Raw))]
-> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
aval, (Bool
True, (Name -> Raw
Var Name
an))) (Name, (Bool, Raw))
-> [(Name, (Bool, Raw))] -> [(Name, (Bool, Raw))]
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 (RigCount -> Maybe ImplicitInfo -> Raw -> Raw -> Binder Raw
forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW Maybe ImplicitInfo
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 Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
x Env
env of
Just Binder Term
_ -> Name -> Maybe Name
forall a. a -> Maybe a
Just Name
x
Maybe (Binder Term)
_ -> Maybe Name
forall a. Maybe a
Nothing
localVar Env
env PTerm
_ = Maybe Name
forall a. Maybe a
Nothing
elabIArg :: ((Name, (Bool, b)), PArg) -> ElabD ()
elabIArg ((Name
n, (Bool
True, b
ty)), PArg
def) =
do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n; ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (PArg -> PTerm
forall t. PArg' t -> t
getTm PArg
def)
elabIArg ((Name, (Bool, b)), PArg)
_ = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
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 Name -> Ctxt [PArg] -> [(Name, [PArg])]
forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
[(Name
n, [PArg]
args)] -> (Name, [Bool]) -> StateT (ElabState EState) TC (Name, [Bool])
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, (PArg -> Bool) -> [PArg] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> PArg -> Bool
forall a b. a -> b -> a
const Bool
True) [PArg]
args)
[(Name, [PArg])]
_ -> TC (Name, [Bool]) -> StateT (ElabState EState) TC (Name, [Bool])
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Name, [Bool]) -> StateT (ElabState EState) TC (Name, [Bool]))
-> TC (Name, [Bool]) -> StateT (ElabState EState) TC (Name, [Bool])
forall a b. (a -> b) -> a -> b
$ Err -> TC (Name, [Bool])
forall a. Err -> TC a
tfail (Name -> Err
forall t. Name -> Err' t
NoSuchVariable Name
fn)
[(Name, Name)]
ns <- Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
match_apply (Name -> Raw
Var Name
fn') ((Bool -> (Bool, Int)) -> [Bool] -> [(Bool, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x,Int
0)) [Bool]
imps)
ElabD ()
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
= TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
forall a. Show a => a -> String
show PTerm
tm)
| Bool
otherwise = ElabD [ImplicitInfo] -> ElabD ()
implicitApp (ElabD [ImplicitInfo] -> ElabD ())
-> ElabD [ImplicitInfo] -> ElabD ()
forall a b. (a -> b) -> a -> b
$
do Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
Term
ty <- Elab' EState Term
forall aux. Elab' aux Term
goal
Term
fty <- Raw -> Elab' EState Term
forall aux. Raw -> Elab' aux Term
get_type (Name -> Raw
Var Name
f)
Context
ctxt <- Elab' EState Context
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 <- (PArg -> StateT (ElabState EState) TC (Maybe Name))
-> [PArg] -> StateT (ElabState EState) TC [Maybe Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM PArg -> StateT (ElabState EState) TC (Maybe Name)
forall {m :: * -> *} {t}. Monad m => PArg' t -> m (Maybe Name)
getKnownImplicit [PArg]
args_in
let knowns :: [Name]
knowns = (Maybe Name -> Maybe Name) -> [Maybe Name] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Maybe Name -> Maybe Name
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 []
Bool -> ElabD () -> ElabD ()
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)) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
forall a. Show a => a -> String
show PTerm
tm)
if (Name
f Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Name, RigCount, Binder Term) -> Name) -> Env -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, RigCount, Binder Term) -> Name
forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
env Bool -> Bool -> Bool
&& [PArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PArg]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& [PArg] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [PArg]
args_in Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
1)
then
do Bool -> ElabD () -> ElabD () -> String -> ElabD ()
forall aux.
Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
simple_app Bool
False
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_isfn = True }) (FC -> Maybe FC
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 = True,
e_guarded = dataCon }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (PArg -> PTerm
forall t. PArg' t -> t
getTm ([PArg] -> PArg
forall a. HasCallStack => [a] -> a
head [PArg]
args)))
(PTerm -> String
forall a. Show a => a -> String
show PTerm
tm)
ElabD ()
forall aux. Elab' aux ()
solve
((FC, OutputAnnotation) -> ElabD ())
-> [(FC, OutputAnnotation)] -> StateT (ElabState EState) TC [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((FC -> OutputAnnotation -> ElabD ())
-> (FC, OutputAnnotation) -> ElabD ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FC -> OutputAnnotation -> ElabD ()
highlightSource) ([(FC, OutputAnnotation)] -> StateT (ElabState EState) TC [()])
-> [(FC, OutputAnnotation)] -> StateT (ElabState EState) TC [()]
forall a b. (a -> b) -> a -> b
$
(FC
ffc, OutputAnnotation
annot) (FC, OutputAnnotation)
-> [(FC, OutputAnnotation)] -> [(FC, OutputAnnotation)]
forall a. a -> [a] -> [a]
: (FC -> (FC, OutputAnnotation)) -> [FC] -> [(FC, OutputAnnotation)]
forall a b. (a -> b) -> [a] -> [b]
map (\FC
f -> (FC
f, OutputAnnotation
annot)) [FC]
hls
[ImplicitInfo] -> ElabD [ImplicitInfo]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return []
else
do [Name]
ivs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_implementations
Fails
ps <- Elab' EState Fails
forall aux. Elab' aux Fails
get_probs
let isinf :: Bool
isinf = Name
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
inferCon Bool -> Bool -> Bool
|| Name -> Bool
tcname Name
f
case Name -> Ctxt InterfaceInfo -> [InterfaceInfo]
forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
f (IState -> Ctxt InterfaceInfo
idris_interfaces IState
ist) of
[] -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[InterfaceInfo]
_ -> do (PTerm -> ElabD ()) -> [PTerm] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ PTerm -> ElabD ()
forall {aux}. PTerm -> Elab' aux ()
setInjective ((PArg -> PTerm) -> [PArg] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map PArg -> PTerm
forall t. PArg' t -> t
getTm [PArg]
args)
ElabD ()
forall aux. Elab' aux ()
unifyProblems
[(Name, Name)]
ns <- Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
f) ((PArg -> (Bool, Int)) -> [PArg] -> [(Bool, Int)]
forall a b. (a -> b) -> [a] -> [b]
map PArg -> (Bool, Int)
isph [PArg]
args)
(Name -> ElabD ()) -> [Name] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Name -> ElabD ()
forall aux. Name -> Elab' aux ()
checkIfInjective (((Name, Name) -> Name) -> [(Name, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Name) -> Name
forall a b. (a, b) -> b
snd [(Name, Name)]
ns)
ElabD ()
forall aux. Elab' aux ()
unifyProblems
Bool
ulog <- Elab' EState Bool
forall aux. Elab' aux Bool
getUnifyLog
OutputAnnotation
annot <- Name -> ElabD OutputAnnotation
findHighlight Name
f
((FC, OutputAnnotation) -> ElabD ())
-> [(FC, OutputAnnotation)] -> StateT (ElabState EState) TC [()]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((FC -> OutputAnnotation -> ElabD ())
-> (FC, OutputAnnotation) -> ElabD ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FC -> OutputAnnotation -> ElabD ()
highlightSource) ([(FC, OutputAnnotation)] -> StateT (ElabState EState) TC [()])
-> [(FC, OutputAnnotation)] -> StateT (ElabState EState) TC [()]
forall a b. (a -> b) -> a -> b
$
(FC
ffc, OutputAnnotation
annot) (FC, OutputAnnotation)
-> [(FC, OutputAnnotation)] -> [(FC, OutputAnnotation)]
forall a. a -> [a] -> [a]
: (FC -> (FC, OutputAnnotation)) -> [FC] -> [(FC, OutputAnnotation)]
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 = e_inarg ina || not isinf,
e_guarded = dataCon })
[] FC
fc Bool
False Name
f
([(Name, Name)] -> [Bool] -> [((Name, Name), Bool)]
forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, Name)]
ns ([Bool]
unmatchableArgs [Bool] -> [Bool] -> [Bool]
forall a. [a] -> [a] -> [a]
++ Bool -> [Bool]
forall a. a -> [a]
repeat Bool
False))
(Name
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"Force")
((PArg -> PTerm) -> [PArg] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map (\PArg
x -> PArg -> PTerm
forall t. PArg' t -> t
getTm PArg
x) [PArg]
args)
[ImplicitInfo]
imp <- if (ElabCtxt -> Bool
e_isfn ElabCtxt
ina) then
do Term
guess <- Elab' EState Term
forall aux. Elab' aux Term
get_guess
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
case [Name] -> Term -> Maybe Raw
safeForgetEnv (((Name, RigCount, Binder Term) -> Name) -> Env -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, RigCount, Binder Term) -> Name
forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
env) Term
guess of
Maybe Raw
Nothing ->
[ImplicitInfo] -> ElabD [ImplicitInfo]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return []
Just Raw
rguess -> do
Term
gty <- Raw -> Elab' EState Term
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
[ImplicitInfo] -> ElabD [ImplicitInfo]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ([ImplicitInfo] -> ElabD [ImplicitInfo])
-> [ImplicitInfo] -> ElabD [ImplicitInfo]
forall a b. (a -> b) -> a -> b
$ Term -> [ImplicitInfo]
forall {n}. TT n -> [ImplicitInfo]
getReqImps Term
ty_n
else [ImplicitInfo] -> ElabD [ImplicitInfo]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return []
case [ImplicitInfo]
imp of
rs :: [ImplicitInfo]
rs@(ImplicitInfo
_:[ImplicitInfo]
_) | Bool -> Bool
not Bool
pattern -> [ImplicitInfo] -> ElabD [ImplicitInfo]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return [ImplicitInfo]
rs
[ImplicitInfo]
_ -> do ElabD ()
forall aux. Elab' aux ()
solve
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
[Name]
ivs' <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_implementations
Bool -> ElabD () -> ElabD ()
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)) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
(Name -> ElabD ()) -> [Name] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
if (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Name
n -> Bool -> Bool
not (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs)) (Term -> [Name]
forall n. Eq n => TT n -> [n]
freeNames Term
g)
then (Err -> Bool) -> ElabD () -> ElabD () -> ElabD ()
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)
(Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
n)
else Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
n)
([Name]
ivs' [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
ivs)
[ImplicitInfo] -> ElabD [ImplicitInfo]
forall a. a -> StateT (ElabState EState) TC a
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; () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise
= do ElabState EState
s <- StateT (ElabState EState) TC (ElabState EState)
forall s (m :: * -> *). MonadState s m => m s
get
[ImplicitInfo]
imps <- ElabD [ImplicitInfo]
elab
case [ImplicitInfo]
imps of
[] -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[ImplicitInfo]
es -> do ElabState EState -> ElabD ()
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 ArgOpt -> [ArgOpt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` PArg' t -> [ArgOpt]
forall t. PArg' t -> [ArgOpt]
argopts PArg' t
imp
= Maybe Name -> m (Maybe Name)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing
| Bool
otherwise = Maybe Name -> m (Maybe Name)
forall a. a -> m a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Maybe Name
forall a. a -> Maybe a
Just (PArg' t -> Name
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 ImplicitInfo -> [ImplicitInfo] -> [ImplicitInfo]
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 <- Elab' aux Env
forall aux. Elab' aux Env
get_env
case Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Maybe (Binder Term)
Nothing -> () -> StateT (ElabState aux) TC ()
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just Binder Term
b ->
case Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env (Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
b)) of
(P NameType
_ Name
c Term
_, [Term]
args) ->
case Name -> Ctxt InterfaceInfo -> Maybe InterfaceInfo
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
c (IState -> Ctxt InterfaceInfo
idris_interfaces IState
ist) of
Maybe InterfaceInfo
Nothing -> () -> StateT (ElabState aux) TC ()
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just InterfaceInfo
ci ->
do (Term -> StateT (ElabState aux) TC ())
-> [Term] -> StateT (ElabState aux) TC ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ Term -> StateT (ElabState aux) TC ()
forall {aux}. Term -> Elab' aux ()
setinjArg (Int -> [Int] -> [Term] -> [Term]
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 <- Elab' aux Bool
forall aux. Elab' aux Bool
getUnifyLog
Fails
probs <- Elab' aux Fails
forall aux. Elab' aux Fails
get_probs
[Name]
inj <- Elab' aux [Name]
forall aux. Elab' aux [Name]
get_inj
Bool
-> String
-> StateT (ElabState aux) TC ()
-> StateT (ElabState aux) TC ()
forall {a}. Bool -> String -> a -> a
traceWhen Bool
ulog (String
"Injective now " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Term] -> String
forall a. Show a => a -> String
show [Term]
args String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nAll: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Name] -> String
forall a. Show a => a -> String
show [Name]
inj
String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"\nProblems: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Fails -> String
qshow Fails
probs) (StateT (ElabState aux) TC () -> StateT (ElabState aux) TC ())
-> StateT (ElabState aux) TC () -> StateT (ElabState aux) TC ()
forall a b. (a -> b) -> a -> b
$
StateT (ElabState aux) TC ()
forall aux. Elab' aux ()
unifyProblems
Fails
probs <- Elab' aux Fails
forall aux. Elab' aux Fails
get_probs
Bool
-> String
-> StateT (ElabState aux) TC ()
-> StateT (ElabState aux) TC ()
forall {a}. Bool -> String -> a -> a
traceWhen Bool
ulog (Fails -> String
qshow Fails
probs) (StateT (ElabState aux) TC () -> StateT (ElabState aux) TC ())
-> StateT (ElabState aux) TC () -> StateT (ElabState aux) TC ()
forall a b. (a -> b) -> a -> b
$ () -> StateT (ElabState aux) TC ()
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Term, [Term])
_ -> () -> StateT (ElabState aux) TC ()
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
setinjArg :: Term -> Elab' aux ()
setinjArg (P NameType
_ Name
n Term
_) = Name -> Elab' aux ()
forall aux. Name -> Elab' aux ()
setinj Name
n
setinjArg Term
_ = () -> Elab' aux ()
forall a. a -> StateT (ElabState aux) TC a
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 t -> t t -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t t
ds = a
a a -> [a] -> [a]
forall a. a -> [a] -> [a]
: t -> t t -> [a] -> [a]
getDets (t
i t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) t t
ds [a]
as
| Bool
otherwise = t -> t t -> [a] -> [a]
getDets (t
i t -> t -> t
forall a. Num a => a -> a -> a
+ t
1) t t
ds [a]
as
setInjective :: PTerm -> Elab' aux ()
setInjective (PRef FC
_ [FC]
_ Name
n) = Name -> Elab' aux ()
forall aux. Name -> Elab' aux ()
setinj Name
n
setInjective (PApp FC
_ (PRef FC
_ [FC]
_ Name
n) [PArg]
_) = Name -> Elab' aux ()
forall aux. Name -> Elab' aux ()
setinj Name
n
setInjective PTerm
_ = () -> Elab' aux ()
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
elab' ElabCtxt
ina Maybe FC
_ tm :: PTerm
tm@(PApp FC
fc PTerm
f [PArg
arg]) =
FC -> ElabD () -> ElabD ()
forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
do Bool -> ElabD () -> ElabD () -> String -> ElabD ()
forall aux.
Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
simple_app (Bool -> Bool
not (Bool -> Bool) -> Bool -> Bool
forall a b. (a -> b) -> a -> b
$ PTerm -> Bool
headRef PTerm
f)
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_isfn = True }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
f)
(ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg = True }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (PArg -> PTerm
forall t. PArg' t -> t
getTm PArg
arg))
(PTerm -> String
forall a. Show a => a -> String
show PTerm
tm)
ElabD ()
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) = (PTerm -> Bool) -> [PTerm] -> Bool
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 [ImplicitInfo] -> ElabD ()
forall {a}. [a] -> ElabD ()
appImpl ([ImplicitInfo] -> [ImplicitInfo]
forall a. [a] -> [a]
reverse [ImplicitInfo]
es)
ElabD ()
forall aux. Elab' aux ()
solve
where appImpl :: [a] -> ElabD ()
appImpl [] = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' (ElabCtxt
ina { e_isfn = False }) Maybe FC
fc PTerm
f
appImpl (a
e : [a]
es) = Bool -> ElabD () -> ElabD () -> String -> ElabD ()
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)
(PTerm -> String
forall a. Show a => a -> String
show PTerm
f)
elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder
= do ~(Name
h : [Name]
hs) <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
h
elab' ElabCtxt
ina Maybe FC
fc (PMetavar FC
nfc Name
n) =
do Term
ptm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
Env
env <- Elab' EState 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
ElabD ()
forall aux. Elab' aux ()
attack
[Name]
psns <- Elab' EState [Name]
forall aux. Elab' aux [Name]
getPSnames
Name
n' <- [Name] -> [Name] -> Name -> Elab' EState Name
forall aux. [Name] -> [Name] -> Name -> Elab' aux Name
defer [Name]
unique_used [Name]
lin_used Name
n'
ElabD ()
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n' (NameOutput -> Maybe NameOutput
forall a. a -> Maybe a
Just NameOutput
MetavarOutput) Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
elab' ElabCtxt
ina Maybe FC
fc (PProof [PTactic]
ts) = do ElabD ()
forall aux. Elab' aux ()
compute; (PTactic -> ElabD ()) -> [PTactic] -> ElabD ()
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 (PTactic -> ElabD ()) -> [PTactic] -> ElabD ()
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) = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
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)
= TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (String -> Err
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 ElabD ()
forall aux. Elab' aux ()
attack
Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scval")
Name
scvn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scvar")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
let scrnames :: [Name]
scrnames = PTerm -> [Name]
allNamesIn PTerm
scr
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
scvn ([Name] -> Env -> RigCount
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 (((PTerm, PTerm) -> PTerm) -> [(PTerm, PTerm)] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map (PTerm, PTerm) -> PTerm
forall a b. (a, b) -> a
fst [(PTerm, PTerm)]
opts)
case Maybe PTerm
scrTy of
Maybe PTerm
Nothing -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PTerm
ty -> do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
tyn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
ty
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
valn
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg = True }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
scr
ElabD ()
forall aux. Elab' aux ()
unifyProblems
Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
matchProblems Bool
True
Env
args <- Elab' EState Env
forall aux. Elab' aux Env
get_env
[(Name, Bool)]
envU <- ((Name, RigCount, Binder Term)
-> StateT (ElabState EState) TC (Name, Bool))
-> Env -> StateT (ElabState EState) TC [(Name, Bool)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Env
-> (Name, RigCount, Binder Term)
-> StateT (ElabState EState) TC (Name, Bool)
forall {b} {c} {aux}.
Env -> (Name, b, c) -> StateT (ElabState aux) TC (Name, Bool)
getKind Env
args) Env
args
Term
ptm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
let inOpts :: [Name]
inOpts = ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
scvn) (((Name, RigCount, Binder Term) -> Name) -> Env -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, RigCount, Binder Term) -> Name
forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
args)) [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ (((PTerm, PTerm) -> [Name]) -> [(PTerm, PTerm)] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PTerm, PTerm)
x -> PTerm -> [Name]
allNamesIn ((PTerm, PTerm) -> PTerm
forall a b. (a, b) -> b
snd (PTerm, PTerm)
x)) [(PTerm, PTerm)]
opts)
let argsDropped :: [Name]
argsDropped = (Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (\Name
t -> [(Name, Bool)] -> Name -> Bool
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)
([Name] -> [Name]
forall a. Eq a => [a] -> [a]
nub ([Name] -> [Name]) -> [Name] -> [Name]
forall a b. (a -> b) -> a -> b
$ [Name]
scrnames [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ Term -> [Name]
forall {a}. TT a -> [a]
inApp Term
ptm [Name] -> [Name] -> [Name]
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' = ((Name, RigCount, Binder Term) -> Bool) -> Env -> Env
forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name
n, RigCount
_, Binder Term
_) -> Name
n Name -> [Name] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
argsDropped) Env
args
ElabD ()
forall aux. Elab' aux ()
attack
Name
cname' <- [Name] -> [Name] -> Name -> Elab' EState Name
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))
ElabD ()
forall aux. Elab' aux ()
solve
let newdef :: PDecl
newdef = FC -> FnOpts -> Name -> [PClause' PTerm] -> PDecl
forall t. FC -> FnOpts -> Name -> [PClause' t] -> PDecl' t
PClauses FC
fc [] Name
cname'
(FC
-> Name
-> PTerm
-> [(Name, (Bool, Binder Term))]
-> [(PTerm, PTerm)]
-> [PClause' PTerm]
caseBlock FC
fc Name
cname' PTerm
scr
(((Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term)))
-> Env -> [(Name, (Bool, Binder Term))]
forall a b. (a -> b) -> [a] -> [b]
map (PTerm
-> (Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term))
isScr PTerm
scr) (Env -> Env
forall a. [a] -> [a]
reverse Env
args')) [(PTerm, PTerm)]
opts)
(EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
e -> EState
e { case_decls = (cname', newdef) : case_decls e } )
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
tyn
ElabD ()
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 = RigCount -> t a -> [(a, RigCount, c)] -> RigCount
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 a -> t a -> Bool
forall a. Eq a => a -> t a -> Bool
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 [] = Maybe PTerm
forall a. Maybe a
Nothing
getScrType (PTerm
f : [PTerm]
os) = Maybe PTerm -> (PTerm -> Maybe PTerm) -> Maybe PTerm -> Maybe PTerm
forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([PTerm] -> Maybe PTerm
getScrType [PTerm]
os) PTerm -> Maybe PTerm
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 Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply (Term -> Term
forall n. TT n -> TT n
getRetTy Term
ty) of
(P NameType
_ Name
tyn Term
_, [Term]
args) ->
PTerm -> Maybe PTerm
forall a. a -> Maybe a
Just (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
tyn)
((PTerm -> PArg) -> [PTerm] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
map PTerm -> PArg
forall {t}. t -> PArg' t
pexp ((Term -> PTerm) -> [Term] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map (PTerm -> Term -> PTerm
forall a b. a -> b -> a
const PTerm
Placeholder) [Term]
args)))
(Term, [Term])
_ -> Maybe PTerm
forall a. Maybe a
Nothing
[(Name, Term)]
_ -> Maybe PTerm
forall a. Maybe a
Nothing
getAppType (PApp FC
_ PTerm
t [PArg]
as) = PTerm -> Maybe PTerm
getAppType PTerm
t
getAppType PTerm
_ = Maybe 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 [a] -> [a] -> [a]
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 [a] -> [a] -> [a]
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 [a] -> [a] -> [a]
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 a -> [(a, Bool)] -> Maybe Bool
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 Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Maybe (Binder Term)
Nothing -> (Name, Bool) -> StateT (ElabState aux) TC (Name, Bool)
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
False)
Just Binder Term
b ->
do Term
ty <- Raw -> Elab' aux Term
forall aux. Raw -> Elab' aux Term
get_type (Term -> Raw
forget (Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
b))
case Term
ty of
UType Universe
UniqueType -> (Name, Bool) -> StateT (ElabState aux) TC (Name, Bool)
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
True)
UType Universe
AllTypes -> (Name, Bool) -> StateT (ElabState aux) TC (Name, Bool)
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
True)
Term
_ -> (Name, Bool) -> StateT (ElabState aux) TC (Name, Bool)
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
False)
isNotLift :: Env -> Name -> Bool
isNotLift Env
env Name
n
= case Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Just Binder Term
ty ->
case Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply (Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
ty) of
(P NameType
_ Name
n Term
_, [Term]
_) -> Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
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 Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
unifyLog Bool
True
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
unifyLog Bool
False
elab' ElabCtxt
ina Maybe FC
fc (PQuasiquote PTerm
t Maybe PTerm
goalt)
= do
Term
finalTy <- Elab' EState Term
forall aux. Elab' aux Term
goal
(PTerm
t, [(Name, PTerm)]
unq) <- Int -> PTerm -> Elab' EState (PTerm, [(Name, PTerm)])
forall aux. Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])
extractUnquotes Int
0 PTerm
t
let unquoteNames :: [Name]
unquoteNames = ((Name, PTerm) -> Name) -> [(Name, PTerm)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PTerm) -> Name
forall a b. (a, b) -> a
fst [(Name, PTerm)]
unq
(Name -> ElabD ()) -> [Name] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
uqn -> Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
uqn (Term -> Raw
forget Term
finalTy)) [Name]
unquoteNames
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Ctxt TypeInfo
datatypes <- Elab' EState (Ctxt TypeInfo)
forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
Int
g_nextname <- Elab' EState Int
forall aux. Elab' aux Int
get_global_nextname
ElabD ()
forall aux. Elab' aux ()
saveState
(ProofState -> ProofState) -> ElabD ()
forall aux. (ProofState -> ProofState) -> Elab' aux ()
updatePS (ProofState -> ProofState -> ProofState
forall a b. a -> b -> a
const (ProofState -> ProofState -> ProofState)
-> (Term -> ProofState) -> Term -> ProofState -> ProofState
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 (Term -> ProofState -> ProofState)
-> Term -> ProofState -> ProofState
forall a b. (a -> b) -> a -> b
$
NameType -> Name -> Term -> Term
forall n. NameType -> n -> TT n -> TT n
P NameType
Ref (String -> Name
reflm String
"TT") Term
forall n. TT n
Erased)
(Name -> ElabD ()) -> [Name] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> do Name
ty <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"unqTy")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
ty Raw
RType
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
ty
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n (Name -> Raw
Var Name
ty)
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
n)
[Name]
unquoteNames
Name
qTy <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"qquoteTy")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
qTy Raw
RType
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
qTy
Name
qTm <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"qquoteTm")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
qTm (Name -> Raw
Var Name
qTy)
Name
nTm <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"quotedTerm")
Name -> RigCount -> Raw -> Raw -> ElabD ()
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 -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PTerm
gTy -> do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
qTy
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_qq = True }) Maybe FC
fc PTerm
gTy
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
qTm
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_qq = True }) Maybe FC
fc PTerm
t
ElabD ()
forall aux. Elab' aux ()
end_unify
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
EState [(Name, PDecl)]
_ [(Int, ElabD ())]
_ [RDeclInstructions]
_ Set (FC', OutputAnnotation)
hs [Name]
_ [(FC, Name)]
_ <- Elab' EState EState
forall aux. Elab' aux aux
getAux
ElabD ()
forall aux. Elab' aux ()
loadState
(EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
aux -> EState
aux { highlighting = hs })
let quoted :: Maybe Term
quoted = (Binder Term -> Term) -> Maybe (Binder Term) -> Maybe Term
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term -> Term
forall n. TT n -> TT n
explicitNames (Term -> Term) -> (Binder Term -> Term) -> Binder Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder Term -> Term
forall b. Binder b -> b
binderVal) (Maybe (Binder Term) -> Maybe Term)
-> Maybe (Binder Term) -> Maybe Term
forall a b. (a -> b) -> a -> b
$ Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
nTm Env
env
isRaw :: Bool
isRaw = case Term -> (Term, [Term])
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 Name -> Name -> Bool
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
(Term
q', Term
_, UCs
_) <- TC (Term, Term, UCs)
-> StateT (ElabState EState) TC (Term, Term, UCs)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term, UCs)
-> StateT (ElabState EState) TC (Term, Term, UCs))
-> TC (Term, Term, UCs)
-> StateT (ElabState EState) TC (Term, Term, UCs)
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, RigCount -> Term -> Binder Term
forall b. RigCount -> b -> Binder b
Lam RigCount
RigW Term
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
Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Raw -> ElabD ()) -> Raw -> ElabD ()
forall a b. (a -> b) -> a -> b
$ [Name] -> Raw -> Raw
reflectRawQuote [Name]
unquoteNames (Term -> Raw
forget Term
q')
else Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Raw -> ElabD ()) -> Raw -> ElabD ()
forall a b. (a -> b) -> a -> b
$ [Name] -> Term -> Raw
reflectTTQuote [Name]
unquoteNames Term
q'
ElabD ()
forall aux. Elab' aux ()
solve
Maybe Term
Nothing -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (String -> TC ()) -> String -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (String -> Err) -> String -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> ElabD ()) -> String -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String
"Broken elaboration of quasiquote"
((Name, PTerm) -> ElabD ()) -> [(Name, PTerm)] -> ElabD ()
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 Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_qq = False }) Maybe FC
fc PTerm
tm
elab' ElabCtxt
ina Maybe FC
fc (PUnquote PTerm
t) = String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
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 Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Raw -> ElabD ()) -> Raw -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n
ElabD ()
forall aux. Elab' aux ()
solve
elab' ElabCtxt
ina Maybe FC
fc (PQuoteName Name
n Bool
True FC
nfc) =
do Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
case Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Just Binder Term
_ -> do Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Raw -> ElabD ()) -> Raw -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n
ElabD ()
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 Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Raw -> ElabD ()) -> Raw -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n'
ElabD ()
forall aux. Elab' aux ()
solve
FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n' Maybe NameOutput
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
[] -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (Name -> TC ()) -> Name -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (Name -> Err) -> Name -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Err
forall t. Name -> Err' t
NoSuchVariable (Name -> ElabD ()) -> Name -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name
n
[(Name, Def)]
more -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> ([Name] -> TC ()) -> [Name] -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> ([Name] -> Err) -> [Name] -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Err
forall t. [Name] -> Err' t
CantResolveAlts ([Name] -> ElabD ()) -> [Name] -> ElabD ()
forall a b. (a -> b) -> a -> b
$ ((Name, Def) -> Name) -> [(Name, Def)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Def) -> Name
forall a b. (a, b) -> a
fst [(Name, Def)]
more
elab' ElabCtxt
ina Maybe FC
fc (PAs FC
_ Name
n PTerm
t) = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (String -> TC ()) -> String -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (String -> Err) -> String -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> ElabD ()) -> String -> ElabD ()
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) <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
h
~(Name
h' : [Name]
hs) <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
if Name
h Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
h' then Name -> ElabD ()
elabHidden Name
h
else Int -> ElabD () -> ElabD ()
delayElab Int
10 (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> ElabD ()
elabHidden Name
h
where
elabHidden :: Name -> ElabD ()
elabHidden Name
h = do [Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
h Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ do
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
h
ElabD ()
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 Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
ElabReflection LanguageExt -> [LanguageExt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ FC -> Err -> Err
forall t. FC -> Err' t -> Err' t
At FC
fc' (String -> Err
forall t. String -> Err' t
Msg String
"You must turn on the ElabReflection extension to use %runElab")
ElabD ()
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 <- Name -> Elab' EState Name
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)
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n Raw
scriptTy
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
Term
elabUnit <- Elab' EState Term
forall aux. Elab' aux Term
goal
ElabD ()
forall aux. Elab' aux ()
attack
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc') PTerm
tm
Term
script <- Elab' EState Term
forall aux. Elab' aux Term
get_guess
Term -> ElabD ()
fullyElaborated Term
script
ElabD ()
forall aux. Elab' aux ()
solve
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
(Term
scriptTm, Term
scriptTy) <- TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term))
-> TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] (Term -> Raw
forget Term
script)
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term -> TC ()
converts Context
ctxt Env
env Term
elabUnit Term
scriptTy
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
ElabInfo
-> IState -> FC -> Env -> Term -> [String] -> Elab' EState Term
runElabAction ElabInfo
info IState
ist (FC -> (FC -> FC) -> Maybe FC -> FC
forall b a. b -> (a -> b) -> Maybe a -> b
maybe FC
fc' FC -> FC
forall a. a -> a
id Maybe FC
fc) Env
env Term
script [String]
ns
ElabD ()
forall aux. Elab' aux ()
solve
elab' ElabCtxt
ina Maybe FC
fc (PConstSugar FC
constFC PTerm
tm) =
do ElabD ()
forall aux. Elab' aux ()
saveState
Name
n <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"cstI")
Name
n' <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"cstIhole")
Raw
g <- Term -> Raw
forget (Term -> Raw)
-> Elab' EState Term -> StateT (ElabState EState) TC Raw
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Elab' EState Term
forall aux. Elab' aux Term
goal
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n' Raw
g
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
n'
ElabD ()
forall aux. Elab' aux ()
attack
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n RigCount
RigW Raw
g (Name -> Raw
Var Name
n')
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n'
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
tm
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
let v :: Maybe Term
v = (Binder Term -> Term) -> Maybe (Binder Term) -> Maybe Term
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env (Term -> Term) -> (Binder Term -> Term) -> Binder Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
forall n. Eq n => TT n -> TT n
finalise (Term -> Term) -> (Binder Term -> Term) -> Binder Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder Term -> Term
forall b. Binder b -> b
binderVal)
(Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env)
ElabD ()
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 -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
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 Maybe NameOutput
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe String
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
_ = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x = String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ElabD ()) -> String -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String
"Unelaboratable syntactic form " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
showTmImpls PTerm
x
delayElab :: Int -> ElabD () -> ElabD ()
delayElab Int
pri ElabD ()
t
= (EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
e -> EState
e { delayed_elab = delayed_elab e ++ [(pri, 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 Name -> Name -> Bool
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' PTerm]
caseBlock FC
fc Name
n PTerm
scr [(Name, (Bool, Binder Term))]
env [(PTerm, PTerm)]
opts
= let args' :: [(Name, (Bool, Binder Term))]
args' = [(Name, (Bool, Binder Term))] -> [(Name, (Bool, Binder Term))]
forall {a} {b}. [(a, (Bool, b))] -> [(a, (Bool, b))]
findScr [(Name, (Bool, Binder Term))]
env
args :: [(PTerm, Bool)]
args = ((Name, Bool) -> (PTerm, Bool))
-> [(Name, Bool)] -> [(PTerm, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Bool) -> (PTerm, Bool)
forall {b}. (Name, b) -> (PTerm, b)
mkarg (((Name, (Bool, Binder Term)) -> (Name, Bool))
-> [(Name, (Bool, Binder Term))] -> [(Name, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (Name, (Bool, Binder Term)) -> (Name, Bool)
forall {a} {b} {b}. (a, (b, b)) -> (a, b)
getNmScr [(Name, (Bool, Binder Term))]
args') in
((PTerm, PTerm) -> PClause' PTerm)
-> [(PTerm, PTerm)] -> [PClause' PTerm]
forall a b. (a -> b) -> [a] -> [b]
map ([(PTerm, Bool)] -> (PTerm, PTerm) -> PClause' PTerm
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)) (a, (Bool, b)) -> [(a, (Bool, b))] -> [(a, (Bool, b))]
forall a. a -> [a] -> [a]
: a -> [(a, (Bool, b))] -> [(a, (Bool, b))]
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 (a, (Bool, b)) -> [(a, (Bool, b))] -> [(a, (Bool, b))]
forall a. a -> [a] -> [a]
: [(a, (Bool, b))] -> [(a, (Bool, b))]
findScr [(a, (Bool, b))]
xs
findScr [] = String -> [(a, (Bool, b))]
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 (t, b) -> [(t, b)] -> [(t, b)]
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' PTerm
mkClause [(PTerm, Bool)]
args (PTerm
l, PTerm
r)
= let args' :: [(PTerm, Bool)]
args' = ((PTerm, Bool) -> (PTerm, Bool))
-> [(PTerm, Bool)] -> [(PTerm, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> (PTerm, Bool) -> (PTerm, Bool)
forall {t :: * -> *} {b}.
Foldable t =>
t Name -> (PTerm, b) -> (PTerm, b)
shadowed (PTerm -> [Name]
allNamesIn PTerm
l)) [(PTerm, Bool)]
args
args'' :: [(PTerm, Bool)]
args'' = ((PTerm, Bool) -> (PTerm, Bool))
-> [(PTerm, Bool)] -> [(PTerm, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> (PTerm, Bool) -> (PTerm, Bool)
forall {t :: * -> *} {b}.
Foldable t =>
t Name -> (PTerm, b) -> (PTerm, b)
implicitable (PTerm -> [Name]
allNamesIn PTerm
r [Name] -> [Name] -> [Name]
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)
(((PTerm, Bool) -> PArg) -> [(PTerm, Bool)] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
map (PTerm -> (PTerm, Bool) -> PArg
forall {t}. t -> (t, Bool) -> PArg' t
mkLHSarg PTerm
l) [(PTerm, Bool)]
args'') in
FC
-> Name -> PTerm -> [PTerm] -> PTerm -> [PDecl] -> PClause' PTerm
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) = t -> PArg' t
forall {t}. t -> PArg' t
pexp t
l
mkLHSarg t
l (t
tm, Bool
False) = t -> PArg' t
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 Name -> t Name -> Bool
forall a. Eq a => a -> t a -> Bool
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 Name -> t Name -> Bool
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 <- Elab' EState EState
forall aux. Elab' aux aux
getAux
case Name -> [(Name, PDecl)] -> Maybe PDecl
forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n (EState -> [(Name, PDecl)]
case_decls EState
estate) of
Maybe PDecl
Nothing -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Just PDecl
_ -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (Err -> TC ()) -> Err -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> ElabD ()) -> Err -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> Err
forall t. Name -> Err' t
ElabScriptStaging Name
n
fullyElaborated (Bind Name
n Binder Term
b Term
body) = Term -> ElabD ()
fullyElaborated Term
body ElabD () -> ElabD () -> ElabD ()
forall a b.
StateT (ElabState EState) TC a
-> StateT (ElabState EState) TC b -> StateT (ElabState EState) TC b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Binder Term -> (Term -> ElabD ()) -> ElabD ()
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 ElabD () -> ElabD () -> ElabD ()
forall a b.
StateT (ElabState EState) TC a
-> StateT (ElabState EState) TC b -> StateT (ElabState EState) TC b
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
_ = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
insertLazy :: ElabCtxt -> PTerm -> ElabD PTerm
insertLazy :: ElabCtxt -> PTerm -> StateT (ElabState EState) TC PTerm
insertLazy ElabCtxt
ina t :: PTerm
t@(PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg]
_) | Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delay" = PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Force" = PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertLazy ElabCtxt
ina (PCoerced PTerm
t) = PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
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) = PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertLazy ElabCtxt
ina PTerm
t =
do Term
ty <- Elab' EState Term
forall aux. Elab' aux Term
goal
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
let (Term
tyh, [Term]
_) = Term -> (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
ty)
let tries :: [PTerm]
tries = [Env -> PTerm -> PTerm
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 Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed"
-> PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [] PAltType
FirstSuccess [PTerm]
tries)
Term
_ -> PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
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 ((PTerm -> PTerm) -> [PTerm] -> [PTerm]
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 (((Name, b, c) -> Name) -> [(Name, b, c)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, b, c) -> Name
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"))
[PTerm -> PArg
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] <- Name -> Ctxt FnOpts -> [FnOpts]
forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
n (IState -> Ctxt FnOpts
idris_flags IState
ist)
= FnOpt
NoImplicit FnOpt -> FnOpts -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts
notImplicitable (PAlternative [(Name, Name)]
_ PAltType
_ [PTerm]
as) = (PTerm -> Bool) -> [PTerm] -> Bool
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 <- Elab' aux 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 <- Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
f Env
env ->
do let a :: Int
a = [(Name, Term)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Term -> [(Name, Term)]
forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env (Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
aty)))
PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (FC -> Int -> PTerm -> [PArg] -> PTerm
mkPApp FC
fc Int
a PTerm
ftm [PArg]
args)
PTerm
_ -> PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
tm
expandToArity PTerm
t = PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
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 [PArg] -> [PArg] -> [PArg]
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 [] = (Maybe PArg
forall a. Maybe a
Nothing, [])
findImplicit Name
n (i :: PArg
i@(PImp Int
_ Bool
_ [ArgOpt]
_ Name
n' PTerm
_) : [PArg]
args)
| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' = (PArg -> Maybe PArg
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 Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' = (PArg -> Maybe PArg
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 PArg -> [PArg] -> [PArg]
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 (PArg -> ElabD ()) -> [PArg] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ([Name] -> PArg -> ElabD ()
forall {t :: * -> *} {t :: (* -> *) -> * -> *} {t}.
(Foldable t, Monad (t TC), MonadTrans t) =>
t Name -> PArg' t -> t TC ()
checkKnownImplicit (((Name, Term) -> Name) -> [(Name, Term)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Term) -> Name
forall a b. (a, b) -> a
fst (Term -> [(Name, Term)]
forall n. TT n -> [(n, TT n)]
getArgTys Term
ty) [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ [Name]
knowns)) [PArg]
xs
Term -> [PArg] -> ElabD [PArg]
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)
= ([PArg] -> [PArg]) -> m [PArg] -> m [PArg]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PArg
arg PArg -> [PArg] -> [PArg]
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)
= ([PArg] -> [PArg]) -> m [PArg] -> m [PArg]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp Name
n (FC -> PTerm
PResolveTC FC
fc) Bool
True PArg -> [PArg] -> [PArg]
forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs)
| Bool -> Bool
not (ImplicitInfo -> Bool
toplevel_imp ImplicitInfo
i)
= ([PArg] -> [PArg]) -> m [PArg] -> m [PArg]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (Name -> PTerm -> Bool -> PArg
forall {t}. Name -> t -> Bool -> PArg' t
pimp Name
n PTerm
Placeholder Bool
True PArg -> [PArg] -> [PArg]
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)
= ([PArg] -> [PArg]) -> m [PArg] -> m [PArg]
forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PArg
x PArg -> [PArg] -> [PArg]
forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs)
doInsert Term
ty [PArg]
xs = [PArg] -> m [PArg]
forall a. a -> m a
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{})
| PArg' t -> Name
forall t. PArg' t -> Name
pname PArg' t
imp Name -> t Name -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Name
ns = () -> t TC ()
forall a. a -> t TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
| Bool
otherwise = TC () -> t TC ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> t TC ()) -> TC () -> t TC ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ FC -> Err -> Err
forall t. FC -> Err' t -> Err' t
At FC
fc (Err -> Err) -> Err -> Err
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Err
forall t. Name -> Name -> Err' t
UnknownImplicit (PArg' t -> Name
forall t. PArg' t -> Name
pname PArg' t
imp) Name
f
checkKnownImplicit t Name
ns PArg' t
_ = () -> t TC ()
forall a. a -> t TC a
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 <- Elab' aux Term
forall aux. Elab' aux Term
goal
Env
env <- Elab' aux 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
Term -> PTerm -> StateT (ElabState aux) TC PTerm
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 <- Name -> Elab' aux Name
forall aux. Name -> Elab' aux Name
unique_hole Name
n
PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
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 = PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
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)]
_) = PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertCoerce p
ina PTerm
t | PTerm -> Bool
notImplicitable PTerm
t = PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
insertCoerce p
ina PTerm
t =
do Term
ty <- Elab' aux Term
forall aux. Elab' aux Term
goal
Env
env <- Elab' aux 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 PTerm -> [PTerm] -> [PTerm]
forall a. a -> [a] -> [a]
: (Name -> PTerm) -> [Name] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map (Env -> PTerm -> Name -> PTerm
forall {b} {c}. [(Name, b, c)] -> PTerm -> Name -> PTerm
mkCoerce Env
env PTerm
t) [Name]
cs)
PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
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 ((PTerm -> PTerm) -> [PTerm] -> [PTerm]
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 = FC -> (FC -> FC) -> Maybe FC -> FC
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> FC
fileFC String
"Coercion") FC -> FC
forall a. a -> a
id (PTerm -> Maybe FC
highestFC PTerm
t) in
IState -> [Name] -> PTerm -> PTerm
addImplBound IState
ist (((Name, b, c) -> Name) -> [(Name, b, c)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, b, c) -> Name
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) [PTerm -> PArg
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 <- Raw -> Elab' EState Term
forall aux. Raw -> Elab' aux Term
get_type (Name -> Raw
Var Name
n)
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState 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 [PArg] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PArg]
a'
then FC -> ElabD () -> ElabD ()
forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
do Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
n) []
OutputAnnotation
hilite <- Name -> ElabD OutputAnnotation
findHighlight Name
n
ElabD ()
forall aux. Elab' aux ()
solve
((FC, OutputAnnotation) -> ElabD ())
-> [(FC, OutputAnnotation)] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ ((FC -> OutputAnnotation -> ElabD ())
-> (FC, OutputAnnotation) -> ElabD ()
forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FC -> OutputAnnotation -> ElabD ()
highlightSource) ([(FC, OutputAnnotation)] -> ElabD ())
-> [(FC, OutputAnnotation)] -> ElabD ()
forall a b. (a -> b) -> a -> b
$
(FC
fc, OutputAnnotation
hilite) (FC, OutputAnnotation)
-> [(FC, OutputAnnotation)] -> [(FC, OutputAnnotation)]
forall a. a -> [a] -> [a]
: (FC -> (FC, OutputAnnotation)) -> [FC] -> [(FC, OutputAnnotation)]
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]
_ = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
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 <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
if Name
holeName Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs then
do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
holeName
case PTerm
t of
PTerm
Placeholder -> do Name -> ElabD ()
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
FC -> Name -> Name -> ElabD ()
forall aux. FC -> Name -> Name -> Elab' aux ()
now_elaborating FC
fc Name
f Name
argName
Name -> Name -> ElabD () -> ElabD ()
forall {aux} {b}.
Name
-> Name
-> StateT (ElabState aux) TC b
-> StateT (ElabState aux) TC b
wrapErr Name
f Name
argName (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ do
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Term
tm <- Elab' EState Term
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 Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
holeName;
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
Bool
poly <- Elab' EState Bool
goal_polymorphic
Bool
ulog <- Elab' EState Bool
forall aux. Elab' aux Bool
getUnifyLog
Bool -> String -> ElabD () -> ElabD ()
forall {a}. Bool -> String -> a -> a
traceWhen Bool
ulog (String
"Elaborating argument " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Name, Name, Term) -> String
forall a. Show a => a -> String
show (Name
argName, Name
holeName, Term
g)) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab (ElabCtxt
ina { e_nomatching = unm && poly }) (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
t
[Bool] -> StateT (ElabState EState) TC [Bool]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return [Bool]
failed
Name -> Name -> ElabD ()
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 <- StateT (ElabState aux) TC (ElabState aux)
forall s (m :: * -> *). MonadState s m => m s
get
[(FC, Name, Name)]
while <- Elab' aux [(FC, Name, Name)]
forall aux. Elab' aux [(FC, Name, Name)]
elaborating_app
let while' :: [(Name, Name)]
while' = ((FC, Name, Name) -> (Name, Name))
-> [(FC, Name, Name)] -> [(Name, Name)]
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 StateT (ElabState aux) TC b
-> ElabState aux -> TC (b, ElabState aux)
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) -> (b, ElabState aux) -> StateT (ElabState aux) TC (b, ElabState aux)
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
res, ElabState aux
newState)
Error Err
e -> do Name -> Name -> Elab' aux ()
forall aux. Name -> Name -> Elab' aux ()
done_elaborating_arg Name
f Name
argName
TC (b, ElabState aux)
-> StateT (ElabState aux) TC (b, ElabState aux)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState aux) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Err -> TC (b, ElabState aux)
forall a. Err -> TC a
tfail ([(Name, Name)] -> Err -> Err
elaboratingArgErr [(Name, Name)]
while' Err
e))
ElabState aux -> Elab' aux ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ElabState aux
newState
b -> StateT (ElabState aux) TC b
forall a. a -> StateT (ElabState aux) TC a
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
_ [] =
String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ElabD ()) -> String -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String
"Can't elaborate these args: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
arg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
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
= (EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
est -> EState
est { auto_binds = n : auto_binds est })
addAutoBind Plicity
_ Name
_ = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
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 ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl
= do Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
EState
est <- Elab' EState EState
forall aux. Elab' aux aux
getAux
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` EState -> [Name]
auto_binds EState
est) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
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 = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
where
tryUnify :: Env -> [(Name, Term)] -> ElabD ()
tryUnify Env
env [] = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
tryUnify Env
env ((Name
nm, Term
ty) : [(Name, Term)]
ts)
= do [Name]
inj <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_inj
[Name]
hs <- Elab' EState [Name]
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, Maybe Provenance
forall a. Maybe a
Nothing) (Term
goal, Maybe Provenance
forall a. Maybe a
Nothing)
[Name]
inj [Name]
hs [] [] of
OK ([(Name, Term)], Fails)
_ ->
(EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
est -> EState
est { implicit_warnings =
(fc, nm) : implicit_warnings est })
TC ([(Name, Term)], Fails)
_ -> Env -> [(Name, Term)] -> ElabD ()
tryUnify Env
env [(Name, Term)]
ts
pruneAlt :: [PTerm] -> [PTerm]
pruneAlt :: [PTerm] -> [PTerm]
pruneAlt [PTerm]
xs = (PTerm -> PTerm) -> [PTerm] -> [PTerm]
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) ((PArg -> PArg) -> [PArg] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PTerm -> PTerm) -> PArg -> PArg
forall a b. (a -> b) -> PArg' a -> PArg' b
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' = (PTerm -> PTerm) -> [PTerm] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> PTerm -> PTerm
choose Name
f) [PTerm]
as
fs :: [PTerm]
fs = (PTerm -> Bool) -> [PTerm] -> [PTerm]
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') ((PArg -> PArg) -> [PArg] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap ((PTerm -> PTerm) -> PArg -> PArg
forall a b. (a -> b) -> PArg' a -> PArg' b
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 Name -> Name -> Bool
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
case Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
Just Binder Term
_ -> OutputAnnotation -> ElabD OutputAnnotation
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputAnnotation -> ElabD OutputAnnotation)
-> OutputAnnotation -> ElabD OutputAnnotation
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
_ -> OutputAnnotation -> ElabD OutputAnnotation
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputAnnotation -> ElabD OutputAnnotation)
-> OutputAnnotation -> ElabD OutputAnnotation
forall a b. (a -> b) -> a -> b
$ Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n Maybe NameOutput
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
Maybe Term
Nothing -> TC OutputAnnotation -> ElabD OutputAnnotation
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC OutputAnnotation -> ElabD OutputAnnotation)
-> (String -> TC OutputAnnotation)
-> String
-> ElabD OutputAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC OutputAnnotation
forall a. Err -> TC a
tfail (Err -> TC OutputAnnotation)
-> (String -> Err) -> String -> TC OutputAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
InternalMsg (String -> ElabD OutputAnnotation)
-> String -> ElabD OutputAnnotation
forall a b. (a -> b) -> a -> b
$
String
"Can't find name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
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 <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not ([Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
hs)) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ do
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
(Err -> Bool) -> ElabD () -> ElabD () -> ElabD ()
forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError Err -> Bool
forall {t}. Err' t -> Bool
cantsolve (Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ do
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
Bool
isg <- Elab' EState Bool
forall aux. Elab' aux Bool
is_guess
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isg) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
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 Maybe Name
forall a. Maybe a
Nothing Name
fn [] [])
(TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
Error ([FailContext] -> Err -> Err
forall {t}. [FailContext] -> Err' t -> Err' t
addLoc [FailContext]
failc
(Term -> [(Name, Term)] -> Err
forall t. t -> [(Name, t)] -> Err' t
CantSolveGoal Term
g (((Name, RigCount, Binder Term) -> (Name, Term))
-> Env -> [(Name, Term)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
b)) Env
env))))
() -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
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
= FC -> Err' t -> Err' t
forall t. FC -> Err' t -> Err' t
At FC
fc (Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
forall t. Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
ElaboratingArg Name
f Name
x
((FailContext -> (Name, Name)) -> [FailContext] -> [(Name, Name)]
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 <- Elab' EState [(Name, ([FailContext], [Name]))]
forall aux. Elab' aux [(Name, ([FailContext], [Name]))]
get_autos
((Name, [FailContext]) -> ElabD ())
-> [(Name, [FailContext])] -> ElabD ()
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) (((Name, ([FailContext], [Name])) -> (Name, [FailContext]))
-> [(Name, ([FailContext], [Name]))] -> [(Name, [FailContext])]
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 ElabD ()
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 <- StateT
[(Name, (Int, Maybe Name, Term, [Name]))]
Identity
[(Name, (Int, Maybe Name, Term, [Name]))]
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
Bool
-> StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity ()
-> StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ((Name, (Int, Maybe Name, Term, [Name])) -> Name)
-> [(Name, (Int, Maybe Name, Term, [Name]))] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, (Int, Maybe Name, Term, [Name])) -> Name
forall a b. (a, b) -> a
fst [(Name, (Int, Maybe Name, Term, [Name]))]
ds)) (StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity ()
-> StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity ())
-> StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity ()
-> StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity ()
forall a b. (a -> b) -> a -> b
$ [(Name, (Int, Maybe Name, Term, [Name]))]
-> StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ([(Name, (Int, Maybe Name, Term, [Name]))]
ds [(Name, (Int, Maybe Name, Term, [Name]))]
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [(Name, (Int, Maybe Name, Term, [Name]))]
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) (Name, Binder Term)
-> [(Name, Binder Term)] -> [(Name, Binder Term)]
forall a. a -> [a] -> [a]
: [(Name, Binder Term)]
env) Term
t
Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
forall a.
a -> StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Binder Term -> Term -> Term
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) = (Term -> Term -> Binder Term)
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
-> StateT
[(Name, (Int, Maybe Name, Term, [Name]))] Identity (Binder Term)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (RigCount -> Term -> Term -> Binder Term
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) = (Term -> Term -> Binder Term)
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
-> StateT
[(Name, (Int, Maybe Name, Term, [Name]))] Identity (Binder Term)
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 Term -> Term -> Binder Term
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 (Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
b)
Binder Term
-> StateT
[(Name, (Int, Maybe Name, Term, [Name]))] Identity (Binder Term)
forall a.
a -> StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity a
forall (m :: * -> *) a. Monad m => a -> m a
return (Binder Term
b { binderTy = ty' })
cd [(Name, Binder Term)]
env (App AppStatus Name
s Term
f Term
a) = (Term -> Term -> Term)
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (AppStatus Name -> Term -> Term -> Term
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 = Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
forall a.
a -> StateT [(Name, (Int, Maybe Name, Term, [Name]))] Identity a
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] -> Elab' EState Term
runElabAction ElabInfo
info IState
ist FC
fc Env
env Term
tm [String]
ns = do Term
tm' <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
tm
Term -> Elab' EState Term
runTacTm Term
tm'
where
eval :: Term -> StateT (ElabState aux) TC Term
eval Term
tm = do Context
ctxt <- Elab' aux Context
forall aux. Elab' aux Context
get_context
Term -> StateT (ElabState aux) TC Term
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> StateT (ElabState aux) TC Term)
-> Term -> StateT (ElabState aux) TC Term
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env (Term -> Term
forall n. Eq n => TT n -> TT n
finalise Term
tm)
returnUnit :: Elab' EState Term
returnUnit = Term -> Elab' EState Term
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Term -> Elab' EState Term) -> Term -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ NameType -> Name -> Term -> Term
forall n. NameType -> n -> TT n -> TT n
P (Int -> Int -> Bool -> NameType
DCon Int
0 Int
0 Bool
False) Name
unitCon (NameType -> Name -> Term -> Term
forall n. NameType -> n -> TT n -> TT n
P (Int -> Int -> NameType
TCon Int
0 Int
0) Name
unitTy Term
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) (Name, Term) -> [(Name, Term)] -> [(Name, Term)]
forall a. a -> [a] -> [a]
: [(Name, Term)]
ns) (Term -> Term -> Term
forall n. TT n -> TT n -> TT n
instantiate (NameType -> Name -> Term -> Term
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) = (([(Name, Term)], Term) -> [(Name, Term)]
forall a b. (a, b) -> a
fst ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs), ([(Name, Term)], Term) -> Term
forall a b. (a, b) -> b
snd ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs), ([(Name, Term)], Term) -> Term
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 <- StateT (ElabState EState) TC (ElabState EState)
forall s (m :: * -> *). MonadState s m => m s
get
case ElabD a -> ElabState EState -> TC (a, ElabState EState)
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') -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Err -> TC ()
forall a. Err -> TC a
tfail Err
orErr)
Error Err
e -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
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
_)] -> NameType -> Name -> Term -> Term
forall n. NameType -> n -> TT n -> TT n
P NameType
nt Name
n' Term
forall n. TT n
Erased
[(Name, Def)]
_ -> NameType -> Name -> Term -> Term
forall n. NameType -> n -> TT n -> TT n
P NameType
Ref Name
n Term
forall n. TT n
Erased
fakeTT (RBind Name
n Binder Raw
b Raw
body) = Name -> Binder Term -> Term -> Term
forall n. n -> Binder (TT n) -> TT n -> TT n
Bind Name
n ((Raw -> Term) -> Binder Raw -> Binder Term
forall a b. (a -> b) -> Binder a -> Binder b
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) = AppStatus Name -> Term -> Term -> Term
forall n. AppStatus n -> TT n -> TT n -> TT n
App AppStatus Name
forall n. AppStatus n
Complete (Raw -> Term
fakeTT Raw
f) (Raw -> Term
fakeTT Raw
a)
fakeTT Raw
RType = UExp -> Term
forall n. UExp -> TT n
TType (String -> Int -> UExp
UVar [] (-Int
1))
fakeTT (RUType Universe
u) = Universe -> Term
forall n. Universe -> TT n
UType Universe
u
fakeTT (RConstant Const
c) = Const -> Term
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Term
ty <- Elab' EState Term
-> (Term -> Elab' EState Term) -> Maybe Term -> Elab' EState Term
forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> Elab' EState Term
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no type decl") Term -> Elab' EState Term
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Maybe Term -> Elab' EState Term)
-> Maybe Term -> Elab' EState Term
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' <- [RFunClause Raw]
-> (RFunClause Raw
-> StateT (ElabState EState) TC (Either Term (Term, Term)))
-> StateT (ElabState EState) TC [Either Term (Term, Term)]
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) <- TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term))
-> TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
lhs
(Term
rhs', Term
rty) <- TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term))
-> TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
rhs
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term -> TC ()
converts Context
ctxt [] Term
lty Term
rty
Either Term (Term, Term)
-> StateT (ElabState EState) TC (Either Term (Term, Term))
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Term (Term, Term)
-> StateT (ElabState EState) TC (Either Term (Term, Term)))
-> Either Term (Term, Term)
-> StateT (ElabState EState) TC (Either Term (Term, Term))
forall a b. (a -> b) -> a -> b
$ (Term, Term) -> Either Term (Term, Term)
forall a b. b -> Either a b
Right (Term
lhs', Term
rhs')
RMkImpossibleClause Raw
lhs ->
do Err -> StateT (ElabState EState) TC (Term, Term) -> ElabD ()
forall a. Err -> ElabD a -> ElabD ()
requireError (String -> Err
forall t. String -> Err' t
Msg String
"Not an impossible case") (StateT (ElabState EState) TC (Term, Term) -> ElabD ())
-> (TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term))
-> TC (Term, Term)
-> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> ElabD ()) -> TC (Term, Term) -> ElabD ()
forall a b. (a -> b) -> a -> b
$
Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
lhs
Either Term (Term, Term)
-> StateT (ElabState EState) TC (Either Term (Term, Term))
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Either Term (Term, Term)
-> StateT (ElabState EState) TC (Either Term (Term, Term)))
-> Either Term (Term, Term)
-> StateT (ElabState EState) TC (Either Term (Term, Term))
forall a b. (a -> b) -> a -> b
$ Term -> Either Term (Term, Term)
forall a b. a -> Either a b
Left (Raw -> Term
fakeTT Raw
lhs))
let clauses'' :: [([(Name, Term)], Term, Term)]
clauses'' = (Either Term (Term, Term) -> ([(Name, Term)], Term, Term))
-> [Either Term (Term, Term)] -> [([(Name, Term)], Term, Term)]
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', Term
forall n. TT n
Impossible))
[Either Term (Term, Term)]
clauses'
let clauses''' :: [([Name], Term, Term)]
clauses''' = (([(Name, Term)], Term, Term) -> ([Name], Term, Term))
-> [([(Name, Term)], Term, Term)] -> [([Name], Term, Term)]
forall a b. (a -> b) -> [a] -> [b]
map (\([(Name, Term)]
ns, Term
lhs, Term
rhs) -> (((Name, Term) -> Name) -> [(Name, Term)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Term) -> Name
forall a b. (a, b) -> a
fst [(Name, Term)]
ns, Term
lhs, Term
rhs)) [([(Name, Term)], Term, Term)]
clauses''
let argtys :: [(Term, Bool)]
argtys = (Term -> (Term, Bool)) -> [Term] -> [(Term, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map (\Term
x -> (Term
x, Term -> Context -> Bool
isCanonical Term
x Context
ctxt))
(((Name, Term) -> Term) -> [(Name, Term)] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Term) -> Term
forall a b. (a, b) -> b
snd (Term -> [(Name, Term)]
forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise Context
ctxt [] Term
ty)))
Context
ctxt'<- TC Context -> Elab' EState Context
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Context -> Elab' EState Context)
-> TC Context -> Elab' EState Context
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 ([Int] -> ErasureInfo
forall a b. a -> b -> a
const [])
CaseInfo
info Bool
False (Term -> SC
forall t. t -> SC' t
STerm Term
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
Context -> ElabD ()
forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
(EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux ((EState -> EState) -> ElabD ()) -> (EState -> EState) -> ElabD ()
forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls = RClausesInstrs n clauses'' : new_tyDecls e}
() -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
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 <- Elab' aux Context
forall aux. Elab' aux Context
get_context
(Term
val, Term
ty) <- TC (Term, Term) -> Elab' aux (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState aux) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> Elab' aux (Term, Term))
-> TC (Term, Term) -> Elab' aux (Term, Term)
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
tm
(Term, Term) -> Elab' aux (Term, Term)
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ((Term, Term) -> Elab' aux (Term, Term))
-> (Term, Term) -> Elab' aux (Term, Term)
forall a b. (a -> b) -> a -> b
$! (Term -> Term
forall n. Eq n => TT n -> TT n
finalise Term
val, Term -> Term
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) (RigCount -> Maybe ImplicitInfo -> Raw -> Raw -> Binder Raw
forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW Maybe ImplicitInfo
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 [] (Term -> Term
forall n. Eq n => TT n -> TT n
finalise Term
ty) of
UType Universe
_ -> () -> t TC ()
forall a. a -> t TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
TType UExp
_ -> () -> t TC ()
forall a. a -> t TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Term
ty' -> TC () -> t TC ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> t TC ()) -> (String -> TC ()) -> String -> t TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (String -> Err) -> String -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
InternalMsg (String -> t TC ()) -> String -> t TC ()
forall a b. (a -> b) -> a -> b
$
a -> String
forall a. Show a => a -> String
show a
tm String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is not a type: it's " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
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
_ -> TC () -> t TC ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> t TC ()) -> (String -> TC ()) -> String -> t TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (String -> Err) -> String -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
InternalMsg (String -> t TC ()) -> String -> t TC ()
forall a b. (a -> b) -> a -> b
$
Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is already defined."
Maybe Def
Nothing -> () -> t TC ()
forall a. a -> t TC a
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Name -> ElabD ()
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Name -> t TC ()
notQualified Name
cn
let qcn :: Name
qcn = Name -> Name
qualify Name
cn
Context -> Name -> ElabD ()
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Context -> Name -> t TC ()
mustNotBeDefined Context
ctxt Name
qcn
let cty :: Raw
cty = (RFunArg -> Raw -> Raw) -> Raw -> [RFunArg] -> Raw
forall a b. (a -> b -> b) -> b -> [a] -> b
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) <- TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term))
-> TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
cty
Context -> Term -> Term -> ElabD ()
forall {t :: (* -> *) -> * -> *} {a}.
(Monad (t TC), MonadTrans t, Show a) =>
Context -> a -> Term -> t TC ()
mustBeType Context
ctxt Term
checkedTy Term
ctyTy
case Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply (Term -> Term
getRetTy (Context -> Env -> Term -> Term
normaliseAll Context
ctxt [] (Term -> Term
forall n. Eq n => TT n -> TT n
finalise Term
checkedTy))) of
(P NameType
_ Name
n Term
_, [Term]
_) | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
tyn -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Term, [Term])
t -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (String -> TC ()) -> String -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (String -> Err) -> String -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> ElabD ()) -> String -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String
"The constructor " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
cn String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" doesn't construct " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
tyn String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" (return type is " String -> String -> String
forall a. [a] -> [a] -> [a]
++ (Term, [Term]) -> String
forall a. Show a => a -> String
show (Term, [Term])
t String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
")"
Context -> ElabD ()
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 = (RFunArg -> PArg) -> [RFunArg] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> PArg
rFunArgToPArg [RFunArg]
args
(Name, [PArg], Term) -> ElabD (Name, [PArg], Term)
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
qcn, [PArg]
impls, Term
checkedTy)
where
notQualified :: Name -> t TC ()
notQualified (NS Name
_ [Text]
_) = TC () -> t TC ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> t TC ()) -> (String -> TC ()) -> String -> t TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (String -> Err) -> String -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> t TC ()) -> String -> t TC ()
forall a b. (a -> b) -> a -> b
$ String
"Constructor names may not be qualified"
notQualified Name
_ = () -> t TC ()
forall a. a -> t TC a
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 = TC a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC a -> StateT (ElabState EState) TC a)
-> (Err -> TC a) -> Err -> StateT (ElabState EState) TC a
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC a
forall a. Err -> TC a
tfail (Err -> StateT (ElabState EState) TC a)
-> Err -> StateT (ElabState EState) TC a
forall a b. (a -> b) -> a -> b
$ Term -> Err
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 | [Term] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l = [Term] -> ElabD [Term]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return [Term]
args
| Bool
otherwise = Term -> ElabD [Term]
forall a. Term -> ElabD a
elabScriptStuck Term
t
runTacTm :: Term -> ElabD Term
runTacTm :: Term -> Elab' EState Term
runTacTm tac :: Term
tac@(Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply -> (P NameType
_ Name
n Term
_, [Term]
args))
| Name
n Name -> Name -> Bool
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
ElabD ()
forall aux. Elab' aux ()
solve
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
case [Name]
hs of
(Name
h : [Name]
_) -> do Term
t <- Elab' EState Term
forall aux. Elab' aux Term
goal
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
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)
[] -> TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$
String
"Elaboration is complete. There are no goals."
| Name
n Name -> Name -> Bool
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 <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
mkList (Name -> Raw
Var (Name -> Raw) -> Name -> Raw
forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName") ((Name -> Raw) -> [Name] -> [Raw]
forall a b. (a -> b) -> [a] -> [b]
map Name -> Raw
reflectName [Name]
hs)
| Name
n Name -> Name -> Bool
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 <- Elab' EState Term
forall aux. Elab' aux Term
get_guess
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ Term -> Raw
reflect Term
g
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
name
Context
ctxt <- Elab' EState Context
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 ]
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
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 Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
name
Ctxt TypeInfo
datatypes <- Elab' EState (Ctxt TypeInfo)
forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Name -> Raw
Var (String -> Name
tacN String
"Datatype"))
((RDatatype -> Raw) -> [RDatatype] -> [Raw]
forall a b. (a -> b) -> [a] -> [b]
map RDatatype -> Raw
reflectDatatype (IState -> Name -> [RDatatype]
buildDatatypes IState
ist Name
n'))
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
name
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Raw -> Raw -> Raw
RApp (Name -> Raw
Var (Name -> Raw) -> Name -> Raw
forall a b. (a -> b) -> a -> b
$ String -> Name
tacN String
"FunDefn") (Name -> Raw
Var (Name -> Raw) -> Name -> Raw
forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT"))
((RFunDefn Term -> Raw) -> [RFunDefn Term] -> [Raw]
forall a b. (a -> b) -> [a] -> [b]
map RFunDefn Term -> Raw
reflectFunDefn (IState -> Name -> [RFunDefn Term]
buildFunDefns IState
ist Name
n'))
| Name
n Name -> Name -> Bool
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 -> Elab' EState 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")) ((RFunArg -> Raw) -> [RFunArg] -> [Raw]
forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> Raw
reflectArg [RFunArg]
args), Raw -> Raw
reflectRaw Raw
res)
| (Name
fn, [PArg]
pargs) <- Name -> Ctxt [PArg] -> [(Name, [PArg])]
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 (Raw -> ([RFunArg], Raw))
-> (Term -> Raw) -> Term -> ([RFunArg], Raw)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Raw
forget (Term -> ([RFunArg], Raw)) -> [Term] -> [([RFunArg], Raw)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
Maybe Term -> [Term]
forall a. Maybe a -> [a]
maybeToList (Name -> Context -> Maybe Term
lookupTyExact Name
fn (IState -> Context
tt_ctxt IState
ist))
]
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
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 Name -> Name -> Bool
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
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$
FC -> Raw
reflectFC FC
fc
| Name
n Name -> Name -> Bool
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
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Const -> Raw
RConstant Const
StrType) ((String -> Raw) -> [String] -> [Raw]
forall a b. (a -> b) -> [a] -> [b]
map (Const -> Raw
RConstant (Const -> Raw) -> (String -> Const) -> String -> Raw
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Const
Str) [String]
ns)
| Name
n Name -> Name -> Bool
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 <- Elab' EState Env
forall aux. Elab' aux Env
get_env
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ Env -> Raw
reflectEnv Env
env
| Name
n Name -> Name -> Bool
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' <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
errs
[ErrorReportPart]
parts <- Term -> ElabD [ErrorReportPart]
reifyReportParts Term
errs'
TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (Err -> TC Term) -> Err -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> Elab' EState Term) -> Err -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ [[ErrorReportPart]] -> Err -> Err
forall t. [[ErrorReportPart]] -> Err' t -> Err' t
ReflectionError [[ErrorReportPart]
parts] (String -> Err
forall t. String -> Err' t
Msg String
"")
| Name
n Name -> Name -> Bool
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
Term -> Elab' EState Term
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
tm
| Name
n Name -> Name -> Bool
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' <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
first
Term
res <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval (Term -> Elab' EState Term)
-> Elab' EState Term -> Elab' EState Term
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> Elab' EState Term
runTacTm Term
first'
Term
next <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval (AppStatus Name -> Term -> Term -> Term
forall n. AppStatus n -> TT n -> TT n -> TT n
App AppStatus Name
forall n. AppStatus n
Complete Term
andThen Term
res)
Term -> Elab' EState Term
runTacTm Term
next
| Name
n Name -> Name -> Bool
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' <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
first
Term
alt' <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
alt
Elab' EState Term -> Elab' EState Term -> Bool -> Elab' EState Term
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (Term -> Elab' EState Term
runTacTm Term
first') (Term -> Elab' EState Term
runTacTm Term
alt') Bool
True
| Name
n Name -> Name -> Bool
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' <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
first
Term
f' <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
f
Elab' EState Term
-> (Err -> Elab' EState Term) -> Elab' EState Term
forall aux a. Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
tryCatch (Term -> Elab' EState Term
runTacTm Term
first') ((Err -> Elab' EState Term) -> Elab' EState Term)
-> (Err -> Elab' EState Term) -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ \Err
err ->
do (Term
err', Term
_) <- Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Err -> Raw
reflectErr Err
err)
Term
f' <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval (AppStatus Name -> Term -> Term -> Term
forall n. AppStatus n -> TT n -> TT n -> TT n
App AppStatus Name
forall n. AppStatus n
Complete Term
f Term
err')
Term -> Elab' EState Term
runTacTm Term
f'
| Name
n Name -> Name -> Bool
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 (Term -> StateT (ElabState EState) TC Raw)
-> Elab' EState Term -> StateT (ElabState EState) TC Raw
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
raw
Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply Raw
raw' []
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Apply" Bool -> Bool -> Bool
|| Name
n Name -> Name -> Bool
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 (Term -> StateT (ElabState EState) TC Raw)
-> Elab' EState Term -> StateT (ElabState EState) TC Raw
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
raw
[(Bool, Int)]
argSpec' <- (Bool -> (Bool, Int)) -> [Bool] -> [(Bool, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
b -> (Bool
b, Int
0)) ([Bool] -> [(Bool, Int)])
-> StateT (ElabState EState) TC [Bool]
-> StateT (ElabState EState) TC [(Bool, Int)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> (Term -> Elab' EState Bool)
-> Term -> StateT (ElabState EState) TC [Bool]
forall a. (Term -> ElabD a) -> Term -> ElabD [a]
reifyList Term -> Elab' EState Bool
reifyBool Term
argSpec
let op :: Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
op = if Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Apply"
then Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply
else Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
match_apply
[(Name, Name)]
ns <- Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
op Raw
raw' [(Bool, Int)]
argSpec'
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$
Raw -> [Raw] -> Raw
rawList (Raw -> Raw -> Raw
rawPairTy (Name -> Raw
Var (Name -> Raw) -> Name -> Raw
forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName") (Name -> Raw
Var (Name -> Raw) -> Name -> Raw
forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName"))
[ (Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var (Name -> Raw) -> Name -> Raw
forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName", Name -> Raw
Var (Name -> Raw) -> Name -> Raw
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 Name -> Name -> Bool
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 <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
hint
case Term
hintStr of
Constant (Str String
h) -> do
Name
n <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
h)
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
reflectName Name
n)
Term
_ -> String -> Elab' EState Term
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no hint"
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
n
Raw
ty' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
ty
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n' Raw
ty'
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Elab' EState Env
reifyEnv Term
env'
Raw
raw' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw (Term -> StateT (ElabState EState) TC Raw)
-> Elab' EState Term -> StateT (ElabState EState) TC Raw
forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
raw
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
(Term
tm, Term
ty) <- TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term))
-> TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt Env
env Raw
raw'
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
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 Name -> Name -> Bool
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
ElabD ()
forall aux. Elab' aux ()
attack
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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
Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
rewrite Raw
r
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
what
[Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
if Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
n' [Name]
hs
then Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n' ElabD () -> Elab' EState Term -> Elab' EState Term
forall a b.
StateT (ElabState EState) TC a
-> StateT (ElabState EState) TC b -> StateT (ElabState EState) TC b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Elab' EState Term
returnUnit
else TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ String
"The name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n' String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" does not denote a hole"
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
what
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
n'
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Maybe Name -> StateT (ElabState EState) TC (Maybe Name)
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Maybe Name
forall a. Maybe a
Nothing
Just Term
name -> (Name -> Maybe Name)
-> Elab' EState Name -> StateT (ElabState EState) TC (Maybe Name)
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Name -> Maybe Name
forall a. a -> Maybe a
Just (Elab' EState Name -> StateT (ElabState EState) TC (Maybe Name))
-> Elab' EState Name -> StateT (ElabState EState) TC (Maybe Name)
forall a b. (a -> b) -> a -> b
$ Term -> Elab' EState Name
reifyTTName Term
name
Maybe Name -> ElabD ()
forall aux. Maybe Name -> Elab' aux ()
intro Maybe Name
n
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
n
Raw
ty' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
ty
Name -> RigCount -> Maybe ImplicitInfo -> Raw -> ElabD ()
forall aux.
Name -> RigCount -> Maybe ImplicitInfo -> Raw -> Elab' aux ()
forAll Name
n' RigCount
RigW Maybe ImplicitInfo
forall a. Maybe a
Nothing Raw
ty'
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
n
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
patvar' Name
n'
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
n
Name -> RigCount -> ElabD ()
forall aux. Name -> RigCount -> Elab' aux ()
patbind Name
n' RigCount
RigW
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Elab' EState 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
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n' RigCount
RigW Raw
ty' Raw
tm'
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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; ElabD ()
forall aux. Elab' aux ()
compute ; Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Elab' EState Env
reifyEnv Term
env
Term
tm' <- Term -> Elab' EState Term
reifyTT Term
tm
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
let out :: Term
out = Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env' (Term -> Term
forall n. Eq n => TT n -> TT n
finalise Term
tm')
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ Term -> Raw
reflect Term
out
| Name
n Name -> Name -> Bool
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 -> Elab' EState Term
reifyTT Term
tm
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Term -> StateT (ElabState EState) TC (Term, Term))
-> Term
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> StateT (ElabState EState) TC (Term, Term))
-> (Term -> Raw)
-> Term
-> StateT (ElabState EState) TC (Term, Term)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Raw
reflect (Term -> Elab' EState Term) -> Term -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term
whnf Context
ctxt [] Term
tm'
| Name
n Name -> Name -> Bool
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 -> Elab' EState Env
reifyEnv Term
env
Term
tm1' <- Term -> Elab' EState Term
reifyTT Term
tm1
Term
tm2' <- Term -> Elab' EState Term
reifyTT Term
tm2
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term -> TC ()
converts Context
ctxt Env
env' Term
tm1' Term
tm2'
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
let rty :: Raw
rty = (RFunArg -> Raw -> Raw) -> Raw -> [RFunArg] -> Raw
forall a b. (a -> b -> b) -> b -> [a] -> b
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') <- TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term))
-> TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
rty
Context -> Term -> Term -> ElabD ()
forall {t :: (* -> *) -> * -> *} {a}.
(Monad (t TC), MonadTrans t, Show a) =>
Context -> a -> Term -> t TC ()
mustBeType Context
ctxt Term
checked Term
ty'
Context -> Name -> ElabD ()
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
Context -> ElabD ()
forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
(EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux ((EState -> EState) -> ElabD ()) -> (EState -> EState) -> ElabD ()
forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls = (RTyDeclInstrs n fc (map rFunArgToPArg args) checked) :
new_tyDecls e }
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
let tcTy :: Raw
tcTy = (RFunArg -> Raw -> Raw) -> Raw -> [RFunArg] -> Raw
forall a b. (a -> b -> b) -> b -> [a] -> b
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') <- TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term))
-> TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
tcTy
Context -> Term -> Term -> ElabD ()
forall {t :: (* -> *) -> * -> *} {a}.
(Monad (t TC), MonadTrans t, Show a) =>
Context -> a -> Term -> t TC ()
mustBeType Context
ctxt Term
checked Term
ty'
Context -> Name -> ElabD ()
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
Context -> ElabD ()
forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
(EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux ((EState -> EState) -> ElabD ()) -> (EState -> EState) -> ElabD ()
forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls = RDatatypeDeclInstrs n (map rFunArgToPArg args) : new_tyDecls e }
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Term
tyconTy <- case Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt of
Just Term
t -> Term -> Elab' EState Term
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
Maybe Term
Nothing -> TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ String
"Type not previously declared"
Ctxt TypeInfo
datatypes <- Elab' EState (Ctxt TypeInfo)
forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
case Name -> Ctxt TypeInfo -> [(Name, TypeInfo)]
forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
n Ctxt TypeInfo
datatypes of
[] -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
[(Name, TypeInfo)]
_ -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (String -> TC ()) -> String -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (String -> Err) -> String -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> ElabD ()) -> String -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" is already defined as a datatype."
[(Name, [PArg], Term)]
ctors' <- (RConstructorDefn -> ElabD (Name, [PArg], Term))
-> [RConstructorDefn]
-> StateT (ElabState EState) TC [(Name, [PArg], Term)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (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 <- StateT (ElabState EState) TC (ElabState EState)
forall s (m :: * -> *). MonadState s m => m s
get
let i :: Int
i = ProofState -> Int
global_nextname ProofState
ps
ElabState EState -> ElabD ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put (ElabState EState -> ElabD ()) -> ElabState EState -> ElabD ()
forall a b. (a -> b) -> a -> b
$ (ProofState, EState)
-> String -> Maybe (ElabState EState) -> ElabState EState
forall aux.
(ProofState, aux)
-> String -> Maybe (ElabState aux) -> ElabState aux
ES (ProofState
ps { global_nextname = global_nextname ps + 1 },
EState
aux)
String
str
Maybe (ElabState EState)
prev
Int -> Elab' EState Int
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
let ctxt' :: Context
ctxt' = Datatype Name -> Context -> Context
addDatatype (Name -> Int -> Term -> Bool -> [(Name, Term)] -> Datatype Name
forall n. n -> Int -> TT n -> Bool -> [(n, TT n)] -> Datatype n
Data Name
n Int
ttag Term
tyconTy Bool
False (((Name, [PArg], Term) -> (Name, Term))
-> [(Name, [PArg], Term)] -> [(Name, Term)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
cn, [PArg]
_, Term
cty) -> (Name
cn, Term
cty)) [(Name, [PArg], Term)]
ctors')) Context
ctxt
Context -> ElabD ()
forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
(EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux ((EState -> EState) -> ElabD ()) -> (EState -> EState) -> ElabD ()
forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls = RDatatypeDefnInstrs n tyconTy ctors' : new_tyDecls e }
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
cls
Name
implName <- Term -> Elab' EState Name
reifyTTName Term
impl
(EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux ((EState -> EState) -> ElabD ()) -> (EState -> EState) -> ElabD ()
forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls = RAddImplementation interfaceName implName :
new_tyDecls e }
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
n
case Name -> Ctxt InterfaceInfo -> Maybe InterfaceInfo
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n' (IState -> Ctxt InterfaceInfo
idris_interfaces IState
ist) of
Just InterfaceInfo
_ -> ((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
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 -> ((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
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 Name -> Name -> Bool
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 <- Elab' EState Term
forall aux. Elab' aux Term
goal
Name
fn <- Term -> Elab' EState Name
reifyTTName Term
fn
Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
resolveTC' Bool
False Bool
True Int
100 Term
g Name
fn IState
ist
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
depth
Term
hints' <- Term -> Elab' EState Term
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 <- (Term -> Elab' EState Name) -> [Term] -> Elab' EState [Name]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> Elab' EState Name
reifyTTName [Term]
hs
ElabD ()
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 Maybe Name
forall a. Maybe a
Nothing (Int -> String -> Name
sMN Int
0 String
"search ") [] [Name]
actualHints IState
ist
Elab' EState Term
returnUnit
(Constant (I Int
_), Maybe [Term]
Nothing ) ->
TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
InternalMsg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ String
"Not a list: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
hints'
(Term
_, Maybe [Term]
_) -> TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
InternalMsg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ String
"Can't reify int " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
d
| Name
n Name -> Name -> Bool
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 <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Term
script <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
script
(Term
goalTT, Term
goalTy) <- TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term))
-> TC (Term, Term) -> StateT (ElabState EState) TC (Term, Term)
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
goal'
TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> TC ()
isType Context
ctxt [] Term
goalTy
Name
recH <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"recElabHole")
EState
aux <- Elab' EState EState
forall aux. Elab' aux aux
getAux
Ctxt TypeInfo
datatypes <- Elab' EState (Ctxt TypeInfo)
forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
Int
g_next <- Elab' EState Int
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)
_) <- StateT (ElabState EState) TC (ElabState EState)
forall s (m :: * -> *). MonadState s m => m s
get
TC (Context, ElabState EState)
-> StateT (ElabState EState) TC (Context, ElabState EState)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Context, ElabState EState)
-> StateT (ElabState EState) TC (Context, ElabState EState))
-> TC (Context, ElabState EState)
-> StateT (ElabState EState) TC (Context, ElabState EState)
forall a b. (a -> b) -> a -> b
$ EState
-> Elab' EState Context
-> ProofState
-> TC (Context, ElabState EState)
forall aux a.
aux -> Elab' aux a -> ProofState -> TC (a, ElabState aux)
runElab EState
aux
(do ElabInfo
-> IState -> FC -> Env -> Term -> [String] -> Elab' EState Term
runElabAction ElabInfo
info IState
ist FC
fc [] Term
script [String]
ns
Context
ctxt' <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Context -> Elab' EState Context
forall a. a -> StateT (ElabState EState) TC a
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 = nextname current_p })
Context -> ElabD ()
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) <- StateT (ElabState EState) TC (ElabState EState)
forall s (m :: * -> *). MonadState s m => m s
get
let p' :: ProofState
p' = ProofState
prf { nextname = nextname p
, global_nextname = global_nextname p
}
ElabState EState -> ElabD ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ((ProofState, EState)
-> String -> Maybe (ElabState EState) -> ElabState EState
forall aux.
(ProofState, aux)
-> String -> Maybe (ElabState aux) -> ElabState aux
ES (ProofState
p', EState
aux') String
s Maybe (ElabState EState)
e)
Env
env' <- Elab' EState Env
forall aux. Elab' aux Env
get_env
(Term
tm, Term
ty, UCs
_) <- TC (Term, Term, UCs)
-> StateT (ElabState EState) TC (Term, Term, UCs)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Term, Term, UCs)
-> StateT (ElabState EState) TC (Term, Term, UCs))
-> TC (Term, Term, UCs)
-> StateT (ElabState EState) TC (Term, Term, UCs)
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)
((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$
(Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var (Name -> Raw) -> Name -> Raw
forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT", Name -> Raw
Var (Name -> Raw) -> Name -> Raw
forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT")
(Raw
tm', Raw
ty')
| Name
n Name -> Name -> Bool
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 -> Elab' EState Name
reifyTTName Term
n
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Term
ptm <- Elab' EState Term
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'
ElabD ()
forall aux. Elab' aux ()
attack
[Name] -> [Name] -> Name -> Elab' EState Name
forall aux. [Name] -> [Name] -> Name -> Elab' aux Name
defer [Name]
unique_used [Name]
lin_used Name
mvn
ElabD ()
forall aux. Elab' aux ()
solve
Elab' EState Term
returnUnit
| Name
n Name -> Name -> Bool
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 <- Term -> Elab' EState Term
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 ((Char -> Bool) -> String -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all ((Char -> String -> Bool) -> String -> Char -> Bool
forall a b c. (a -> b -> c) -> b -> a -> c
flip Char -> String -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
opChars) String
op) Bool -> Bool -> Bool
|| String -> [String] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
op [String]
invalidOperators
then TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ String
"'" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"' is not a valid operator name."
else case [Fixity] -> [Fixity]
forall a. Eq a => [a] -> [a]
nub [Fixity
f | Fix Fixity
f String
someOp <- [FixDecl]
fixities, String
someOp String -> String -> Bool
forall a. Eq a => a -> a -> Bool
== String
op] of
[] -> TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ String
"No fixity found for operator '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'."
[Fixity
f] -> ((Term, Term) -> Term)
-> StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term
forall a b.
(a -> b)
-> StateT (ElabState EState) TC a -> StateT (ElabState EState) TC b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Term, Term) -> Term
forall a b. (a, b) -> a
fst (StateT (ElabState EState) TC (Term, Term) -> Elab' EState Term)
-> (Raw -> StateT (ElabState EState) TC (Term, Term))
-> Raw
-> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Raw -> Elab' EState Term) -> Raw -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ Fixity -> Raw
reflectFixity Fixity
f
[Fixity]
many -> TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
InternalMsg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ String
"Ambiguous fixity for '" String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
op String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
"'! Found " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Fixity] -> String
forall a. Show a => a -> String
show [Fixity]
many
Term
_ -> TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$ String
"Not a constant string for an operator name: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
opTm
| Name
n Name -> Name -> Bool
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' <- Term -> Elab' EState Term
forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
msg
[ErrorReportPart]
parts <- Term -> ElabD [ErrorReportPart]
reifyReportParts Term
msg
[ErrorReportPart] -> Elab' EState Term
forall aux a. [ErrorReportPart] -> Elab' aux a
debugElaborator [ErrorReportPart]
parts
runTacTm Term
x = Term -> Elab' EState Term
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 <- Elab' EState Env
forall aux. Elab' aux Env
get_env
Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
let tac' :: PTactic
tac' = (PTerm -> PTerm) -> PTactic -> PTactic
forall a b. (a -> b) -> PTactic' a -> PTactic' b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IState -> [Name] -> PTerm -> PTerm
addImplBound IState
ist (((Name, RigCount, Binder Term) -> Name) -> Env -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, RigCount, Binder Term) -> Name
forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
env)) PTactic
tac
if Bool
autoSolve
then PTactic -> ElabD ()
runT PTactic
tac'
else ElabD () -> Maybe Err -> ElabD ()
forall aux. Elab' aux () -> Maybe Err -> Elab' aux ()
no_errors (PTactic -> ElabD ()
runT PTactic
tac')
(Err -> Maybe Err
forall a. a -> Maybe a
Just (Term -> [(Name, Term)] -> Err
forall t. t -> [(Name, t)] -> Err' t
CantSolveGoal Term
g (((Name, RigCount, Binder Term) -> (Name, Term))
-> Env -> [(Name, Term)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
b)) Env
env)))
where
runT :: PTactic -> ElabD ()
runT (Intro []) = do Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
ElabD ()
forall aux. Elab' aux ()
attack; Maybe Name -> ElabD ()
forall aux. Maybe Name -> Elab' aux ()
intro (Term -> Maybe Name
forall {a}. TT a -> Maybe a
bname Term
g)
where
bname :: TT a -> Maybe a
bname (Bind a
n Binder (TT a)
_ TT a
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
n
bname TT a
_ = Maybe a
forall a. Maybe a
Nothing
runT (Intro [Name]
xs) = (Name -> ElabD ()) -> [Name] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
x -> do ElabD ()
forall aux. Elab' aux ()
attack; Maybe Name -> ElabD ()
forall aux. Maybe Name -> Elab' aux ()
intro (Name -> Maybe Name
forall a. a -> Maybe a
Just Name
x)) [Name]
xs
runT PTactic
Intros = do Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
ElabD ()
forall aux. Elab' aux ()
attack;
Maybe Name -> ElabD ()
forall aux. Maybe Name -> Elab' aux ()
intro (Term -> Maybe Name
forall {a}. TT a -> Maybe a
bname Term
g)
ElabD () -> ElabD () -> Bool -> ElabD ()
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (PTactic -> ElabD ()
runT PTactic
forall t. PTactic' t
Intros)
(() -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
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
_) = a -> Maybe a
forall a. a -> Maybe a
Just a
n
bname TT a
_ = Maybe 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
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
runT (MatchRefine Name
fn)
= do [(Name, [Bool])]
fnimps <-
case Name -> Ctxt [PArg] -> [(Name, [PArg])]
forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
[] -> do [Bool]
a <- Name -> StateT (ElabState EState) TC [Bool]
forall {aux}. Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
fn
[(Name, [Bool])] -> StateT (ElabState EState) TC [(Name, [Bool])]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
fn, [Bool]
a)]
[(Name, [PArg])]
ns -> [(Name, [Bool])] -> StateT (ElabState EState) TC [(Name, [Bool])]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (((Name, [PArg]) -> (Name, [Bool]))
-> [(Name, [PArg])] -> [(Name, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
n, [PArg]
a) -> (Name
n, (PArg -> Bool) -> [PArg] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> PArg -> Bool
forall a b. a -> b -> a
const Bool
True) [PArg]
a)) [(Name, [PArg])]
ns)
let tacs :: [(Elab' aux [(Name, Name)], Name)]
tacs = ((Name, [Bool]) -> (Elab' aux [(Name, Name)], Name))
-> [(Name, [Bool])] -> [(Elab' aux [(Name, Name)], Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
fn', [Bool]
imps) ->
(Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
match_apply (Name -> Raw
Var Name
fn') ((Bool -> (Bool, Int)) -> [Bool] -> [(Bool, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x, Int
0)) [Bool]
imps),
Name
fn')) [(Name, [Bool])]
fnimps
[(Elab' EState [(Name, Name)], Name)]
-> Elab' EState [(Name, Name)]
forall aux a. [(Elab' aux a, Name)] -> Elab' aux a
tryAll [(Elab' EState [(Name, Name)], Name)]
forall {aux}. [(Elab' aux [(Name, Name)], Name)]
tacs
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
where envArgs :: Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
n = do Env
e <- Elab' aux Env
forall aux. Elab' aux Env
get_env
case Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
e of
Just Binder Term
t -> [Bool] -> StateT (ElabState aux) TC [Bool]
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bool] -> StateT (ElabState aux) TC [Bool])
-> [Bool] -> StateT (ElabState aux) TC [Bool]
forall a b. (a -> b) -> a -> b
$ ((Name, Term) -> Bool) -> [(Name, Term)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> (Name, Term) -> Bool
forall a b. a -> b -> a
const Bool
False)
(Term -> [(Name, Term)]
forall n. TT n -> [(n, TT n)]
getArgTys (Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
t))
Maybe (Binder Term)
_ -> [Bool] -> StateT (ElabState aux) TC [Bool]
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return []
runT (Refine Name
fn [])
= do [(Name, [Bool])]
fnimps <-
case Name -> Ctxt [PArg] -> [(Name, [PArg])]
forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
[] -> do [Bool]
a <- Name -> StateT (ElabState EState) TC [Bool]
forall {aux}. Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
fn
[(Name, [Bool])] -> StateT (ElabState EState) TC [(Name, [Bool])]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
fn, [Bool]
a)]
[(Name, [PArg])]
ns -> [(Name, [Bool])] -> StateT (ElabState EState) TC [(Name, [Bool])]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (((Name, [PArg]) -> (Name, [Bool]))
-> [(Name, [PArg])] -> [(Name, [Bool])]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
n, [PArg]
a) -> (Name
n, (PArg -> Bool) -> [PArg] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map PArg -> Bool
forall {t}. PArg' t -> Bool
isImp [PArg]
a)) [(Name, [PArg])]
ns)
let tacs :: [(Elab' aux [(Name, Name)], Name)]
tacs = ((Name, [Bool]) -> (Elab' aux [(Name, Name)], Name))
-> [(Name, [Bool])] -> [(Elab' aux [(Name, Name)], Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
fn', [Bool]
imps) ->
(Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
fn') ((Bool -> (Bool, Int)) -> [Bool] -> [(Bool, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x, Int
0)) [Bool]
imps),
Name
fn')) [(Name, [Bool])]
fnimps
[(Elab' EState [(Name, Name)], Name)]
-> Elab' EState [(Name, Name)]
forall aux a. [(Elab' aux a, Name)] -> Elab' aux a
tryAll [(Elab' EState [(Name, Name)], Name)]
forall {aux}. [(Elab' aux [(Name, Name)], Name)]
tacs
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
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 <- Elab' aux Env
forall aux. Elab' aux Env
get_env
case Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
e of
Just Binder Term
t -> [Bool] -> StateT (ElabState aux) TC [Bool]
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Bool] -> StateT (ElabState aux) TC [Bool])
-> [Bool] -> StateT (ElabState aux) TC [Bool]
forall a b. (a -> b) -> a -> b
$ ((Name, Term) -> Bool) -> [(Name, Term)] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> (Name, Term) -> Bool
forall a b. a -> b -> a
const Bool
False)
(Term -> [(Name, Term)]
forall n. TT n -> [(n, TT n)]
getArgTys (Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
t))
Maybe (Binder Term)
_ -> [Bool] -> StateT (ElabState aux) TC [Bool]
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return []
runT (Refine Name
fn [Bool]
imps) = do [(Name, Name)]
ns <- Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
fn) ((Bool -> (Bool, Int)) -> [Bool] -> [(Bool, Int)]
forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x,Int
0)) [Bool]
imps)
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
runT PTactic
DoUnify = do ElabD ()
forall aux. Elab' aux ()
unify_all
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
runT (Claim Name
n PTerm
tm) = do Name
tmHole <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"newGoal")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tmHole Raw
RType
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
n (Name -> Raw
Var Name
tmHole)
Name -> ElabD ()
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
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
runT (Equiv PTerm
tm)
= do ElabD ()
forall aux. Elab' aux ()
attack
Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"ety")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"eqval")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"equiv_val")
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
Name -> ElabD ()
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
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
valn
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
runT (Rewrite PTerm
tm)
= do ElabD ()
forall aux. Elab' aux ()
attack;
Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rval")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rewrite_rule")
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
Name -> ElabD ()
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
Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
rewrite (Name -> Raw
Var Name
letn)
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
runT (LetTac Name
n PTerm
tm)
= do ElabD ()
forall aux. Elab' aux ()
attack
Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
unique_hole Name
n
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
Name -> ElabD ()
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
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
runT (LetTacTy Name
n PTerm
ty PTerm
tm)
= do ElabD ()
forall aux. Elab' aux ()
attack
Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
unique_hole Name
n
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
Name -> ElabD ()
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
Name -> ElabD ()
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
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
runT PTactic
Compute = ElabD ()
forall aux. Elab' aux ()
compute
runT PTactic
Trivial = do IState -> ElabD ()
trivial' IState
ist; Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
runT PTactic
TCImplementation = PTactic -> ElabD ()
runT (PTerm -> PTactic
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
Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve ElabD ()
forall aux. Elab' aux ()
solveAll
runT (Focus Name
n) = Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
runT PTactic
Unfocus = do [Name]
hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
case [Name]
hs of
[] -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
(Name
h : [Name]
_) -> Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
h
runT PTactic
Solve = ElabD ()
forall aux. Elab' aux ()
solve
runT (Try PTactic
l PTactic
r) = do ElabD () -> ElabD () -> Bool -> ElabD ()
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 <- Elab' EState Env
forall aux. Elab' aux Env
get_env
Term
tgoal <- Elab' EState Term
forall aux. Elab' aux Term
goal
ElabD ()
forall aux. Elab' aux ()
attack
Name
script <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"script")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
script Raw
scriptTy
Name
scriptvar <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scriptvar" )
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
scriptvar RigCount
RigW Raw
scriptTy (Name -> Raw
Var Name
script)
Name -> ElabD ()
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
_) <- Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
scriptvar)
Name
restac <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"restac")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
restac Raw
tacticTy
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
restac
Raw -> ElabD ()
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' <- Elab' EState Term
forall aux. Elab' aux Term
get_guess
ElabD ()
forall aux. Elab' aux ()
solve
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState 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")
(RigCount -> Maybe ImplicitInfo -> Raw -> Raw -> Binder Raw
forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW Maybe ImplicitInfo
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")
(RigCount -> Maybe ImplicitInfo -> Raw -> Raw -> Binder Raw
forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW Maybe ImplicitInfo
forall a. Maybe a
Nothing (Name -> Raw
Var (Name -> Raw) -> Name -> Raw
forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT") Raw
RType) Raw
tacticTy))
runT (ByReflection PTerm
tm)
= do Term
tgoal <- Elab' EState Term
forall aux. Elab' aux Term
goal
ElabD ()
forall aux. Elab' aux ()
attack
Name
script <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"script")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
script Raw
scriptTy
Name
scriptvar <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scriptvar" )
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
scriptvar RigCount
RigW Raw
scriptTy (Name -> Raw
Var Name
script)
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
script
Term
ptm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
Env
env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
let denv :: [(Name, Term)]
denv = ((Name, RigCount, Binder Term) -> (Name, Term))
-> Env -> [(Name, Term)]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, Binder Term -> Term
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 [PTerm -> PArg
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
_) <- Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
scriptvar)
Name
restac <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"restac")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
restac Raw
tacticTy
Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
restac
Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Term -> Raw
forget Term
script')
Term
restac' <- Elab' EState Term
forall aux. Elab' aux Term
get_guess
ElabD ()
forall aux. Elab' aux ()
solve
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState 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 ElabD ()
forall aux. Elab' aux ()
attack
Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letvar")
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
Name -> ElabD ()
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
_) <- Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
letn)
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState 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 (PTerm -> PTactic
forall t. t -> PTactic' t
Exact (PTerm -> PTactic) -> PTerm -> PTactic
forall a b. (a -> b) -> a -> b
$ Raw -> PTerm
PQuote (Term -> Raw
reflect Term
value'))
runT (Fill PTerm
v) = do ElabD ()
forall aux. Elab' aux ()
attack
Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
Name
valn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
Name
letn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letvar")
Name -> RigCount -> Raw -> Raw -> ElabD ()
forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
Name -> ElabD ()
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
_) <- Raw -> StateT (ElabState EState) TC (Term, Term)
forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
letn)
Context
ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
Env
env <- Elab' EState 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 (PTerm -> PTactic
forall t. t -> PTactic' t
Exact (PTerm -> PTactic) -> PTerm -> PTactic
forall a b. (a -> b) -> a -> b
$ Raw -> PTerm
PQuote Raw
rawValue)
runT (GoalType String
n PTactic
tac) = do Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
case Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply Term
g of
(P NameType
_ Name
n' Term
_, [Term]
_) ->
if Name -> Name
nsroot Name
n' Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
n
then PTactic -> ElabD ()
runT PTactic
tac
else String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong goal type"
(Term, [Term])
_ -> String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong goal type"
runT PTactic
ProofState = do Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
() -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runT PTactic
Skip = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
runT (TFail [ErrorReportPart]
err) = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (Err -> TC ()) -> Err -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> ElabD ()) -> Err -> ElabD ()
forall a b. (a -> b) -> a -> b
$ [[ErrorReportPart]] -> Err -> Err
forall t. [[ErrorReportPart]] -> Err' t -> Err' t
ReflectionError [[ErrorReportPart]
err] (String -> Err
forall t. String -> Err' t
Msg String
"")
runT PTactic
SourceFC =
case Maybe FC
perhapsFC of
Maybe FC
Nothing -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (Err -> TC ()) -> Err -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> ElabD ()) -> Err -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg String
"There is no source location available."
Just FC
fc ->
do Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Raw -> ElabD ()) -> Raw -> ElabD ()
forall a b. (a -> b) -> a -> b
$ FC -> Raw
reflectFC FC
fc
ElabD ()
forall aux. Elab' aux ()
solve
runT PTactic
Qed = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (Err -> TC ()) -> Err -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> ElabD ()) -> Err -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg String
"The qed command is only valid in the interactive prover"
runT PTactic
x = String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ElabD ()) -> String -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String
"Not implemented " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTactic -> String
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 = Err -> Maybe Err -> Err
forall a. a -> Maybe a -> a
fromMaybe Err
err (Err -> Maybe 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
_) = Maybe (Err' t)
forall a. Maybe a
Nothing
rewrite (ProofSearchFail Err' t
e) = (Err' t -> Err' t) -> Maybe (Err' t) -> Maybe (Err' t)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Err' t -> Err' t
forall t. Err' t -> Err' t
ProofSearchFail (Err' t -> Maybe (Err' t)
rewrite Err' t
e)
rewrite (At FC
fc Err' t
e) = (Err' t -> Err' t) -> Maybe (Err' t) -> Maybe (Err' t)
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (FC -> Err' t -> Err' t
forall t. FC -> Err' t -> Err' t
At FC
fc) (Err' t -> Maybe (Err' t)
rewrite Err' t
e)
rewrite Err' t
err = Err' t -> Maybe (Err' t)
forall a. a -> Maybe a
Just (Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
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 = Idris a -> (Err -> Idris a) -> Idris a
forall a. Idris a -> (Err -> Idris a) -> Idris a
idrisCatch Idris a
x (\ Err
e -> Err -> Idris Err
handle Err
e Idris Err -> (Err -> Idris a) -> Idris a
forall a b.
StateT IState (ExceptT Err IO) a
-> (a -> StateT IState (ExceptT Err IO) b)
-> StateT IState (ExceptT Err IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Err -> Idris a
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"
Err -> Idris Err
forall a. a -> StateT IState (ExceptT Err IO) a
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"
Err -> Idris Err
forall a. a -> StateT IState (ExceptT Err IO) a
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
Err -> Idris Err
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (FC -> Err -> Err
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
Err -> Idris Err
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (String -> Name -> Maybe Term -> Err -> Err
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 [Name] -> Bool
forall a. [a] -> Bool
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
Err -> Idris Err
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name -> Name -> [(Name, Name)] -> Err -> Err
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 (Err -> String
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 = Map Name (Set Name)
-> (Map Name (Set Name) -> Map Name (Set Name))
-> Maybe (Map Name (Set Name))
-> Map Name (Set Name)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Name (Set Name)
forall k a. Map k a
M.empty Map Name (Set Name) -> Map Name (Set Name)
forall a. a -> a
id (Maybe (Map Name (Set Name)) -> Map Name (Set Name))
-> (IState -> Maybe (Map Name (Set Name)))
-> IState
-> Map Name (Set Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
Name -> Ctxt (Map Name (Set Name)) -> Maybe (Map Name (Set Name))
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
f (Ctxt (Map Name (Set Name)) -> Maybe (Map Name (Set Name)))
-> (IState -> Ctxt (Map Name (Set Name)))
-> IState
-> Maybe (Map Name (Set Name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
IState -> Ctxt (Map Name (Set Name))
idris_function_errorhandlers (IState -> Map Name (Set Name)) -> IState -> Map Name (Set Name)
forall a b. (a -> b) -> a -> b
$ IState
ist
[Name] -> Idris [Name]
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ([Name] -> Idris [Name])
-> (Map Name (Set Name) -> [Name])
-> Map Name (Set Name)
-> Idris [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> (Set Name -> [Name]) -> Maybe (Set Name) -> [Name]
forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] Set Name -> [Name]
forall a. Set a -> [a]
S.toList (Maybe (Set Name) -> [Name])
-> (Map Name (Set Name) -> Maybe (Set Name))
-> Map Name (Set Name)
-> [Name]
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Map Name (Set Name) -> Maybe (Set Name)
forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
arg (Map Name (Set Name) -> Idris [Name])
-> Map Name (Set Name) -> Idris [Name]
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 = (Term -> Term) -> Err -> Err
forall a b. (a -> b) -> Err' a -> Err' b
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 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"Using reflection handlers " String -> String -> String
forall a. [a] -> [a] -> [a]
++
[String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
", " ((Name -> String) -> [Name] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Name -> String
forall a. Show a => a -> String
show [Name]
handlers))
let reports :: [Raw]
reports = (Name -> Raw) -> [Name] -> [Raw]
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 (Raw -> TC (Term, Term)) -> [Raw] -> TC [(Term, Term)]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM (Context -> Env -> Raw -> TC (Term, Term)
check (IState -> Context
tt_ctxt IState
ist) []) [Raw]
reports of
Error Err
_ -> [(Term, Term)] -> StateT IState (ExceptT Err IO) [(Term, Term)]
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return []
OK [(Term, Term)]
hs -> [(Term, Term)] -> StateT IState (ExceptT Err IO) [(Term, Term)]
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Term, Term)]
hs
Context
ctxt <- Idris Context
getContext
let results :: [Term]
results = (Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Env -> Term -> Term
normaliseAll Context
ctxt []) (((Term, Term) -> Term) -> [(Term, Term)] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Term, Term) -> Term
forall a b. (a, b) -> a
fst [(Term, Term)]
handlers)
Int -> String -> Idris ()
logElab Int
3 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"New error message info: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [String] -> String
forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (String -> [String] -> [String]
forall a. a -> [a] -> [a]
intersperse String
" and " ((Term -> String) -> [Term] -> [String]
forall a b. (a -> b) -> [a] -> [b]
map Term -> String
forall a. Show a => a -> String
show [Term]
results))
let errorpartsTT :: [[Term]]
errorpartsTT = (Term -> Maybe [Term]) -> [Term] -> [[Term]]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Term -> Maybe [Term]
unList ((Term -> Maybe Term) -> [Term] -> [Term]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Term -> Maybe Term
fromTTMaybe [Term]
results)
[[ErrorReportPart]]
errorparts <- case ([Term] -> Either Err [ErrorReportPart])
-> [[Term]] -> Either Err [[ErrorReportPart]]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM ((Term -> Either Err ErrorReportPart)
-> [Term] -> Either Err [ErrorReportPart]
forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
forall (m :: * -> *) a b. Monad m => (a -> m b) -> [a] -> m [b]
mapM Term -> Either Err ErrorReportPart
reifyReportPart) [[Term]]
errorpartsTT of
Left Err
err -> Err -> StateT IState (ExceptT Err IO) [[ErrorReportPart]]
forall a. Err -> Idris a
ierror Err
err
Right [[ErrorReportPart]]
ok -> [[ErrorReportPart]]
-> StateT IState (ExceptT Err IO) [[ErrorReportPart]]
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [[ErrorReportPart]]
ok
Err -> Idris Err
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Err -> Idris Err) -> Err -> Idris Err
forall a b. (a -> b) -> a -> b
$ case [[ErrorReportPart]]
errorparts of
[] -> Err
e
[[ErrorReportPart]]
parts -> [[ErrorReportPart]] -> Err -> Err
forall t. [[ErrorReportPart]] -> Err' t -> Err' t
ReflectionError [[ErrorReportPart]]
errorparts Err
e
solveAll :: Elab' aux ()
solveAll = Elab' aux () -> Elab' aux () -> Elab' aux ()
forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do Elab' aux ()
forall aux. Elab' aux ()
solve; Elab' aux ()
solveAll) (() -> Elab' aux ()
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ())
processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()
processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()
processTacticDecls ElabInfo
info [RDeclInstructions]
steps =
[RDeclInstructions] -> (RDeclInstructions -> Idris ()) -> Idris ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([RDeclInstructions] -> [RDeclInstructions]
forall a. [a] -> [a]
reverse [RDeclInstructions]
steps) ((RDeclInstructions -> Idris ()) -> Idris ())
-> (RDeclInstructions -> Idris ()) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \case
RTyDeclInstrs Name
n FC
fc [PArg]
impls Term
ty ->
do Int -> String -> Idris ()
logElab Int
3 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"Declaration from tactics: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
ty
Int -> String -> Idris ()
logElab Int
3 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
" It has impls " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PArg] -> String
forall a. Show a => a -> String
show [PArg]
impls
(IState -> IState) -> Idris ()
updateIState ((IState -> IState) -> Idris ()) -> (IState -> IState) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits =
addDef n impls (idris_implicits 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, Maybe Name
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' = ((Name, (Int, Maybe Name, Term, [Name]))
-> (Name, (Int, Maybe Name, Term, [Name], Bool, Bool)))
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))]
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]
_ -> () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
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 ((IState -> IState) -> Idris ()) -> (IState -> IState) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits = addDef n impls (idris_implicits 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)
((Name, [PArg], Term) -> Idris ())
-> [(Name, [PArg], Term)] -> Idris ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IBCWrite -> Idris ()
addIBC (IBCWrite -> Idris ())
-> ((Name, [PArg], Term) -> IBCWrite)
-> (Name, [PArg], Term)
-> Idris ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IBCWrite
IBCDef (Name -> IBCWrite)
-> ((Name, [PArg], Term) -> Name)
-> (Name, [PArg], Term)
-> IBCWrite
forall b c a. (b -> c) -> (a -> b) -> a -> c
. (Name, [PArg], Term) -> Name
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) (((Name, [PArg], Term) -> Term) -> [(Name, [PArg], Term)] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [PArg], Term) -> Term
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 (((Name, [PArg], Term) -> Name) -> [(Name, [PArg], Term)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [PArg], Term) -> Name
forall {a} {b} {c}. (a, b, c) -> a
cn [(Name, [PArg], Term)]
ctors) Bool
False [] [Int]
params [] Bool
False
(IState -> IState) -> Idris ()
updateIState ((IState -> IState) -> Idris ()) -> (IState -> IState) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_datatypes =
addDef tyn typeInfo (idris_datatypes 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)
[(Name, [PArg], Term)]
-> ((Name, [PArg], Term) -> Idris ()) -> Idris ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Name, [PArg], Term)]
ctors (((Name, [PArg], Term) -> Idris ()) -> Idris ())
-> ((Name, [PArg], Term) -> Idris ()) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \(Name
cn, [PArg]
impls, Term
_) ->
do (IState -> IState) -> Idris ()
updateIState ((IState -> IState) -> Idris ()) -> (IState -> IState) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits = addDef cn impls (idris_implicits i) }
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCImp Name
cn)
[(Name, [PArg], Term)]
-> ((Name, [PArg], Term) -> Idris ()) -> Idris ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Name, [PArg], Term)]
ctors (((Name, [PArg], Term) -> Idris ()) -> Idris ())
-> ((Name, [PArg], Term) -> Idris ()) -> Idris ()
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 (IState -> Context) -> Idris IState -> Idris Context
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 Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: ((Name, [PArg], Term) -> Name) -> [(Name, [PArg], Term)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [PArg], Term) -> Name
forall {a} {b} {c}. (a, b, c) -> a
cn [(Name, [PArg], Term)]
ctors) (Name
ctorN, Term
cty)
() -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Term
Nothing -> () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
case [(Name, [PArg], Term)]
ctors of
[(Name, [PArg], Term)
ctor] -> do Name -> Idris ()
setDetaggable ((Name, [PArg], Term) -> Name
forall {a} {b} {c}. (a, b, c) -> a
cn (Name, [PArg], Term)
ctor); Name -> Idris ()
setDetaggable Name
tyn
IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCOpt ((Name, [PArg], Term) -> Name
forall {a} {b} {c}. (a, b, c) -> a
cn (Name, [PArg], Term)
ctor)); IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCOpt Name
tyn)
[(Name, [PArg], Term)]
_ -> () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
RAddImplementation Name
interfaceName Name
implName ->
do
Int -> String -> Idris ()
logElab Int
2 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"Adding elab script implementation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
implName String -> String -> String
forall a. [a] -> [a] -> [a]
++
String
" for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
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 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"Pattern-matching definition from tactics: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n
FC -> Name -> Idris ()
solveDeferred FC
emptyFC Name
n
let lhss :: [([Name], Term)]
lhss = (([(Name, Term)], Term, Term) -> ([Name], Term))
-> [([(Name, Term)], Term, Term)] -> [([Name], Term)]
forall a b. (a -> b) -> [a] -> [b]
map (\([(Name, Term)]
ns, Term
lhs, Term
_) -> (((Name, Term) -> Name) -> [(Name, Term)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Term) -> Name
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
((([Name], Term) -> PTerm) -> [([Name], Term)] -> [PTerm]
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 <- (PTerm -> StateT IState (ExceptT Err IO) Bool)
-> [PTerm] -> StateT IState (ExceptT Err IO) [PTerm]
forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Name -> PTerm -> StateT IState (ExceptT Err IO) Bool
checkPossible Name
n) [PTerm]
possible
let undef :: [PTerm]
undef = (PTerm -> Bool) -> [PTerm] -> [PTerm]
forall a. (a -> Bool) -> [a] -> [a]
filter (IState -> [Term] -> PTerm -> Bool
forall {t :: * -> *}.
Foldable t =>
IState -> t Term -> PTerm -> Bool
noMatch IState
ist ((([Name], Term) -> Term) -> [([Name], Term)] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map ([Name], Term) -> Term
forall a b. (a, b) -> b
snd [([Name], Term)]
lhss)) [PTerm]
missing
[PTerm] -> StateT IState (ExceptT Err IO) [PTerm]
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [PTerm]
undef
let tot :: Totality
tot = if [PTerm] -> Bool
forall a. [a] -> Bool
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 ((IState -> IState) -> Idris ()) -> (IState -> IState) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_patdefs =
addDef n (cs, pmissing) $ idris_patdefs 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 = ((Name, [[Name]]) -> Name) -> [(Name, [[Name]])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [[Name]]) -> Name
forall a b. (a, b) -> a
fst ([(Name, [[Name]])] -> [Name]) -> [(Name, [[Name]])] -> [Name]
forall a b. (a -> b) -> a -> b
$ SC -> [Name] -> [(Name, [[Name]])]
findCalls SC
sc [Name]
scargs
in do Int -> String -> Idris ()
logElab Int
2 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"Called names in reflected elab: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Name] -> String
forall a. Show a => a -> String
show [Name]
calls
Name -> [Name] -> Idris ()
addCalls Name
n [Name]
calls
IBCWrite -> Idris ()
addIBC (IBCWrite -> Idris ()) -> IBCWrite -> Idris ()
forall a b. (a -> b) -> a -> b
$ Name -> IBCWrite
IBCCG Name
n
Just Def
_ -> () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
Maybe Def
Nothing -> () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
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'
Bool -> Idris () -> Idris ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Totality
tot' Totality -> Totality -> Bool
forall a. Eq a => a -> a -> Bool
/= Totality
Unchecked) (Idris () -> Idris ()) -> Idris () -> Idris ()
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 -> StateT IState (ExceptT Err IO) 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 String
-> Context
-> Ctxt TypeInfo
-> Int
-> Name
-> Term
-> EState
-> ElabD ElabResult
-> TC (ElabResult, String)
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
(FC -> ElabD ElabResult -> ElabD ElabResult
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 ((IState -> IState) -> Idris ()) -> (IState -> IState) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_name = 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)
_ -> Bool -> StateT IState (ExceptT Err IO) Bool
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
TC (Term, Term, UCs)
err -> Bool -> StateT IState (ExceptT Err IO) Bool
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
Error Err
err -> Bool -> StateT IState (ExceptT Err IO) Bool
forall a. a -> StateT IState (ExceptT Err IO) a
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 = (Term -> Bool) -> t Term -> Bool
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