{-|
Module      : Idris.Elab.Term
Description : Code to elaborate terms.

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# 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 {
    -- | The term resulting from elaboration
    ElabResult -> Term
resultTerm :: Term
    -- | Information about new metavariables
  , ElabResult -> [(Name, (Int, Maybe Name, Term, [Name]))]
resultMetavars :: [(Name, (Int, Maybe Name, Type, [Name]))]
    -- | Deferred declarations as the meaning of case blocks
  , ElabResult -> [PDecl]
resultCaseDecls :: [PDecl]
    -- | The potentially extended context from new definitions
  , ElabResult -> Context
resultContext :: Context
    -- | Meta-info about the new type declarations
  , ElabResult -> [RDeclInstructions]
resultTyDecls :: [RDeclInstructions]
    -- | Saved highlights from elaboration
  , ElabResult -> Set (FC', OutputAnnotation)
resultHighlighting :: S.Set (FC', OutputAnnotation)
    -- | The new global name counter
  , ElabResult -> Int
resultName :: Int
  }



-- | Using the elaborator, convert a term in raw syntax to a fully
-- elaborated, typechecked term.
--
-- If building a pattern match, we convert undeclared variables from
-- holes to pattern bindings.
--
-- Also find deferred names in the term and their types
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
         -- Resolve remaining interfaces. Two passes - first to get the
         -- default Num implementations, second to clean up the rest
         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 ()

-- | Build a term autogenerated as an interface method definition.
--
-- (Separate, so we don't go overboard resolving things that we don't
-- know about yet on the LHS of a pattern def)

buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name ->
         [Name] -> -- Cached names in the PTerm, before adding PAlternatives
         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
         -- set name supply to begin after highest index in tm
         [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
         -- 'dots' are the PHidden things which have not been solved by
         -- unification
         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)

-- | return whether arguments of the given constructor name can be
-- matched on. If they're polymorphic, no, unless the type has beed
-- made concrete by the time we get around to elaborating the
-- argument.
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, -- ^ Function part of application
                           ElabCtxt -> Bool
e_guarded :: Bool,
                           ElabCtxt -> Bool
e_intype :: Bool,
                           ElabCtxt -> Bool
e_qq :: Bool,
                           ElabCtxt -> Bool
e_nomatching :: Bool -- ^ can't pattern match
                         }

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

-- | Returns the set of declarations we need to add to complete the
-- definition (most likely case blocks to elaborate) as well as
-- declarations resulting from user tactic scripts (%runElab)
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 -- expand type synonyms, etc
         ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
initElabCtxt (ElabInfo -> Maybe FC
elabFC ElabInfo
info) PTerm
tm -- (in argument, guarded, in type, in qquote)
         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
$
              -- convert remaining holes to pattern vars
              do ElabD ()
forall aux. Elab' aux ()
unify_all
                 Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
matchProblems Bool
False -- only the ones we matched earlier
                 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
$
              -- Look for Rig1 (linear) pattern bindings
              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 elaborates an expression, possibly wrapping implicit coercions
    -- and forces/delays.  If you make a recursive call in elab', it is
    -- normally correct to call elabE - the ones that don't are `desugarings
    -- typically
    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
        -- If any of the autos use variables which have recently been solved,
        -- have another go at solving them now.
        ((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

        --trace ("Elaborating " ++ show t' ++ " in " ++ show g
        --         ++ "\n" ++ show tm
        --         ++ "\nholes " ++ show hs
        --         ++ "\nproblems " ++ show ps
        --         ++ "\n-----------\n") $
        --trace ("ELAB " ++ show t') $
        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  -- ^ (in an argument, guarded, in a type, in a quasiquote)
          -> Maybe FC -- ^ The closest FC in the syntax tree, if applicable
          -> PTerm -- ^ The term to elaborate
          -> 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 -- skip elabE step
    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' (_,_,inty) (PConstant c)
--     | constType c && pattern && not reflection && not inty
--       = lift $ tfail (Msg "Typecase is not allowed")
    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)
_)) -- for chasing parent interfaces
       = 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
    -- Elaborate the equality type first homogeneously, then
    -- heterogeneously as a fallback
    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
             -- Finish the mkUniqueNames job with the pruned set, rather than
             -- the full set.
             [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
                  -- If there's options, try now, and if that fails, postpone
                  -- to later.
                  [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
"_") -- We probably should do something better than this here

              doPrune :: [PTerm] -> StateT (ElabState aux) TC [PTerm]
doPrune [PTerm]
as =
                  do Elab' aux ()
forall aux. Elab' aux ()
compute -- to get 'Delayed' if it's there
                     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 -- finish the mkUniqueNames job
             [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 -- if none work, take the error from the first
              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 -- trace ("NEED IMPLICIT! " ++ show orig ++ "\n" ++
                        --      show alts ++ "\n" ++
                        --      showQuick err) $
                    -- Prune the coercions so that only the ones
                    -- with the right type to fix the error will be tried!
                    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) -- take error from original if all fail
                                  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 -- special case hack for 'Borrowed'
        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 -- special case hack for 'Borrowed'
        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' (_, _, inty) (PRef fc f)
--       | isTConName f (tt_ctxt ist) && pattern && not reflection && not inty
--          = lift $ tfail (Msg "Typecase is not allowed")
    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

             -- If the name is defined, globally or locally, elaborate it
             -- as a reference, otherwise it might end up as a pattern var.
             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

             -- this is to stop us resolving interfaces recursively
             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 -- finally, ordinary PRef elaboration
                       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 -- if n is a type constructor name, this makes no sense...
               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 -- okay for proof search
               -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)
               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")
               -- if n is a type constructor name, this makes no sense...
               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 -- okay for proof search
               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 -- okay for proof search
               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' -- okay for proof search
               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)
               -- HACK: If the name leaks into its type, it may leak out of
               -- scope outside, so substitute in the outer scope.
               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' ina fc (PLet n Placeholder
--              (PApp fc r [pexp (delab ist rty)]) sc)
    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
         -- make a function type a -> b -> c -> ... -> rty for the
         -- new function name
         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
--             trace (show (ptm, map fst argTys)) $ focus fn
            -- build and defer the function application
         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
         -- elaborate the arguments, to unify their types. They all have to
         -- be explicit.
         (((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 () -- already done, just a name

             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
    -- if f is local, just do a simple_app
    -- FIXME: Anyone feel like refactoring this mess? - EB
    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 []
--             trace ("BEFORE " ++ show f ++ ": " ++ show ty) $
            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)
--             trace (show (f, args_in, args)) $
            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 -- simple app, as below
                    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
                    -- HACK: we shouldn't resolve interfaces if we're defining an implementation
                    -- function or default definition.
                    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
                    -- if f is an interface, we need to know its arguments so that
                    -- we can unify with them
                    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)
                                -- maybe more things are solvable now
                                ElabD ()
forall aux. Elab' aux ()
unifyProblems
--                    trace ("args is " ++ show args) $ return ()
                    [(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)
--                    trace ("ns is " ++ show ns) $ return ()
                    -- mark any interface arguments as injective
--                     when (not pattern) $
                    (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 -- try again with the new information,
                                  -- to help with disambiguation
                    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) -- TODO: remove this False arg
                    [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 []
                    -- Now we find out how many implicits we needed at the
                    -- end of the application by looking at the goal again
                    -- - Have another go, but this time add the
                    -- implicits (can't think of a better way than this...)
                    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 -- quit, try again
                         [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
                                 -- Attempt to resolve any interfaces which have 'complete' types,
                                 -- i.e. no holes in them
                                 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
            -- Run the elaborator, which returns how many implicit
            -- args were needed, then run it again with those args. We need
            -- this because we have to elaborate the whole application to
            -- find out whether any computations have caused more implicits
            -- to be needed.
            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 -- lift $ tfail $ UnknownImplicit (pname imp) f
                 | 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 -> -- interface, set as injective
                                        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)
                                        -- maybe we can solve more things now...
                                           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) -- not that we look...
                                      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 -- e_isfn not set, so no recursive expansion of implicits
              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
             -- When building the metavar application, leave out the unique
             -- names which have been used elsewhere in the term, since we
             -- won't be able to use them in the resulting application.
             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
    -- A common error case if trying to typecheck an autogenerated case block
    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)

             -- Start filling in the scrutinee type, if we can work one
             -- out from the case options
             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
             -- Solve any remaining implicits - we need to solve as many
             -- as possible before making the 'case' type
             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

             -- Drop the unique arguments used in the term already
             -- and in the scrutinee (since it's
             -- not valid to use them again anyway)
             --
             -- Also drop unique arguments which don't appear explicitly
             -- in either case branch so they don't count as used
             -- unnecessarily (can only do this for unique things, since we
             -- assume they don't appear implicitly in types)
             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

             -- trace (show lin_used ++ "\n" ++ show args ++ "\n" ++ show ptm) attack
             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

             -- if the scrutinee is one of the 'args' in env, we should
             -- inspect it directly, rather than adding it as a new argument
             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)
             -- elaborate case
             (EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
e -> EState
e { case_decls = (cname', newdef) : case_decls e } )
             -- if we haven't got the type yet, hopefully we'll get it later!
             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)
--               mkCaseName (UN x) = UN (x ++ "_case")
--               mkCaseName (MN i x) = MN i (x ++ "_case")
              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

              -- If any variables in the scrutinee are in the environment with
              -- multiplicity other than RigW, let bind the scrutinee variable
              -- with the smallest multiplicity
              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 -- ambiguity is no help to us!
              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) -- can't happen, actually...
                         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 -- First extract the unquoted subterms, replacing them with fresh
             -- names in the quasiquoted term. Claim their reflections to be
             -- an inferred type (to support polytypic quasiquotes).
             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

             -- Save the old state - we need a fresh proof state to avoid
             -- capturing lexically available variables in the quoted term.
             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)

             -- Re-add the unquotes, letting Idris infer the (fictional)
             -- types. Here, they represent the real type rather than the type
             -- of their reflection.
             (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

             -- Determine whether there's an explicit goal type, and act accordingly
             -- Establish holes for the type and value of the term to be
             -- quasiquoted
             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)

             -- Let-bind the result of elaborating the contained term, so that
             -- the hole doesn't disappear
             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)

             -- Fill out the goal type, if relevant
             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

             -- Elaborate the quasiquoted term into the hole
             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

             -- We now have an elaborated term. Reflect it and solve the
             -- original goal in the original proof state, preserving highlighting
             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 -- we forget q' instead of using q to ensure rechecking
                                             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"

             -- Finally fill in the terms or patterns from the unquotes. This
             -- happens last so that their holes still exist while elaborating
             -- the main quotation.
             ((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
             -- Dotting a hole means that either the hole or any outer
             -- hole (a hole outside any occurrence of it)
             -- must be solvable by unification as well as being filled
             -- in directly.
             -- Delay dotted things to the end, then when we elaborate them
             -- we can check the result against what was inferred
             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 we're at the end anyway, do it now
             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 -- to get an extra hole
         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 -- eliminate the hole. Because there are no references, the script is only in the binding
         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) =
      -- Here we elaborate the contained term, then calculate
      -- highlighting for constFC.  The highlighting is the
      -- highlighting for the outermost constructor of the result of
      -- evaluating the elaborated term, if one exists (it always
      -- should, but better to fail gracefully for something silly
      -- like highlighting info). This is how implicit applications of
      -- fromInteger get highlighted.
      do ElabD ()
forall aux. Elab' aux ()
saveState -- so we don't pollute the elaborated term
         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'
         -- In order to intercept the elaborated value, we need to
         -- let-bind it.
         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 -- we have the highlighting - re-elaborate the value
         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

    -- delay elaboration of 't', with priority 'pri' until after everything
    -- else is done.
    -- The delayed things with lower numbered priority will be elaborated
    -- first. (In practice, this means delayed alternatives, then PHidden
    -- things.)
    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)] })

    -- If the variable in the environment is the scrutinee of the case,
    -- and has multiplicity W, keep it available
    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 -- original scrutinee
                 -> [(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 -- Find the variable we want as the scrutinee and mark it as
             -- 'True'. If the scrutinee is available in the environment,
             -- match on that otherwise match on the new argument we're adding.
             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
             -- [] can't happen since scrutinee is in the environment!
             findScr [] = String -> [(a, (Bool, b))]
forall a. HasCallStack => String -> a
error String
"The impossible happened - the scrutinee was not in the environment"

             -- To make sure top level pattern name remains in scope, put
             -- it at the end of 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)
             -- may be shadowed names in the new pattern - so replace the
             -- old ones with an _
             -- Also, names which don't appear on the rhs should not be
             -- fixed on the lhs, or this restricts the kind of matching
             -- we can do to non-dependent types.
             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 []

             -- Keep scrutinee available if it's just a name (this makes
             -- the names in scope look better when looking at a hole on
             -- the rhs of a case)
             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

    -- Fail if a term is not yet fully elaborated (e.g. if it contains
    -- case block functions that don't yet exist)
    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 ()

    -- If the goal type is a "Lazy", then try elaborating via 'Delay'
    -- first. We need to do this brute force approach, rather than anything
    -- more precise, since there may be various other ambiguities to resolve
    -- first.
    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
    -- Don't add a delay to top level pattern variables, since they
    -- can be forced on the rhs if needed
    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])


    -- Don't put implicit coercions around applications which are marked
    -- as '%noImplicit', or around case blocks, otherwise we get exponential
    -- blowup especially where there are errors deep in large expressions.
    notImplicitable :: PTerm -> Bool
notImplicitable (PApp FC
_ PTerm
f [PArg]
_) = PTerm -> Bool
notImplicitable PTerm
f
    -- TMP HACK no coercing on bind (make this configurable)
    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
    -- case is tricky enough without implicit coercions! If they are needed,
    -- they can go in the branches separately.
    notImplicitable (PCase FC
_ PTerm
_ [(PTerm, PTerm)]
_) = Bool
True
    notImplicitable PTerm
_ = Bool
False

    -- Elaboration works more smoothly if we expand function applications
    -- to their full arity and elaborate it all at once (better error messages
    -- in particular)
    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
            -- if f is global, leave it alone because we've already
            -- expanded it to the right arity
            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

    -- See if the name is listed as an implicit. If it is, return it, and
    -- drop it from the rest of the list
    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

        -- Any implicit in the application needs to have the name of a
        -- scoped implicit or a top level implicit, otherwise report an error
        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
        -- just one level at a time
        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 -- (sMN 0 "scoped_imp")
                    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
           -- Check for possible coercions to get to the goal
           -- and add them as 'alternatives'
           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) -- check for implicits
                  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 [])

    -- | Elaborate the arguments to a function
    elabArgs :: IState -- ^ The current Idris state
             -> ElabCtxt -- ^ (in an argument, guarded, in a type, in a qquote)
             -> [Bool]
             -> FC -- ^ Source location
             -> Bool
             -> Name -- ^ Name of the function being applied
             -> [((Name, Name), Bool)] -- ^ (Argument Name, Hole Name, unmatchable)
             -> Bool -- ^ under a 'force'
             -> [PTerm] -- ^ argument
             -> 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 -- solveAutos ist fn False
                 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
                   -- No coercing under an explicit Force (or it can Force/Delay
                   -- recursively!)
                   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' <- -- trace (show (n, t, hs, tm)) $
                              -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $
                              do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
holeName;
                                 Term
g <- Elab' EState Term
forall aux. Elab' aux Term
goal
                                 -- Can't pattern match on polymorphic goals
                                 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

-- For every alternative, look at the function at the head. Automatically resolve
-- any nested alternatives where that function is also at the head

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 -- keep if it's not an application

-- | Use the local elab context to work out the highlighting for a name
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

-- Try again to solve auto implicits
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 -- if it's a guess, we're working on it recursively, so stop
                        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)

-- Return true if the given error suggests an interface failure is
-- recoverable
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

-- | Compute the appropriate name for a top-level metavariable
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)) -- TODO alpha-convert 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 ()

    -- create a fake TT term for the LHS of an impossible case
    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 -- TODO document and figure out
         [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 -- TODO what are these?
                             [(Term, Bool)]
argtys [] -- TODO inaccessible types
                             [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)

    -- | Add another argument to a Pi
    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 ()

    -- | Prepare a constructor to be added to a datatype being defined here
    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
         -- ensure the constructor name is not qualified, and
         -- construct a qualified one
         Name -> ElabD ()
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Name -> t TC ()
notQualified Name
cn
         let qcn :: Name
qcn = Name -> Name
qualify Name
cn

         -- ensure that the constructor name is not defined already
         Context -> Name -> ElabD ()
forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Context -> Name -> t TC ()
mustNotBeDefined Context
ctxt Name
qcn

         -- construct the actual type for the constructor
         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

         -- ensure that the constructor builds the right family
         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
")"

         -- add temporary type declaration for constructor (so it can
         -- occur in later constructor types)
         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)

         -- Save the implicits for high-level Idris
         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


    -- Should be dependent
    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 -- Probably should be an argument size mismatch internal error


    -- | Do a step in the reflected elaborator monad. The input is the
    -- step, the output is the (reflected) term returned.
    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 -- patterns are irrefutable because `tacTmArgs` returns lists of exactly the size given to it as first argument
           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)
               -- Idris tuples nest to the right
               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"))
            -- Idris tuples nest to the right
           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."
           -- Prepare the constructors
           [(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'
           -- the rest happens in a bit
           (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
           -- See documentation above in the elab case for PMetavar
           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

-- Running tactics directly
-- if a tactic adds unification problems, return an error

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) -- let bind tm, then
              = 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) -- to elaborate tm, let bind it, then rewrite by that
              = do ElabD ()
forall aux. Elab' aux ()
attack; -- (h:_) <- get_holes
                   Name
tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rty")
                   -- start_unify h
                   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 -- store the environment
                               Term
tgoal <- Elab' EState Term
forall aux. Elab' aux Term
goal -- store the goal
                               ElabD ()
forall aux. Elab' aux ()
attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...
                               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)
                               -- now that we have the script apply
                               -- it to the reflected goal and context
                               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
                               -- normalise the result in order to
                               -- reify it
                               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) -- run the reflection function 'tm' on the
                           -- goal, then apply the resulting reflected Tactic
        = 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)
             -- now that we have the script apply
             -- it to the reflected goal
             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
             -- normalise the result in order to
             -- reify it
             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 -- let x = reflect v in ...
                          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 -- let x = fill x in ...
                       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 -- Don't do meta-reflection of errors
          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
          -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them
          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')
          -- ProofSearchFail is an internal detail - so don't expose it
          handle (ProofSearchFail Err
e) = Err -> Idris Err
handle Err
e
          -- TODO: argument-specific error handlers go here for ElaboratingArg
          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

                         -- Typecheck error handlers - if this fails, most
                         -- likely something which is needed by it has not
                         -- been imported, so keep the original error.
                         [(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 [] -- ierror $ ReflectionFailed "Type error while constructing reflected error" e
                                       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

                         -- Normalize error handler terms to produce the new messages
                         -- Need to use 'normaliseAll' since we have to reduce private
                         -- names in error handlers too
                         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))

                         -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent
                         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 ())

-- | Do the left-over work after creating declarations in reflected
-- elaborator scripts
processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()
processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()
processTacticDecls ElabInfo
info [RDeclInstructions]
steps =
  -- The order of steps is important: type declarations might
  -- establish metavars that later function bodies resolve.
  [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]
_) ->
             -- If the function isn't defined at the end of the elab script,
             -- then it must be added as a metavariable. This needs guarding
             -- to prevent overwriting case defs with a metavar, if the case
             -- defs come after the type decl in the same script!
             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
         -- implicit precondition to IBCData is that idris_datatypes on the IState is populated.
         -- otherwise writing the IBC just fails silently!
         (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 -- from AbsSyntax.hs, really returns a disambiguating Int

         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 ()
         -- TODO: inaccessible

    RAddImplementation Name
interfaceName Name
implName ->
      do -- The interface resolution machinery relies on a special
         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 -- still need to check recursive calls
                      else PReason -> Totality
Partial PReason
NotCovering -- missing cases implies not total
         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) ->
             -- Here, we populate the call graph with a list of things
             -- we refer to, so that if they aren't total, the whole
             -- thing won't be.
             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 () -- TODO throw internal error
           Maybe Def
Nothing -> () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

         -- checkDeclTotality requires that the call graph be present
         -- before calling it.
         -- TODO: reduce code duplication with Idris.Elab.Clause
         (FC, Name) -> Idris ()
buildSCG (FC
fc, Name
n)

         -- Actually run the totality checker. In the main clause
         -- elaborator, this is deferred until after. Here, we run it
         -- now to get totality information as early as possible.
         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
    -- TODO: see if the code duplication with Idris.Elab.Clause can be
    -- reduced or eliminated.
    -- These are always cases generated by genClauses
    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 -- not recursively calling here, because we don't
                 -- want to run infinitely many times
                 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
            -- if it's a recoverable error, the case may become possible
            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)


    -- TODO: Attempt to reduce/eliminate code duplication with Idris.Elab.Clause
    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