{-|
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
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
/= :: ElabMode -> ElabMode -> Bool
$c/= :: ElabMode -> ElabMode -> Bool
== :: ElabMode -> ElabMode -> Bool
$c== :: ElabMode -> ElabMode -> Bool
Eq


data ElabResult = ElabResult {
    -- | 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 forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
fn (IState -> Ctxt TIData
idris_tyinfodata IState
ist) of
                        [TIData
TIPartial] -> Bool
True
                        [TIData]
_ -> Bool
False

         [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
         [Name]
ivs <- forall aux. Elab' aux [Name]
get_implementations
         Term
ptm <- forall aux. Elab' aux Term
get_term
         -- Resolve remaining interfaces. Two passes - first to get the
         -- default Num implementations, second to clean up the rest
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$
                             do forall aux. Name -> Elab' aux ()
focus Name
n
                                Term
g <- forall aux. Elab' aux Term
goal
                                forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
resolveTC' Bool
True Bool
True Int
10 Term
g Name
fn IState
ist)
                                    (forall aux. Name -> Elab' aux ()
movelast Name
n)) [Name]
ivs
         [Name]
ivs <- forall aux. Elab' aux [Name]
get_implementations
         [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$
              forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$
                             do forall aux. Name -> Elab' aux ()
focus Name
n
                                Term
g <- forall aux. Elab' aux Term
goal
                                Term
ptm <- forall aux. Elab' aux Term
get_term
                                Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
resolveTC' Bool
True Bool
True Int
10 Term
g Name
fn IState
ist) [Name]
ivs

         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$ IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
False

         Term
tm <- forall aux. Elab' aux Term
get_term
         Context
ctxt <- forall aux. Elab' aux Context
get_context
         Fails
probs <- forall aux. Elab' aux Fails
get_probs
         Bool
u <- forall aux. Elab' aux Bool
getUnifyLog
         [Name]
hs <- forall aux. Elab' aux [Name]
get_holes

         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$
           forall {a}. Bool -> String -> a -> a
traceWhen Bool
u (String
"Remaining holes:\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Name]
hs forall a. [a] -> [a] -> [a]
++ String
"\n" forall a. [a] -> [a] -> [a]
++
                        String
"Remaining problems:\n" forall a. [a] -> [a] -> [a]
++ Fails -> String
qshow Fails
probs) forall a b. (a -> b) -> a -> b
$
             do forall aux. Elab' aux ()
unify_all; forall aux. Bool -> Elab' aux ()
matchProblems Bool
True; forall aux. Elab' aux ()
unifyProblems

         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern) forall a b. (a -> b) -> a -> b
$ IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
True

         Fails
probs <- forall aux. Elab' aux Fails
get_probs
         case Fails
probs of
            [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ((Term
_,Term
_,Bool
_,Env
_,Err
e,[FailContext]
_,FailAt
_):Fails
es) -> forall {a}. Bool -> String -> a -> a
traceWhen Bool
u (String
"Final problems:\n" forall a. [a] -> [a] -> [a]
++ Fails -> String
qshow Fails
probs forall a. [a] -> [a] -> [a]
++ String
"\nin\n" forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
tm) forall a b. (a -> b) -> a -> b
$
                                     if Bool
inf then forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                            else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
Error Err
e)

         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
tydecl (do forall aux. Elab' aux ()
mkPat
                         forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
                         forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
orderPats)
         EState [(Name, PDecl)]
is [(Int, ElabD ())]
_ [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights [Name]
_ [(FC, Name)]
_ <- forall aux. Elab' aux aux
getAux
         Term
tt <- forall aux. Elab' aux Term
get_term
         Context
ctxt <- forall aux. Elab' aux Context
get_context
         let (Term
tm, [(Name, (Int, Maybe Name, Term, [Name]))]
ds) = forall s a. State s a -> s -> (a, s)
runState (Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred (forall a. a -> Maybe a
Just Name
fn) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, PDecl)]
is) Context
ctxt Term
tt) []
         String
log <- forall aux. Elab' aux String
getLog
         Int
g_nextname <- forall aux. Elab' aux Int
get_global_nextname
         if String
log forall a. Eq a => a -> a -> Bool
/= String
""
            then forall a. String -> a -> a
trace String
log forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [PDecl]
-> Context
-> [RDeclInstructions]
-> Set (FC', OutputAnnotation)
-> Int
-> ElabResult
ElabResult Term
tm [(Name, (Int, Maybe Name, Term, [Name]))]
ds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)
            else forall (m :: * -> *) a. Monad m => a -> m a
return (Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [PDecl]
-> Context
-> [RDeclInstructions]
-> Set (FC', OutputAnnotation)
-> Int
-> ElabResult
ElabResult Term
tm [(Name, (Int, Maybe Name, Term, [Name]))]
ds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)
  where pattern :: Bool
pattern = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
        tydecl :: Bool
tydecl = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl

        mkPat :: StateT (ElabState aux) TC ()
mkPat = do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
                   Term
tm <- forall aux. Elab' aux Term
get_term
                   case [Name]
hs of
                      (Name
h: [Name]
hs) -> do forall aux. Name -> Elab' aux ()
patvar Name
h; StateT (ElabState aux) TC ()
mkPat
                      [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

-- | 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 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
         forall aux. [Name] -> Elab' aux ()
initNextNameFrom [Name]
ns
         IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn PTerm
tm
         Fails
probs <- forall aux. Elab' aux Fails
get_probs
         Term
tm <- forall aux. Elab' aux Term
get_term
         case Fails
probs of
            [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ((Term
_,Term
_,Bool
_,Env
_,Err
e,[FailContext]
_,FailAt
_):Fails
es) -> if Bool
inf then forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                           else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
Error Err
e)
         [(Name, [Name])]
dots <- forall aux. Elab' aux [(Name, [Name])]
get_dotterm
         -- 'dots' are the PHidden things which have not been solved by
         -- unification
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [(Name, [Name])]
dots)) forall a b. (a -> b) -> a -> b
$
            forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
Error (forall t. t -> Err' t
CantMatch (Term -> Term
getInferTerm Term
tm)))
         EState [(Name, PDecl)]
is [(Int, ElabD ())]
_ [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights [Name]
_ [(FC, Name)]
_ <- forall aux. Elab' aux aux
getAux
         Term
tt <- forall aux. Elab' aux Term
get_term
         Context
ctxt <- forall aux. Elab' aux Context
get_context
         let (Term
tm, [(Name, (Int, Maybe Name, Term, [Name]))]
ds) = forall s a. State s a -> s -> (a, s)
runState (Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred (forall a. a -> Maybe a
Just Name
fn) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, PDecl)]
is) Context
ctxt Term
tt) []
         String
log <- forall aux. Elab' aux String
getLog
         Int
g_nextname <- forall aux. Elab' aux Int
get_global_nextname
         if (String
log forall a. Eq a => a -> a -> Bool
/= String
"")
            then forall a. String -> a -> a
trace String
log forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return (Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [PDecl]
-> Context
-> [RDeclInstructions]
-> Set (FC', OutputAnnotation)
-> Int
-> ElabResult
ElabResult Term
tm [(Name, (Int, Maybe Name, Term, [Name]))]
ds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)
            else forall (m :: * -> *) a. Monad m => a -> m a
return (Term
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [PDecl]
-> Context
-> [RDeclInstructions]
-> Set (FC', OutputAnnotation)
-> Int
-> ElabResult
ElabResult Term
tm [(Name, (Int, Maybe Name, Term, [Name]))]
ds (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, PDecl)]
is) Context
ctxt [RDeclInstructions]
impls Set (FC', OutputAnnotation)
highlights Int
g_nextname)

-- | 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 forall a. Eq a => a -> a -> Bool
/= Name
inferCon
   = case Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt of
          Maybe Term
Nothing -> []
          Just Term
ty -> [Name] -> [[Name]] -> Term -> [Bool]
checkArgs [] [] Term
ty
  where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]
        checkArgs :: [Name] -> [[Name]] -> Term -> [Bool]
checkArgs [Name]
env [[Name]]
ns (Bind Name
n (Pi RigCount
_ Maybe ImplicitInfo
_ Term
t Term
_) Term
sc)
            = let env' :: [Name]
env' = case Term
t of
                              TType UExp
_ -> Name
n forall a. a -> [a] -> [a]
: [Name]
env
                              Term
_ -> [Name]
env in
                  [Name] -> [[Name]] -> Term -> [Bool]
checkArgs [Name]
env' (forall a. Eq a => [a] -> [a] -> [a]
intersect [Name]
env (Term -> [Name]
refsIn Term
t) forall a. a -> [a] -> [a]
: [[Name]]
ns)
                            (forall n. TT n -> TT n -> TT n
instantiate (forall n. NameType -> n -> TT n -> TT n
P NameType
Bound Name
n Term
t) Term
sc)
        checkArgs [Name]
env [[Name]]
ns Term
t
            = forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: * -> *) a. Foldable t => t a -> Bool
null) (forall a. [a] -> [a]
reverse [[Name]]
ns)

getUnmatchable Context
ctxt Name
n = []

data ElabCtxt = ElabCtxt { ElabCtxt -> Bool
e_inarg :: Bool,
                           ElabCtxt -> Bool
e_isfn :: Bool, -- ^ 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 :: ElabD Bool
goal_polymorphic =
   do Term
ty <- forall aux. Elab' aux Term
goal
      case Term
ty of
           P NameType
_ Name
n Term
_ -> do Env
env <- forall aux. Elab' aux Env
get_env
                         case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
                              Maybe (Binder Term)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                              Maybe (Binder Term)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
           Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | 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)
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
loglvl forall a. Ord a => a -> a -> Bool
> Int
5) forall a b. (a -> b) -> a -> b
$ forall aux. Bool -> Elab' aux ()
unifyLog Bool
True
         forall aux. Elab' aux ()
compute -- 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 <- forall aux. Elab' aux aux
getAux
         forall (t :: * -> *) (m :: * -> *) a.
(Foldable t, Monad m) =>
t (m a) -> m ()
sequence_ (EState -> [ElabD ()]
get_delayed_elab EState
est)
         forall aux. Elab' aux ()
end_unify
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform) forall a b. (a -> b) -> a -> b
$
              -- convert remaining holes to pattern vars
              do forall aux. Elab' aux ()
unify_all
                 forall aux. Bool -> Elab' aux ()
matchProblems Bool
False -- only the ones we matched earlier
                 forall aux. Elab' aux ()
unifyProblems
                 forall aux. Elab' aux ()
mkPat
                 forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
         Term
ptm <- forall aux. Elab' aux Term
get_term
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
pattern forall a b. (a -> b) -> a -> b
$
              -- 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
                 forall aux. (Term -> Term) -> Elab' aux ()
update_term ([(Name, RigCount)] -> Term -> Term
setLinear [(Name, RigCount)]
pnms)
  where
    pattern :: Bool
pattern = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
    eimpossible :: Bool
eimpossible = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
    intransform :: Bool
intransform = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETransLHS
    bindfree :: Bool
bindfree = ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETransLHS
               Bool -> Bool -> Bool
|| ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
    autoimpls :: Bool
autoimpls = IOption -> Bool
opt_autoimpls (IState -> IOption
idris_options IState
ist)

    get_delayed_elab :: EState -> [ElabD ()]
get_delayed_elab EState
est =
        let ds :: [(Int, ElabD ())]
ds = EState -> [(Int, ElabD ())]
delayed_elab EState
est in
            forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd forall a b. (a -> b) -> a -> b
$ forall a. (a -> a -> Ordering) -> [a] -> [a]
sortBy (\(Int
p1, ElabD ()
_) (Int
p2, ElabD ()
_) -> forall a. Ord a => a -> a -> Ordering
compare Int
p1 Int
p2) [(Int, ElabD ())]
ds

    tcgen :: Bool
tcgen = FnOpt
Dictionary forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts
    reflection :: Bool
reflection = FnOpt
Reflection forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts

    isph :: PArg -> (Bool, Int)
isph PArg
arg = case forall t. PArg' t -> t
getTm PArg
arg of
        PTerm
Placeholder -> (Bool
True, forall t. PArg' t -> Int
priority PArg
arg)
        PTerm
tm -> (Bool
False, forall t. PArg' t -> Int
priority PArg
arg)

    mkPat :: StateT (ElabState aux) TC ()
mkPat = do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
               Term
tm <- forall aux. Elab' aux Term
get_term
               case [Name]
hs of
                  (Name
h: [Name]
hs) -> do forall aux. Name -> Elab' aux ()
patvar Name
h; StateT (ElabState aux) TC ()
mkPat
                  [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    elabRec :: PTerm -> ElabD ()
elabRec = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
initElabCtxt forall a. Maybe a
Nothing

    -- | elabE 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 <- forall aux. Elab' aux [Name]
get_recents
        [(Name, ([FailContext], [Name]))]
as <- forall aux. Elab' aux [(Name, ([FailContext], [Name]))]
get_autos
        [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
        -- If any of the autos use variables which have recently been solved,
        -- have another go at solving them now.
        forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\(Name
a, ([FailContext]
failc, [Name]
ns)) ->
                       if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
n -> Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
solved) [Name]
ns Bool -> Bool -> Bool
&& forall a. [a] -> a
head [Name]
hs forall a. Eq a => a -> a -> Bool
/= Name
a
                              then IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
solveAuto IState
ist Name
fn Bool
False (Name
a, [FailContext]
failc)
                              else forall (m :: * -> *) a. Monad m => a -> m a
return ()) [(Name, ([FailContext], [Name]))]
as

        PTerm
apt <- forall {aux}. PTerm -> StateT (ElabState aux) TC PTerm
expandToArity PTerm
t
        PTerm
itm <- if Bool -> Bool
not Bool
pattern then forall {p} {aux}. p -> PTerm -> StateT (ElabState aux) TC PTerm
insertImpLam ElabCtxt
ina PTerm
apt else forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
apt
        PTerm
ct <- forall {p} {aux}. p -> PTerm -> StateT (ElabState aux) TC PTerm
insertCoerce ElabCtxt
ina PTerm
itm
        PTerm
t' <- ElabCtxt -> PTerm -> ElabD PTerm
insertLazy ElabCtxt
ina PTerm
ct
        Term
g <- forall aux. Elab' aux Term
goal
        Term
tm <- forall aux. Elab' aux Term
get_term
        Fails
ps <- forall aux. Elab' aux Fails
get_probs
        [Name]
hs <- forall aux. Elab' aux [Name]
get_holes

        --trace ("Elaborating " ++ show t' ++ " in " ++ show g
        --         ++ "\n" ++ show tm
        --         ++ "\nholes " ++ show hs
        --         ++ "\nproblems " ++ show ps
        --         ++ "\n-----------\n") $
        --trace ("ELAB " ++ show t') $
        Env
env <- forall aux. Elab' aux Env
get_env
        let fc :: FC
fc = String -> FC
fileFC String
"Force"
        forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError (PTerm -> Env -> Err -> Bool
forceErr PTerm
t' Env
env)
            (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc' PTerm
t')
            (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc' (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] (String -> Name
sUN String
"Force"))
                             [forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"t") PTerm
Placeholder Bool
True,
                              forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"a") PTerm
Placeholder Bool
True,
                              forall {t}. t -> PArg' t
pexp PTerm
ct]))

    forceErr :: PTerm -> Env -> Err -> Bool
forceErr PTerm
orig Env
env (CantUnify Bool
_ (Term
t,Maybe Provenance
_) (Term
t',Maybe Provenance
_) Err
_ [(Name, Term)]
_ Int
_)
       | (P NameType
_ (UN Text
ht) Term
_, [Term]
_) <- forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
t),
            Text
ht forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed" = PTerm -> Bool
notDelay PTerm
orig
    forceErr PTerm
orig Env
env (CantUnify Bool
_ (Term
t,Maybe Provenance
_) (Term
t',Maybe Provenance
_) Err
_ [(Name, Term)]
_ Int
_)
       | (P NameType
_ (UN Text
ht) Term
_, [Term]
_) <- forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
t'),
            Text
ht forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed" = PTerm -> Bool
notDelay PTerm
orig
    forceErr PTerm
orig Env
env (InfiniteUnify Name
_ Term
t [(Name, Term)]
_)
       | (P NameType
_ (UN Text
ht) Term
_, [Term]
_) <- forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
t),
            Text
ht forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed" = PTerm -> Bool
notDelay PTerm
orig
    forceErr PTerm
orig Env
env (Elaborating String
_ Name
_ Maybe Term
_ Err
t) = PTerm -> Env -> Err -> Bool
forceErr PTerm
orig Env
env Err
t
    forceErr PTerm
orig Env
env (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err
t) = PTerm -> Env -> Err -> Bool
forceErr PTerm
orig Env
env Err
t
    forceErr PTerm
orig Env
env (At FC
_ Err
t) = PTerm -> Env -> Err -> Bool
forceErr PTerm
orig Env
env Err
t
    forceErr PTerm
orig Env
env Err
t = Bool
False

    notDelay :: PTerm -> Bool
notDelay t :: PTerm
t@(PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg]
_) | Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delay" = Bool
False
    notDelay PTerm
_ = Bool
True

    elab' :: ElabCtxt  -- ^ (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 forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply Raw
RType []
         forall aux. Elab' aux ()
solve
         FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (String -> String -> OutputAnnotation
AnnType String
"Type" String
"The type of types")
    elab' ElabCtxt
ina Maybe FC
fc (PUniverse FC
fc' Universe
u)   =
      do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
UniquenessTypes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist
                  Bool -> Bool -> Bool
|| ElabCtxt -> Bool
e_qq ElabCtxt
ina) forall a b. (a -> b) -> a -> b
$
           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
fc' (forall t. String -> Err' t
Msg String
"You must turn on the UniquenessTypes extension to use UniqueType or AnyType")
         forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Universe -> Raw
RUType Universe
u) []
         forall aux. Elab' aux ()
solve
         FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (String -> String -> OutputAnnotation
AnnType (forall a. Show a => a -> String
show Universe
u) String
"The type of unique types")
--  elab' (_,_,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
              = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
         | Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& ElabCtxt -> Bool
e_nomatching ElabCtxt
ina
              = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
         | Bool
otherwise = do forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Const -> Raw
RConstant Const
c) []
                          forall aux. Elab' aux ()
solve
                          FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (Const -> OutputAnnotation
AnnConst Const
c)
    elab' ElabCtxt
ina Maybe FC
fc (PQuote Raw
r)     = do forall aux. Raw -> Elab' aux ()
fill Raw
r; forall aux. Elab' aux ()
solve
    elab' ElabCtxt
ina Maybe FC
_ (PTrue FC
fc PunInfo
_)   =
       do forall aux. Elab' aux ()
compute
          Term
g <- forall aux. Elab' aux Term
goal
          case Term
g of
            TType UExp
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
unitTy)
            UType Universe
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
unitTy)
            Term
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
unitCon)
    elab' ElabCtxt
ina Maybe FC
fc (PResolveTC (FC String
"HACK" (Int, Int)
_ (Int, Int)
_)) -- for chasing parent interfaces
       = do Term
g <- forall aux. Elab' aux Term
goal; Bool
-> Bool
-> Int
-> Term
-> Name
-> (PTerm -> ElabD ())
-> IState
-> ElabD ()
resolveTC Bool
False Bool
False Int
5 Term
g Name
fn PTerm -> ElabD ()
elabRec IState
ist
    elab' ElabCtxt
ina Maybe FC
fc (PResolveTC FC
fc')
        = do Name
c <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"__interface")
             forall aux. Name -> Elab' aux ()
implementationArg Name
c
    -- 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 forall a. Eq a => a -> a -> Bool
== Name
eqTy, [PTerm
Placeholder, PTerm
Placeholder, PTerm
l, PTerm
r] <- forall a b. (a -> b) -> [a] -> [b]
map forall t. PArg' t -> t
getTm [PArg]
args
       = forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"aqty")
                 forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
                 forall aux. Name -> Elab' aux ()
movelast Name
tyn
                 ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
eqTy)
                              [forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
tyn) Bool
True,
                               forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
tyn) Bool
False,
                               forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r]))
             (do Name
atyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"aqty")
                 Name
btyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"bqty")
                 forall aux. Name -> Raw -> Elab' aux ()
claim Name
atyn Raw
RType
                 forall aux. Name -> Elab' aux ()
movelast Name
atyn
                 forall aux. Name -> Raw -> Elab' aux ()
claim Name
btyn Raw
RType
                 forall aux. Name -> Elab' aux ()
movelast Name
btyn
                 ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
eqTy)
                   [forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
atyn) Bool
True,
                    forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
btyn) Bool
False,
                    forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r]))

    elab' ElabCtxt
ina Maybe FC
_ (PPair FC
fc [FC]
hls PunInfo
_ PTerm
l PTerm
r)
        = do forall aux. Elab' aux ()
compute
             Term
g <- forall aux. Elab' aux Term
goal
             let (Term
tc, [Term]
_) = forall n. TT n -> (TT n, [TT n])
unApply Term
g
             case Term
g of
                TType UExp
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
pairTy)
                                                      [forall {t}. t -> PArg' t
pexp PTerm
l,forall {t}. t -> PArg' t
pexp PTerm
r])
                UType Universe
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
upairTy)
                                                      [forall {t}. t -> PArg' t
pexp PTerm
l,forall {t}. t -> PArg' t
pexp PTerm
r])
                Term
_ -> case Term
tc of
                        P NameType
_ Name
n Term
_ | Name
n forall a. Eq a => a -> a -> Bool
== Name
upairTy
                          -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
upairCon)
                                                [forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") PTerm
Placeholder Bool
False,
                                                 forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") PTerm
Placeholder Bool
False,
                                                 forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r])
                        Term
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
pairCon)
                                                [forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"A") PTerm
Placeholder Bool
False,
                                                 forall {t}. Name -> t -> Bool -> PArg' t
pimp (String -> Name
sUN String
"B") PTerm
Placeholder Bool
False,
                                                 forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r])
    elab' ElabCtxt
ina Maybe FC
_ (PDPair FC
fc [FC]
hls PunInfo
p l :: PTerm
l@(PRef FC
nfc [FC]
hl Name
n) PTerm
t PTerm
r)
            = case PunInfo
p of
                PunInfo
IsType -> ElabD ()
asType
                PunInfo
IsTerm -> ElabD ()
asValue
                PunInfo
TypeOrTerm ->
                   do forall aux. Elab' aux ()
compute
                      Term
g <- forall aux. Elab' aux Term
goal
                      case Term
g of
                         TType UExp
_ -> ElabD ()
asType
                         Term
_ -> ElabD ()
asValue
         where asType :: ElabD ()
asType = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [FC]
hls Name
sigmaTy)
                                        [forall {t}. t -> PArg' t
pexp PTerm
t,
                                         forall {t}. t -> PArg' t
pexp (FC -> Name -> FC -> PTerm -> PTerm -> PTerm
PLam FC
fc Name
n FC
nfc PTerm
Placeholder PTerm
r)])
               asValue :: ElabD ()
asValue = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
sigmaCon)
                                         [forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"a") PTerm
t Bool
False,
                                          forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"P") PTerm
Placeholder Bool
True,
                                          forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r])

    elab' ElabCtxt
ina Maybe FC
_ (PDPair FC
fc [FC]
hls PunInfo
p PTerm
l PTerm
t PTerm
r) = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [FC]
hls Name
sigmaCon)
                                                  [forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"a") PTerm
t Bool
False,
                                                   forall {t}. Name -> t -> Bool -> PArg' t
pimp (Int -> String -> Name
sMN Int
0 String
"P") PTerm
Placeholder Bool
True,
                                                   forall {t}. t -> PArg' t
pexp PTerm
l, forall {t}. t -> PArg' t
pexp PTerm
r])
    elab' ElabCtxt
ina Maybe FC
fc (PAlternative [(Name, Name)]
ms (ExactlyOne Bool
delayok) [PTerm]
as)
        = do [PTerm]
as_pruned <- forall {aux}. [PTerm] -> StateT (ElabState aux) TC [PTerm]
doPrune [PTerm]
as
             -- Finish the mkUniqueNames job with the pruned set, rather than
             -- the full set.
             [Name]
uns <- forall aux. Elab' aux [Name]
get_usedns
             let as' :: [PTerm]
as' = forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> [(Name, Name)] -> PTerm -> PTerm
mkUniqueNames ([Name]
uns forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, Name)]
ms) [(Name, Name)]
ms) [PTerm]
as_pruned
             ~(Name
h : [Name]
hs) <- forall aux. Elab' aux [Name]
get_holes
             Term
ty <- forall aux. Elab' aux Term
goal
             case [PTerm]
as' of
                  [] -> do [Name]
hds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {aux}. PTerm -> StateT (ElabState aux) TC Name
showHd [PTerm]
as
                           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. [Name] -> Err' t
NoValidAlts [Name]
hds
                  [PTerm
x] -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x
                  -- If there's options, try now, and if that fails, postpone
                  -- to later.
                  [PTerm]
_ -> forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError forall {t}. Err' t -> Bool
isAmbiguous
                           (do [Name]
hds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {aux}. PTerm -> StateT (ElabState aux) TC Name
showHd [PTerm]
as'
                               forall aux a. [(Elab' aux a, Name)] -> Elab' aux a
tryAll (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc) [PTerm]
as')
                                           [Name]
hds))
                        (do forall aux. Name -> Elab' aux ()
movelast Name
h
                            Int -> ElabD () -> ElabD ()
delayElab Int
5 forall a b. (a -> b) -> a -> b
$ do
                              [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
                              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
h forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$ do
                                  forall aux. Name -> Elab' aux ()
focus Name
h
                                  [PTerm]
as'' <- forall {aux}. [PTerm] -> StateT (ElabState aux) TC [PTerm]
doPrune [PTerm]
as'
                                  case [PTerm]
as'' of
                                       [PTerm
x] -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x
                                       [PTerm]
_ -> do [Name]
hds <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {aux}. PTerm -> StateT (ElabState aux) TC Name
showHd [PTerm]
as''
                                               forall aux a. Bool -> [(Elab' aux a, Name)] -> Elab' aux a
tryAll' Bool
False (forall a b. [a] -> [b] -> [(a, b)]
zip (forall a b. (a -> b) -> [a] -> [b]
map (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc) [PTerm]
as'')
                                                                  [Name]
hds))
        where showHd :: PTerm -> StateT (ElabState aux) TC Name
showHd (PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg
_, PArg
_, PArg
arg])
                 | Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delay" = PTerm -> StateT (ElabState aux) TC Name
showHd (forall t. PArg' t -> t
getTm PArg
arg)
              showHd (PApp FC
_ (PRef FC
_ [FC]
_ Name
n) [PArg]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
              showHd (PRef FC
_ [FC]
_ Name
n) = forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
              showHd (PApp FC
_ PTerm
h [PArg]
_) = PTerm -> StateT (ElabState aux) TC Name
showHd PTerm
h
              showHd (PHidden PTerm
h) = PTerm -> StateT (ElabState aux) TC Name
showHd PTerm
h
              showHd PTerm
x = forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"_") -- We probably should do something better than this here

              doPrune :: [PTerm] -> StateT (ElabState aux) TC [PTerm]
doPrune [PTerm]
as =
                  do forall aux. Elab' aux ()
compute -- to get 'Delayed' if it's there
                     Term
ty <- forall aux. Elab' aux Term
goal
                     Context
ctxt <- forall aux. Elab' aux Context
get_context
                     Env
env <- forall aux. Elab' aux Env
get_env
                     let ty' :: Term
ty' = Term -> Term
unDelay Term
ty
                     let (Term
tc, [Term]
_) = forall n. TT n -> (TT n, [TT n])
unApply Term
ty'
                     forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Bool -> Env -> Term -> Term -> IState -> [PTerm] -> [PTerm]
pruneByType Bool
eimpossible Env
env Term
tc Term
ty' IState
ist [PTerm]
as

              unDelay :: Term -> Term
unDelay Term
t | (P NameType
_ (UN Text
l) Term
_, [Term
_, Term
arg]) <- forall n. TT n -> (TT n, [TT n])
unApply Term
t,
                          Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed" = Term -> Term
unDelay Term
arg
                        | Bool
otherwise = Term
t

              isAmbiguous :: Err' t -> Bool
isAmbiguous (CantResolveAlts [Name]
_) = Bool
delayok
              isAmbiguous (Elaborating String
_ Name
_ Maybe t
_ Err' t
e) = Err' t -> Bool
isAmbiguous Err' t
e
              isAmbiguous (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err' t
e) = Err' t -> Bool
isAmbiguous Err' t
e
              isAmbiguous (At FC
_ Err' t
e) = Err' t -> Bool
isAmbiguous Err' t
e
              isAmbiguous Err' t
_ = Bool
False

    elab' ElabCtxt
ina Maybe FC
fc (PAlternative [(Name, Name)]
ms PAltType
FirstSuccess [PTerm]
as_in)
        = do -- finish the mkUniqueNames job
             [Name]
uns <- forall aux. Elab' aux [Name]
get_usedns
             let as :: [PTerm]
as = forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> [(Name, Name)] -> PTerm -> PTerm
mkUniqueNames ([Name]
uns forall a. [a] -> [a] -> [a]
++ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, Name)]
ms) [(Name, Name)]
ms) [PTerm]
as_in
             [PTerm] -> ElabD ()
trySeq [PTerm]
as
        where -- 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
                                    forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' ElabD ()
e1 (forall {a}. StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' ElabD ()
e1 [PTerm]
xs) Bool
True
              trySeq [] = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Nothing to try in sequence"
              trySeq' :: StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' StateT (ElabState EState) TC a
deferr [] = do StateT (ElabState EState) TC a
deferr; forall aux. Elab' aux ()
unifyProblems
              trySeq' StateT (ElabState EState) TC a
deferr (PTerm
x : [PTerm]
xs)
                  = forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (forall aux a. Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
tryCatch (do ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x
                                       IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
False
                                       forall aux. Elab' aux ()
unifyProblems)
                             (\Err
_ -> StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' StateT (ElabState EState) TC a
deferr []))
                         (StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' StateT (ElabState EState) TC a
deferr [PTerm]
xs) Bool
True
    elab' ElabCtxt
ina Maybe FC
fc (PAlternative [(Name, Name)]
ms PAltType
TryImplicit (PTerm
orig : [PTerm]
alts)) = do
        Env
env <- forall aux. Elab' aux Env
get_env
        forall aux. Elab' aux ()
compute
        Term
ty <- forall aux. Elab' aux Term
goal
        let doelab :: ElabD ()
doelab = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
orig
        forall aux a. Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
tryCatch ElabD ()
doelab
            (\Err
err ->
                if forall {t}. Err' t -> Bool
recoverableErr Err
err
                   then -- 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
                         [] -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail Err
err
                         [PTerm]
alts' -> do
                             forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc ([(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms (Bool -> PAltType
ExactlyOne Bool
False) [PTerm]
alts'))
                                  (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail Err
err) -- take error from original if all fail
                                  Bool
True
                   else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail Err
err)
      where
        recoverableErr :: Err' t -> Bool
recoverableErr (CantUnify Bool
_ (t, Maybe Provenance)
_ (t, Maybe Provenance)
_ Err' t
_ [(Name, t)]
_ Int
_) = Bool
True
        recoverableErr (TooManyArguments Name
_) = Bool
False
        recoverableErr (CantSolveGoal t
_ [(Name, t)]
_) = Bool
False
        recoverableErr (CantResolveAlts [Name]
_) = Bool
False
        recoverableErr (NoValidAlts [Name]
_) = Bool
True
        recoverableErr (ProofSearchFail (Msg String
_)) = Bool
True
        recoverableErr (ProofSearchFail Err' t
_) = Bool
False
        recoverableErr (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err' t
e) = Err' t -> Bool
recoverableErr Err' t
e
        recoverableErr (At FC
_ Err' t
e) = Err' t -> Bool
recoverableErr Err' t
e
        recoverableErr (ElabScriptDebug [ErrorReportPart]
_ t
_ [(Name, t, [(Name, Binder t)])]
_) = Bool
False
        recoverableErr Err' t
_ = Bool
True

        pruneAlts :: Err -> [PTerm] -> Env -> [PTerm]
pruneAlts (CantUnify Bool
_ (Term
inc, Maybe Provenance
_) (Term
outc, Maybe Provenance
_) Err
_ [(Name, Term)]
_ Int
_) [PTerm]
alts Env
env
            = case forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
inc) of
                   (P (TCon Int
_ Int
_) Name
n Term
_, [Term]
_) -> forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Env -> PTerm -> Bool
hasArg Name
n Env
env) [PTerm]
alts
                   (Constant Const
_, [Term]
_) -> [PTerm]
alts
                   (Term, [Term])
_ -> forall a. (a -> Bool) -> [a] -> [a]
filter PTerm -> Bool
isLend [PTerm]
alts -- 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
_ = 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty)) in
                                   forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (forall {a}. Eq a => a -> TT a -> Bool
fnIs Name
n) [Term]
args
                    Maybe Term
Nothing -> Bool
False
        hasArg Name
n Env
env (PAlternative [(Name, Name)]
_ PAltType
_ [PTerm]
as) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> Env -> PTerm -> Bool
hasArg Name
n Env
env) [PTerm]
as
        hasArg Name
n Env
_ PTerm
tm = Bool
False

        isLend :: PTerm -> Bool
isLend (PApp FC
_ (PRef FC
_ [FC]
_ Name
l) [PArg]
_) = Name
l forall a. Eq a => a -> a -> Bool
== Name -> [String] -> Name
sNS (String -> Name
sUN String
"lend") [String
"Ownership"]
        isLend PTerm
_ = Bool
False

        fnIs :: a -> TT a -> Bool
fnIs a
n TT a
ty = case forall n. TT n -> (TT n, [TT n])
unApply TT a
ty of
                         (P NameType
_ a
n' TT a
_, [TT a]
_) -> a
n forall a. Eq a => a -> a -> Bool
== a
n'
                         (TT a, [TT a])
_ -> Bool
False

    elab' ElabCtxt
ina Maybe FC
_ (PPatvar FC
fc Name
n) | Bool
bindfree
        = do forall aux. Name -> Elab' aux ()
patvar Name
n
             forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
             FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
--    elab' (_, _, 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)
              = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
      | Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ec) Bool -> Bool -> Bool
&& ElabCtxt -> Bool
e_nomatching ElabCtxt
ec
              = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
      | (Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform Bool -> Bool -> Bool
|| (Bool
bindfree Bool -> Bool -> Bool
&& Name -> Bool
bindable Name
n)) Bool -> Bool -> Bool
&& Bool -> Bool
not (Name -> Bool
inparamBlock Name
n) Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ec)
        = do Term
ty <- forall aux. Elab' aux Term
goal
             FC -> Name -> Term -> ElabD ()
testImplicitWarning FC
fc Name
n Term
ty
             let ina :: Bool
ina = ElabCtxt -> Bool
e_inarg ElabCtxt
ec
             Context
ctxt <- forall aux. Elab' aux Context
get_context
             Env
env <- forall aux. Elab' aux Env
get_env

             -- 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 forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc forall a b. (a -> b) -> a -> b
$
                      do forall aux. Name -> Elab' aux ()
patvar Name
n
                         forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
                         FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
               else if Bool
defined -- 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 forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
n) []
                                    OutputAnnotation
annot <- Name -> ElabD OutputAnnotation
findHighlight Name
n
                                    forall aux. Elab' aux ()
solve
                                    FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc OutputAnnotation
annot)
                                (do forall aux. Name -> Elab' aux ()
patvar Name
n
                                    forall aux. (Term -> Term) -> Elab' aux ()
update_term Term -> Term
liftPats
                                    FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False))
      where inparamBlock :: Name -> Bool
inparamBlock Name
n = case forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
n (ElabInfo -> Ctxt [Name]
inblock ElabInfo
info) of
                                [] -> Bool
False
                                [(Name, [Name])]
_ -> Bool
True
            bindable :: Name -> Bool
bindable (NS Name
_ [Text]
_) = Bool
False
            bindable (MN Int
_ Text
_) = Bool
True
            bindable Name
n = Name -> Bool
implicitable Name
n Bool -> Bool -> Bool
&& Bool
autoimpls
    elab' ElabCtxt
ina Maybe FC
_ f :: PTerm
f@(PInferRef FC
fc [FC]
hls Name
n) = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
NoFC PTerm
f [])
    elab' ElabCtxt
ina Maybe FC
fc' tm :: PTerm
tm@(PRef FC
fc [FC]
hls Name
n)
          | Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_intype ElabCtxt
ina)
            Bool -> Bool -> Bool
&& Name -> Context -> Bool
isTConName Name
n (IState -> Context
tt_ctxt IState
ist)
              = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
          | Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& ElabCtxt -> Bool
e_nomatching ElabCtxt
ina
              = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
          | Bool
otherwise = ElabCtxt -> Maybe FC -> FC -> [FC] -> Name -> PTerm -> ElabD ()
elabRef ElabCtxt
ina Maybe FC
fc' FC
fc [FC]
hls Name
n PTerm
tm
    elab' ElabCtxt
ina Maybe FC
_ (PLam FC
_ Name
_ FC
_ PTerm
_ PTerm
PImpossible) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Only pattern-matching lambdas can be impossible"
    elab' ElabCtxt
ina Maybe FC
_ (PLam FC
fc Name
n FC
nfc PTerm
Placeholder PTerm
sc)
          = do -- if n is a type constructor name, this makes no sense...
               Context
ctxt <- forall aux. Elab' aux Context
get_context
               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Context -> Bool
isTConName Name
n Context
ctxt) forall a b. (a -> b) -> a -> b
$
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail (forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Can't use type constructor " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" here")
               forall aux. Name -> Elab' aux ()
checkPiGoal Name
n
               forall aux. Elab' aux ()
attack; forall aux. Maybe Name -> Elab' aux ()
intro (forall a. a -> Maybe a
Just Name
n);
               forall aux. Name -> Elab' aux ()
addPSname Name
n -- okay for proof search
               -- trace ("------ intro " ++ show n ++ " ---- \n" ++ show ptm)
               ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True } ) (forall a. a -> Maybe a
Just FC
fc) PTerm
sc; forall aux. Elab' aux ()
solve
               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
    elab' ElabCtxt
ec Maybe FC
_ (PLam FC
fc Name
n FC
nfc PTerm
ty PTerm
sc)
          = do Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"lamty")
               -- if n is a type constructor name, this makes no sense...
               Context
ctxt <- forall aux. Elab' aux Context
get_context
               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name -> Context -> Bool
isTConName Name
n Context
ctxt) forall a b. (a -> b) -> a -> b
$
                    forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail (forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Can't use type constructor " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" here")
               forall aux. Name -> Elab' aux ()
checkPiGoal Name
n
               forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
               forall aux. Name -> Elab' aux ()
explicit Name
tyn
               forall aux. Elab' aux ()
attack
               Term
ptm <- forall aux. Elab' aux Term
get_term
               [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
               forall aux. Raw -> Maybe Name -> Elab' aux ()
introTy (Name -> Raw
Var Name
tyn) (forall a. a -> Maybe a
Just Name
n)
               forall aux. Name -> Elab' aux ()
addPSname Name
n -- okay for proof search
               forall aux. Name -> Elab' aux ()
focus Name
tyn

               ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ec { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
ty
               ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ec { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
sc
               forall aux. Elab' aux ()
solve
               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
    elab' ElabCtxt
ina Maybe FC
fc (PPi Plicity
p Name
n FC
nfc PTerm
Placeholder PTerm
sc)
          = do forall aux. Elab' aux ()
attack;
               case Plicity -> RigCount
pcount Plicity
p of
                    RigCount
RigW -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    RigCount
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
LinearTypes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist
                                       Bool -> Bool -> Bool
|| ElabCtxt -> Bool
e_qq ElabCtxt
ina) forall a b. (a -> b) -> a -> b
$
                           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
nfc (forall t. String -> Err' t
Msg String
"You must turn on the LinearTypes extension to use a count")
               forall aux.
Name -> RigCount -> Maybe ImplicitInfo -> Name -> Elab' aux ()
arg Name
n (Plicity -> RigCount
pcount Plicity
p) (Plicity -> Maybe ImplicitInfo
is_scoped Plicity
p) (Int -> String -> Name
sMN Int
0 String
"phTy")
               Plicity -> Name -> ElabD ()
addAutoBind Plicity
p Name
n
               forall aux. Name -> Elab' aux ()
addPSname Name
n -- okay for proof search
               ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True }) Maybe FC
fc PTerm
sc
               forall aux. Elab' aux ()
solve
               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
    elab' ElabCtxt
ina Maybe FC
fc (PPi Plicity
p Name
n FC
nfc PTerm
ty PTerm
sc)
          = do forall aux. Elab' aux ()
attack; Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"piTy")
               forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
               Name
n' <- case Name
n of
                        MN Int
_ Text
_ -> forall aux. Name -> Elab' aux Name
unique_hole Name
n
                        Name
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Name
n
               case Plicity -> RigCount
pcount Plicity
p of
                    RigCount
RigW -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                    RigCount
_ -> forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
LinearTypes forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist
                                       Bool -> Bool -> Bool
|| ElabCtxt -> Bool
e_qq ElabCtxt
ina) forall a b. (a -> b) -> a -> b
$
                           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
nfc (forall t. String -> Err' t
Msg String
"You must turn on the LinearTypes extension to use a linear argument")
               forall aux.
Name -> RigCount -> Maybe ImplicitInfo -> Raw -> Elab' aux ()
forAll Name
n' (Plicity -> RigCount
pcount Plicity
p) (Plicity -> Maybe ImplicitInfo
is_scoped Plicity
p) (Name -> Raw
Var Name
tyn)
               Plicity -> Name -> ElabD ()
addAutoBind Plicity
p Name
n'
               forall aux. Name -> Elab' aux ()
addPSname Name
n' -- okay for proof search
               forall aux. Name -> Elab' aux ()
focus Name
tyn
               let ec' :: ElabCtxt
ec' = ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True }
               ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ec' Maybe FC
fc PTerm
ty
               ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ec' Maybe FC
fc PTerm
sc
               forall aux. Elab' aux ()
solve
               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
    elab' ElabCtxt
ina Maybe FC
_ tm :: PTerm
tm@(PLet FC
fc RigCount
rig Name
n FC
nfc PTerm
ty PTerm
val PTerm
sc)
          = do forall aux. Elab' aux ()
attack
               [Name]
ivs <- forall aux. Elab' aux [Name]
get_implementations
               Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
               forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
               Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
               forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
               forall aux. Name -> Elab' aux ()
explicit Name
valn
               forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n RigCount
rig (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
               forall aux. Name -> Elab' aux ()
addPSname Name
n
               case PTerm
ty of
                   PTerm
Placeholder -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                   PTerm
_ -> do forall aux. Name -> Elab' aux ()
focus Name
tyn
                           forall aux. Name -> Elab' aux ()
explicit Name
tyn
                           ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True })
                                 (forall a. a -> Maybe a
Just FC
fc) PTerm
ty
               forall aux. Name -> Elab' aux ()
focus Name
valn
               ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True })
                     (forall a. a -> Maybe a
Just FC
fc) PTerm
val
               [Name]
ivs' <- forall aux. Elab' aux [Name]
get_implementations
               Env
env <- forall aux. Elab' aux Env
get_env
               ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
sc
               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform)) forall a b. (a -> b) -> a -> b
$
                   forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> do forall aux. Name -> Elab' aux ()
focus Name
n
                                   Term
g <- forall aux. Elab' aux Term
goal
                                   [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
                                   if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Name
n -> Name
n forall a. Eq a => a -> a -> Bool
== Name
tyn Bool -> Bool -> Bool
|| Bool -> Bool
not (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs)) (forall n. Eq n => TT n -> [n]
freeNames Term
g)
                                    then forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError (ElabMode -> Err -> Bool
tcRecoverable ElabMode
emode)
                                           (Bool
-> Bool
-> Int
-> Term
-> Name
-> (PTerm -> ElabD ())
-> IState
-> ElabD ()
resolveTC Bool
True Bool
False Int
10 Term
g Name
fn PTerm -> ElabD ()
elabRec IState
ist)
                                           (forall aux. Name -> Elab' aux ()
movelast Name
n)
                                    else forall aux. Name -> Elab' aux ()
movelast Name
n)
                         ([Name]
ivs' forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
ivs)
               -- HACK: If the name leaks into its type, it may leak out of
               -- scope outside, so substitute in the outer scope.
               forall aux. Name -> Term -> Elab' aux ()
expandLet Name
n (case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
                                 Just (Let RigCount
rig Term
t Term
v) -> Term
v
                                 Maybe (Binder Term)
other -> forall a. HasCallStack => String -> a
error (String
"Value not a let binding: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Maybe (Binder Term)
other))
               forall aux. Elab' aux ()
solve
               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
    elab' ElabCtxt
ina Maybe FC
_ (PGoal FC
fc PTerm
r Name
n PTerm
sc) = do
         Term
rty <- forall aux. Elab' aux Term
goal
         forall aux. Elab' aux ()
attack
         Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
         forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
         Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
         forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
         forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
         forall aux. Name -> Elab' aux ()
focus Name
valn
         ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True, e_intype :: Bool
e_intype = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc PTerm
r [forall {t}. t -> PArg' t
pexp (IState -> Term -> PTerm
delab IState
ist Term
rty)])
         Env
env <- forall aux. Elab' aux Env
get_env
         forall aux. Name -> Elab' aux ()
computeLet Name
n
         ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
sc
         forall aux. Elab' aux ()
solve
--          elab' 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 <- forall aux. Elab' aux Term
goal
         [Name]
ds <- forall aux. Elab' aux [Name]
get_deferred
         Context
ctxt <- forall aux. Elab' aux Context
get_context
         -- make a function type a -> b -> c -> ... -> rty for the
         -- new function name
         Env
env <- forall aux. Elab' aux Env
get_env
         [(Name, (Bool, Raw))]
argTys <- forall {aux}.
Env -> [PArg] -> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
claimArgTys Env
env [PArg]
args
         Name
fn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"inf_fn")
         let fty :: Raw
fty = forall {a}. [(Name, (a, Raw))] -> Term -> Raw
fnTy [(Name, (Bool, Raw))]
argTys Term
rty
--             trace (show (ptm, map fst argTys)) $ focus fn
            -- build and defer the function application
         forall aux. Elab' aux ()
attack; forall aux. Name -> Raw -> [Name] -> Elab' aux ()
deferType (Name -> Name
mkN Name
f) Raw
fty (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, (Bool, Raw))]
argTys); forall aux. Elab' aux ()
solve
         -- elaborate the arguments, to unify their types. They all have to
         -- be explicit.
         forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {b}. ((Name, (Bool, b)), PArg) -> ElabD ()
elabIArg (forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, (Bool, Raw))]
argTys [PArg]
args)
       where claimArgTys :: Env -> [PArg] -> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
claimArgTys Env
env [] = forall (m :: * -> *) a. Monad m => a -> m a
return []
             claimArgTys Env
env (PArg
arg : [PArg]
xs) | Just Name
n <- Env -> PTerm -> Maybe Name
localVar Env
env (forall t. PArg' t -> t
getTm PArg
arg)
                                  = do Term
nty <- forall aux. Raw -> Elab' aux Term
get_type (Name -> Raw
Var Name
n)
                                       [(Name, (Bool, Raw))]
ans <- Env -> [PArg] -> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
claimArgTys Env
env [PArg]
xs
                                       forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
n, (Bool
False, Term -> Raw
forget Term
nty)) forall a. a -> [a] -> [a]
: [(Name, (Bool, Raw))]
ans)
             claimArgTys Env
env (PArg
_ : [PArg]
xs)
                                  = do Name
an <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"inf_argTy")
                                       Name
aval <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"inf_arg")
                                       forall aux. Name -> Raw -> Elab' aux ()
claim Name
an Raw
RType
                                       forall aux. Name -> Raw -> Elab' aux ()
claim Name
aval (Name -> Raw
Var Name
an)
                                       [(Name, (Bool, Raw))]
ans <- Env -> [PArg] -> StateT (ElabState aux) TC [(Name, (Bool, Raw))]
claimArgTys Env
env [PArg]
xs
                                       forall (m :: * -> *) a. Monad m => a -> m a
return ((Name
aval, (Bool
True, (Name -> Raw
Var Name
an))) forall a. a -> [a] -> [a]
: [(Name, (Bool, Raw))]
ans)
             fnTy :: [(Name, (a, Raw))] -> Term -> Raw
fnTy [] Term
ret  = Term -> Raw
forget Term
ret
             fnTy ((Name
x, (a
_, Raw
xt)) : [(Name, (a, Raw))]
xs) Term
ret = Name -> Binder Raw -> Raw -> Raw
RBind Name
x (forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW forall a. Maybe a
Nothing Raw
xt Raw
RType) ([(Name, (a, Raw))] -> Term -> Raw
fnTy [(Name, (a, Raw))]
xs Term
ret)

             localVar :: Env -> PTerm -> Maybe Name
localVar Env
env (PRef FC
_ [FC]
_ Name
x)
                           = case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
x Env
env of
                                  Just Binder Term
_ -> forall a. a -> Maybe a
Just Name
x
                                  Maybe (Binder Term)
_ -> forall a. Maybe a
Nothing
             localVar Env
env PTerm
_ = forall a. Maybe a
Nothing

             elabIArg :: ((Name, (Bool, b)), PArg) -> ElabD ()
elabIArg ((Name
n, (Bool
True, b
ty)), PArg
def) =
               do forall aux. Name -> Elab' aux ()
focus Name
n; ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) (forall t. PArg' t -> t
getTm PArg
def)
             elabIArg ((Name, (Bool, b)), PArg)
_ = forall (m :: * -> *) a. Monad m => a -> m a
return () -- 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 forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
                             [(Name
n, [PArg]
args)] -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Bool
True) [PArg]
args)
                             [(Name, [PArg])]
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail (forall t. Name -> Err' t
NoSuchVariable Name
fn)
            [(Name, Name)]
ns <- forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
match_apply (Name -> Raw
Var Name
fn') (forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x,Int
0)) [Bool]
imps)
            forall aux. Elab' aux ()
solve
    -- 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
              = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
      | Bool
otherwise = ElabD [ImplicitInfo] -> ElabD ()
implicitApp forall a b. (a -> b) -> a -> b
$
         do Env
env <- forall aux. Elab' aux Env
get_env
            Term
ty <- forall aux. Elab' aux Term
goal
            Term
fty <- forall aux. Raw -> Elab' aux Term
get_type (Name -> Raw
Var Name
f)
            Context
ctxt <- forall aux. Elab' aux Context
get_context
            let dataCon :: Bool
dataCon = Name -> Context -> Bool
isDConName Name
f Context
ctxt
            OutputAnnotation
annot <- Name -> ElabD OutputAnnotation
findHighlight Name
f
            [Maybe Name]
knowns_m <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM forall {m :: * -> *} {t}. Monad m => PArg' t -> m (Maybe Name)
getKnownImplicit [PArg]
args_in
            let knowns :: [Name]
knowns = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe forall a. a -> a
id [Maybe Name]
knowns_m
            [PArg]
args <- FC -> Name -> [Name] -> Term -> [PArg] -> ElabD [PArg]
insertScopedImps FC
fc Name
f [Name]
knowns (Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
fty) [PArg]
args_in

            let unmatchableArgs :: [Bool]
unmatchableArgs = if Bool
pattern
                                     then Context -> Name -> [Bool]
getUnmatchable (IState -> Context
tt_ctxt IState
ist) Name
f
                                     else []
--             trace ("BEFORE " ++ show f ++ ": " ++ show ty) $
            forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_intype ElabCtxt
ina)
                          Bool -> Bool -> Bool
&& Name -> Context -> Bool
isTConName Name
f (IState -> Context
tt_ctxt IState
ist)) forall a b. (a -> b) -> a -> b
$
              forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTerm
tm)
--             trace (show (f, args_in, args)) $
            if (Name
f forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
env Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [PArg]
args forall a. Eq a => a -> a -> Bool
== Int
1 Bool -> Bool -> Bool
&& forall (t :: * -> *) a. Foldable t => t a -> Int
length [PArg]
args_in forall a. Eq a => a -> a -> Bool
== Int
1)
               then -- simple app, as below
                    do forall aux.
Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
simple_app Bool
False
                                  (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_isfn :: Bool
e_isfn = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
ffc [FC]
hls Name
f))
                                  (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True,
                                                e_guarded :: Bool
e_guarded = Bool
dataCon }) (forall a. a -> Maybe a
Just FC
fc) (forall t. PArg' t -> t
getTm (forall a. [a] -> a
head [PArg]
args)))
                                  (forall a. Show a => a -> String
show PTerm
tm)
                       forall aux. Elab' aux ()
solve
                       forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FC -> OutputAnnotation -> ElabD ()
highlightSource) forall a b. (a -> b) -> a -> b
$
                         (FC
ffc, OutputAnnotation
annot) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\FC
f -> (FC
f, OutputAnnotation
annot)) [FC]
hls
                       forall (m :: * -> *) a. Monad m => a -> m a
return []
               else
                 do [Name]
ivs <- forall aux. Elab' aux [Name]
get_implementations
                    Fails
ps <- forall aux. Elab' aux Fails
get_probs
                    -- HACK: we shouldn't resolve interfaces if we're defining an implementation
                    -- function or default definition.
                    let isinf :: Bool
isinf = Name
f 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 forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
f (IState -> Ctxt InterfaceInfo
idris_interfaces IState
ist) of
                        [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        [InterfaceInfo]
_ -> do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {aux}. PTerm -> Elab' aux ()
setInjective (forall a b. (a -> b) -> [a] -> [b]
map forall t. PArg' t -> t
getTm [PArg]
args)
                                -- maybe more things are solvable now
                                forall aux. Elab' aux ()
unifyProblems
--                    trace ("args is " ++ show args) $ return ()
                    [(Name, Name)]
ns <- forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
f) (forall a b. (a -> b) -> [a] -> [b]
map PArg -> (Bool, Int)
isph [PArg]
args)
--                    trace ("ns is " ++ show ns) $ return ()
                    -- mark any interface arguments as injective
--                     when (not pattern) $
                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall aux. Name -> Elab' aux ()
checkIfInjective (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [(Name, Name)]
ns)
                    forall aux. Elab' aux ()
unifyProblems -- try again with the new information,
                                  -- to help with disambiguation
                    Bool
ulog <- forall aux. Elab' aux Bool
getUnifyLog

                    OutputAnnotation
annot <- Name -> ElabD OutputAnnotation
findHighlight Name
f
                    forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FC -> OutputAnnotation -> ElabD ()
highlightSource) forall a b. (a -> b) -> a -> b
$
                      (FC
ffc, OutputAnnotation
annot) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\FC
f -> (FC
f, OutputAnnotation
annot)) [FC]
hls

                    IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist (ElabCtxt
ina { e_inarg :: Bool
e_inarg = ElabCtxt -> Bool
e_inarg ElabCtxt
ina Bool -> Bool -> Bool
|| Bool -> Bool
not Bool
isinf,
                                        e_guarded :: Bool
e_guarded = Bool
dataCon })
                           [] FC
fc Bool
False Name
f
                             (forall a b. [a] -> [b] -> [(a, b)]
zip [(Name, Name)]
ns ([Bool]
unmatchableArgs forall a. [a] -> [a] -> [a]
++ forall a. a -> [a]
repeat Bool
False))
                             (Name
f forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
"Force")
                             (forall a b. (a -> b) -> [a] -> [b]
map (\PArg
x -> forall t. PArg' t -> t
getTm PArg
x) [PArg]
args) -- TODO: remove this False arg
                    [ImplicitInfo]
imp <- if (ElabCtxt -> Bool
e_isfn ElabCtxt
ina) then
                              do Term
guess <- forall aux. Elab' aux Term
get_guess
                                 Env
env <- forall aux. Elab' aux Env
get_env
                                 case [Name] -> Term -> Maybe Raw
safeForgetEnv (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
env) Term
guess of
                                      Maybe Raw
Nothing ->
                                         forall (m :: * -> *) a. Monad m => a -> m a
return []
                                      Just Raw
rguess -> do
                                         Term
gty <- forall aux. Raw -> Elab' aux Term
get_type Raw
rguess
                                         let ty_n :: Term
ty_n = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
gty
                                         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall {n}. TT n -> [ImplicitInfo]
getReqImps Term
ty_n
                              else forall (m :: * -> *) a. Monad m => a -> m a
return []
                    -- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return [ImplicitInfo]
rs -- quit, try again
                         [ImplicitInfo]
_ -> do forall aux. Elab' aux ()
solve
                                 [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
                                 [Name]
ivs' <- forall aux. Elab' aux [Name]
get_implementations
                                 -- Attempt to resolve any interfaces which have 'complete' types,
                                 -- i.e. no holes in them
                                 forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
pattern Bool -> Bool -> Bool
|| (ElabCtxt -> Bool
e_inarg ElabCtxt
ina Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
tcgen)) forall a b. (a -> b) -> a -> b
$
                                    forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> do forall aux. Name -> Elab' aux ()
focus Name
n
                                                    Term
g <- forall aux. Elab' aux Term
goal
                                                    Env
env <- forall aux. Elab' aux Env
get_env
                                                    [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
                                                    if forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Name
n -> Bool -> Bool
not (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs)) (forall n. Eq n => TT n -> [n]
freeNames Term
g)
                                                     then forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError (ElabMode -> Err -> Bool
tcRecoverable ElabMode
emode)
                                                              (Bool
-> Bool
-> Int
-> Term
-> Name
-> (PTerm -> ElabD ())
-> IState
-> ElabD ()
resolveTC Bool
False Bool
False Int
10 Term
g Name
fn PTerm -> ElabD ()
elabRec IState
ist)
                                                              (forall aux. Name -> Elab' aux ()
movelast Name
n)
                                                     else forall aux. Name -> Elab' aux ()
movelast Name
n)
                                          ([Name]
ivs' forall a. Eq a => [a] -> [a] -> [a]
\\ [Name]
ivs)
                                 forall (m :: * -> *) a. Monad m => a -> m a
return []
      where
            -- 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; forall (m :: * -> *) a. Monad m => a -> m a
return ()
              | Bool
otherwise
                = do ElabState EState
s <- forall s (m :: * -> *). MonadState s m => m s
get
                     [ImplicitInfo]
imps <- ElabD [ImplicitInfo]
elab
                     case [ImplicitInfo]
imps of
                          [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          [ImplicitInfo]
es -> do forall s (m :: * -> *). MonadState s m => s -> m ()
put ElabState EState
s
                                   ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
topfc (PTerm -> [ImplicitInfo] -> PTerm
PAppImpl PTerm
tm [ImplicitInfo]
es)

            getKnownImplicit :: PArg' t -> m (Maybe Name)
getKnownImplicit PArg' t
imp
                 | ArgOpt
UnknownImp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall t. PArg' t -> [ArgOpt]
argopts PArg' t
imp
                    = forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing -- lift $ tfail $ UnknownImplicit (pname imp) f
                 | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return (forall a. a -> Maybe a
Just (forall t. PArg' t -> Name
pname PArg' t
imp))

            getReqImps :: TT n -> [ImplicitInfo]
getReqImps (Bind n
x (Pi RigCount
_ (Just ImplicitInfo
i) TT n
ty TT n
_) TT n
sc)
                 = ImplicitInfo
i forall a. a -> [a] -> [a]
: TT n -> [ImplicitInfo]
getReqImps TT n
sc
            getReqImps TT n
_ = []

            checkIfInjective :: Name -> StateT (ElabState aux) TC ()
checkIfInjective Name
n = do
                Env
env <- forall aux. Elab' aux Env
get_env
                case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
                     Maybe (Binder Term)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                     Just Binder Term
b ->
                       case forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env (forall b. Binder b -> b
binderTy Binder Term
b)) of
                            (P NameType
_ Name
c Term
_, [Term]
args) ->
                                case forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
c (IState -> Ctxt InterfaceInfo
idris_interfaces IState
ist) of
                                   Maybe InterfaceInfo
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                   Just InterfaceInfo
ci -> -- interface, set as injective
                                        do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ forall {aux}. Term -> Elab' aux ()
setinjArg (forall {t :: * -> *} {t} {a}.
(Foldable t, Eq t, Num t) =>
t -> t t -> [a] -> [a]
getDets Int
0 (InterfaceInfo -> [Int]
interface_determiners InterfaceInfo
ci) [Term]
args)
                                        -- maybe we can solve more things now...
                                           Bool
ulog <- forall aux. Elab' aux Bool
getUnifyLog
                                           Fails
probs <- forall aux. Elab' aux Fails
get_probs
                                           [Name]
inj <- forall aux. Elab' aux [Name]
get_inj
                                           forall {a}. Bool -> String -> a -> a
traceWhen Bool
ulog (String
"Injective now " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Term]
args forall a. [a] -> [a] -> [a]
++ String
"\nAll: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Name]
inj
                                                            forall a. [a] -> [a] -> [a]
++ String
"\nProblems: " forall a. [a] -> [a] -> [a]
++ Fails -> String
qshow Fails
probs) forall a b. (a -> b) -> a -> b
$
                                             forall aux. Elab' aux ()
unifyProblems
                                           Fails
probs <- forall aux. Elab' aux Fails
get_probs
                                           forall {a}. Bool -> String -> a -> a
traceWhen Bool
ulog (Fails -> String
qshow Fails
probs) forall a b. (a -> b) -> a -> b
$ forall (m :: * -> *) a. Monad m => a -> m a
return ()
                            (Term, [Term])
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

            setinjArg :: Term -> Elab' aux ()
setinjArg (P NameType
_ Name
n Term
_) = forall aux. Name -> Elab' aux ()
setinj Name
n
            setinjArg Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

            getDets :: t -> t t -> [a] -> [a]
getDets t
i t t
ds [] = []
            getDets t
i t t
ds (a
a : [a]
as) | t
i forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t t
ds = a
a forall a. a -> [a] -> [a]
: t -> t t -> [a] -> [a]
getDets (t
i forall a. Num a => a -> a -> a
+ t
1) t t
ds [a]
as
                                  | Bool
otherwise = t -> t t -> [a] -> [a]
getDets (t
i forall a. Num a => a -> a -> a
+ t
1) t t
ds [a]
as

            setInjective :: PTerm -> Elab' aux ()
setInjective (PRef FC
_ [FC]
_ Name
n) = forall aux. Name -> Elab' aux ()
setinj Name
n
            setInjective (PApp FC
_ (PRef FC
_ [FC]
_ Name
n) [PArg]
_) = forall aux. Name -> Elab' aux ()
setinj Name
n
            setInjective PTerm
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    elab' ElabCtxt
ina Maybe FC
_ tm :: PTerm
tm@(PApp FC
fc PTerm
f [PArg
arg]) =
            forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc forall a b. (a -> b) -> a -> b
$
             do forall aux.
Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
simple_app (Bool -> Bool
not forall a b. (a -> b) -> a -> b
$ PTerm -> Bool
headRef PTerm
f)
                           (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_isfn :: Bool
e_isfn = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
f)
                           (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) (forall t. PArg' t -> t
getTm PArg
arg))
                                (forall a. Show a => a -> String
show PTerm
tm)
                forall aux. Elab' aux ()
solve
        where headRef :: PTerm -> Bool
headRef (PRef FC
_ [FC]
_ Name
_) = Bool
True
              headRef (PApp FC
_ PTerm
f [PArg]
_) = PTerm -> Bool
headRef PTerm
f
              headRef (PAlternative [(Name, Name)]
_ PAltType
_ [PTerm]
as) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all PTerm -> Bool
headRef [PTerm]
as
              headRef PTerm
_ = Bool
False

    elab' ElabCtxt
ina Maybe FC
fc (PAppImpl PTerm
f [ImplicitInfo]
es) = do forall {a}. [a] -> ElabD ()
appImpl (forall a. [a] -> [a]
reverse [ImplicitInfo]
es) -- not that we look...
                                      forall aux. Elab' aux ()
solve
        where appImpl :: [a] -> ElabD ()
appImpl [] = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' (ElabCtxt
ina { e_isfn :: Bool
e_isfn = Bool
False }) Maybe FC
fc PTerm
f -- e_isfn not set, so no recursive expansion of implicits
              appImpl (a
e : [a]
es) = forall aux.
Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
simple_app Bool
False
                                            ([a] -> ElabD ()
appImpl [a]
es)
                                            (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder)
                                            (forall a. Show a => a -> String
show PTerm
f)
    elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder
        = do ~(Name
h : [Name]
hs) <- forall aux. Elab' aux [Name]
get_holes
             forall aux. Name -> Elab' aux ()
movelast Name
h
    elab' ElabCtxt
ina Maybe FC
fc (PMetavar FC
nfc Name
n) =
          do Term
ptm <- forall aux. Elab' aux Term
get_term
             -- 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 <- forall aux. Elab' aux Env
get_env
             let unique_used :: [Name]
unique_used = Context -> Term -> [Name]
getUniqueUsed (IState -> Context
tt_ctxt IState
ist) Term
ptm
             let lin_used :: [Name]
lin_used = Context -> Term -> [Name]
getLinearUsed (IState -> Context
tt_ctxt IState
ist) Term
ptm
             let n' :: Name
n' = [String] -> Name -> Name
metavarName (ElabInfo -> [String]
namespace ElabInfo
info) Name
n
             forall aux. Elab' aux ()
attack
             [Name]
psns <- forall aux. Elab' aux [Name]
getPSnames
             Name
n' <- forall aux. [Name] -> [Name] -> Name -> Elab' aux Name
defer [Name]
unique_used [Name]
lin_used Name
n'
             forall aux. Elab' aux ()
solve
             FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n' (forall a. a -> Maybe a
Just NameOutput
MetavarOutput) forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
    elab' ElabCtxt
ina Maybe FC
fc (PProof [PTactic]
ts) = do forall aux. Elab' aux ()
compute; forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
True IState
ist (ElabInfo -> Maybe FC
elabFC ElabInfo
info) Name
fn) [PTactic]
ts
    elab' ElabCtxt
ina Maybe FC
fc (PTactics [PTactic]
ts)
        | Bool -> Bool
not Bool
pattern = do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
False IState
ist Maybe FC
fc Name
fn) [PTactic]
ts
        | Bool
otherwise = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder
    elab' ElabCtxt
ina Maybe FC
fc (PElabError Err
e) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail Err
e
    elab' ElabCtxt
ina Maybe FC
mfc (PRewrite FC
fc Maybe Name
substfn PTerm
rule PTerm
sc Maybe PTerm
newg)
        = (PTerm -> ElabD ())
-> IState
-> FC
-> Maybe Name
-> PTerm
-> PTerm
-> Maybe PTerm
-> ElabD ()
elabRewrite (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
mfc) IState
ist FC
fc Maybe Name
substfn PTerm
rule PTerm
sc Maybe PTerm
newg
    -- 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)
        = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail (forall t. String -> Err' t
Msg String
"No expression for the case to inspect.\nYou need to replace the _ with an expression.")
    elab' ElabCtxt
ina Maybe FC
_ c :: PTerm
c@(PCase FC
fc PTerm
scr [(PTerm, PTerm)]
opts)
        = do forall aux. Elab' aux ()
attack

             Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scty")
             forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
             Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scval")
             Name
scvn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scvar")
             forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
             Env
env <- forall aux. Elab' aux Env
get_env

             let scrnames :: [Name]
scrnames = PTerm -> [Name]
allNamesIn PTerm
scr
             forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
scvn (forall {t :: * -> *} {a} {c}.
(Foldable t, Eq a) =>
t a -> [(a, RigCount, c)] -> RigCount
letrig [Name]
scrnames Env
env) (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)

             -- 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 (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(PTerm, PTerm)]
opts)
             case Maybe PTerm
scrTy of
                  Maybe PTerm
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Just PTerm
ty -> do forall aux. Name -> Elab' aux ()
focus Name
tyn
                                ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc) PTerm
ty

             forall aux. Name -> Elab' aux ()
focus Name
valn
             ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_inarg :: Bool
e_inarg = Bool
True }) (forall a. a -> Maybe a
Just FC
fc) PTerm
scr
             -- Solve any remaining implicits - we need to solve as many
             -- as possible before making the 'case' type
             forall aux. Elab' aux ()
unifyProblems
             forall aux. Bool -> Elab' aux ()
matchProblems Bool
True
             Env
args <- forall aux. Elab' aux Env
get_env
             [(Name, Bool)]
envU <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall {b} {c} {aux}.
Env -> (Name, b, c) -> StateT (ElabState aux) TC (Name, Bool)
getKind Env
args) Env
args

             -- 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 <- forall aux. Elab' aux Term
get_term
             let inOpts :: [Name]
inOpts = (forall a. (a -> Bool) -> [a] -> [a]
filter (forall a. Eq a => a -> a -> Bool
/= Name
scvn) (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
args)) forall a. Eq a => [a] -> [a] -> [a]
\\ (forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PTerm, PTerm)
x -> PTerm -> [Name]
allNamesIn (forall a b. (a, b) -> b
snd (PTerm, PTerm)
x)) [(PTerm, PTerm)]
opts)

             let argsDropped :: [Name]
argsDropped = forall a. (a -> Bool) -> [a] -> [a]
filter (\Name
t -> forall {a}. Eq a => [(a, Bool)] -> a -> Bool
isUnique [(Name, Bool)]
envU Name
t Bool -> Bool -> Bool
|| Env -> Name -> Bool
isNotLift Env
args Name
t)
                                   (forall a. Eq a => [a] -> [a]
nub forall a b. (a -> b) -> a -> b
$ [Name]
scrnames forall a. [a] -> [a] -> [a]
++ forall {a}. TT a -> [a]
inApp Term
ptm forall a. [a] -> [a] -> [a]
++
                                    [Name]
inOpts)
             let lin_used :: [Name]
lin_used = Context -> Term -> [Name]
getLinearUsed (IState -> Context
tt_ctxt IState
ist) Term
ptm

             let args' :: Env
args' = forall a. (a -> Bool) -> [a] -> [a]
filter (\(Name
n, RigCount
_, Binder Term
_) -> Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` [Name]
argsDropped) Env
args

             -- trace (show lin_used ++ "\n" ++ show args ++ "\n" ++ show ptm) attack
             forall aux. Elab' aux ()
attack
             Name
cname' <- forall aux. [Name] -> [Name] -> Name -> Elab' aux Name
defer [Name]
argsDropped [Name]
lin_used (Name -> Name
mkN (FC -> Name -> Name
mkCaseName FC
fc Name
fn))
             forall aux. Elab' aux ()
solve

             -- 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 = forall t. FC -> FnOpts -> Name -> [PClause' t] -> PDecl' t
PClauses FC
fc [] Name
cname'
                             (FC
-> Name
-> PTerm
-> [(Name, (Bool, Binder Term))]
-> [(PTerm, PTerm)]
-> [PClause]
caseBlock FC
fc Name
cname' PTerm
scr
                                (forall a b. (a -> b) -> [a] -> [b]
map (PTerm
-> (Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term))
isScr PTerm
scr) (forall a. [a] -> [a]
reverse Env
args')) [(PTerm, PTerm)]
opts)
             -- elaborate case
             forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
e -> EState
e { case_decls :: [(Name, PDecl)]
case_decls = (Name
cname', PDecl
newdef) forall a. a -> [a] -> [a]
: EState -> [(Name, PDecl)]
case_decls EState
e } )
             -- if we haven't got the type yet, hopefully we'll get it later!
             forall aux. Name -> Elab' aux ()
movelast Name
tyn
             forall aux. Elab' aux ()
solve
        where mkCaseName :: FC -> Name -> Name
mkCaseName FC
fc (NS Name
n [Text]
ns) = Name -> [Text] -> Name
NS (FC -> Name -> Name
mkCaseName FC
fc Name
n) [Text]
ns
              mkCaseName FC
fc Name
n = SpecialName -> Name
SN (FC' -> Name -> SpecialName
CaseN (FC -> FC'
FC' FC
fc) Name
n)
--               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 = forall {t :: * -> *} {a} {c}.
(Foldable t, Eq a) =>
RigCount -> t a -> [(a, RigCount, c)] -> RigCount
letrig' RigCount
Rig1 t a
ns [(a, RigCount, c)]
env

              letrig' :: RigCount -> t a -> [(a, RigCount, c)] -> RigCount
letrig' RigCount
def t a
ns [] = RigCount
def
              letrig' RigCount
def t a
ns ((a
n, RigCount
r, c
_) : [(a, RigCount, c)]
env)
                   | a
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t a
ns = RigCount -> t a -> [(a, RigCount, c)] -> RigCount
letrig' (RigCount -> RigCount -> RigCount
rigMult RigCount
def RigCount
r) t a
ns [(a, RigCount, c)]
env
                   | Bool
otherwise = RigCount -> t a -> [(a, RigCount, c)] -> RigCount
letrig' RigCount
def t a
ns [(a, RigCount, c)]
env

              getScrType :: [PTerm] -> Maybe PTerm
getScrType [] = forall a. Maybe a
Nothing
              getScrType (PTerm
f : [PTerm]
os) = forall b a. b -> (a -> b) -> Maybe a -> b
maybe ([PTerm] -> Maybe PTerm
getScrType [PTerm]
os) forall a. a -> Maybe a
Just (PTerm -> Maybe PTerm
getAppType PTerm
f)

              getAppType :: PTerm -> Maybe PTerm
getAppType (PRef FC
_ [FC]
_ Name
n) =
                 case Name -> Context -> [(Name, Term)]
lookupTyName Name
n (IState -> Context
tt_ctxt IState
ist) of
                      [(Name
n', Term
ty)] | Name -> Context -> Bool
isDConName Name
n' (IState -> Context
tt_ctxt IState
ist) ->
                         case forall n. TT n -> (TT n, [TT n])
unApply (forall n. TT n -> TT n
getRetTy Term
ty) of
                           (P NameType
_ Name
tyn Term
_, [Term]
args) ->
                               forall a. a -> Maybe a
Just (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
tyn)
                                    (forall a b. (a -> b) -> [a] -> [b]
map forall {t}. t -> PArg' t
pexp (forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const PTerm
Placeholder) [Term]
args)))
                           (Term, [Term])
_ -> forall a. Maybe a
Nothing
                      [(Name, Term)]
_ -> forall a. Maybe a
Nothing -- ambiguity is no help to us!
              getAppType (PApp FC
_ PTerm
t [PArg]
as) = PTerm -> Maybe PTerm
getAppType PTerm
t
              getAppType PTerm
_ = forall a. Maybe a
Nothing

              inApp :: TT a -> [a]
inApp (P NameType
_ a
n TT a
_) = [a
n]
              inApp (App AppStatus a
_ TT a
f TT a
a) = TT a -> [a]
inApp TT a
f forall a. [a] -> [a] -> [a]
++ TT a -> [a]
inApp TT a
a
              inApp (Bind a
n (Let RigCount
_ TT a
_ TT a
v) TT a
sc) = TT a -> [a]
inApp TT a
v forall a. [a] -> [a] -> [a]
++ TT a -> [a]
inApp TT a
sc
              inApp (Bind a
n (Guess TT a
_ TT a
v) TT a
sc) = TT a -> [a]
inApp TT a
v forall a. [a] -> [a] -> [a]
++ TT a -> [a]
inApp TT a
sc
              inApp (Bind a
n Binder (TT a)
b TT a
sc) = TT a -> [a]
inApp TT a
sc
              inApp TT a
_ = []

              isUnique :: [(a, Bool)] -> a -> Bool
isUnique [(a, Bool)]
envk a
n = case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup a
n [(a, Bool)]
envk of
                                     Just Bool
u -> Bool
u
                                     Maybe Bool
_ -> Bool
False

              getKind :: Env -> (Name, b, c) -> StateT (ElabState aux) TC (Name, Bool)
getKind Env
env (Name
n, b
_, c
_)
                  = case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
                         Maybe (Binder Term)
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
False) -- can't happen, actually...
                         Just Binder Term
b ->
                            do Term
ty <- forall aux. Raw -> Elab' aux Term
get_type (Term -> Raw
forget (forall b. Binder b -> b
binderTy Binder Term
b))
                               case Term
ty of
                                    UType Universe
UniqueType -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
True)
                                    UType Universe
AllTypes -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
True)
                                    Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, Bool
False)

              isNotLift :: Env -> Name -> Bool
isNotLift Env
env Name
n
                 = case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
                        Just Binder Term
ty ->
                             case forall n. TT n -> (TT n, [TT n])
unApply (forall b. Binder b -> b
binderTy Binder Term
ty) of
                                  (P NameType
_ Name
n Term
_, [Term]
_) -> Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` ElabInfo -> [Name]
noCaseLift ElabInfo
info
                                  (Term, [Term])
_ -> Bool
False
                        Maybe (Binder Term)
_ -> Bool
False

    elab' ElabCtxt
ina Maybe FC
fc (PUnifyLog PTerm
t) = do forall aux. Bool -> Elab' aux ()
unifyLog Bool
True
                                    ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
                                    forall aux. Bool -> Elab' aux ()
unifyLog Bool
False
    elab' ElabCtxt
ina Maybe FC
fc (PQuasiquote PTerm
t Maybe PTerm
goalt)
        = do -- 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 <- forall aux. Elab' aux Term
goal
             (PTerm
t, [(Name, PTerm)]
unq) <- forall aux. Int -> PTerm -> Elab' aux (PTerm, [(Name, PTerm)])
extractUnquotes Int
0 PTerm
t
             let unquoteNames :: [Name]
unquoteNames = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, PTerm)]
unq
             forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
uqn -> forall aux. Name -> Raw -> Elab' aux ()
claim Name
uqn (Term -> Raw
forget Term
finalTy)) [Name]
unquoteNames

             -- Save the old state - we need a fresh proof state to avoid
             -- capturing lexically available variables in the quoted term.
             Context
ctxt <- forall aux. Elab' aux Context
get_context
             Ctxt TypeInfo
datatypes <- forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
             Int
g_nextname <- forall aux. Elab' aux Int
get_global_nextname
             forall aux. Elab' aux ()
saveState
             forall aux. (ProofState -> ProofState) -> Elab' aux ()
updatePS (forall a b. a -> b -> a
const forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                       Name
-> String -> Context -> Ctxt TypeInfo -> Int -> Term -> ProofState
newProof (Int -> String -> Name
sMN Int
0 String
"q") (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt Ctxt TypeInfo
datatypes Int
g_nextname forall a b. (a -> b) -> a -> b
$
                       forall n. NameType -> n -> TT n -> TT n
P NameType
Ref (String -> Name
reflm String
"TT") forall n. TT n
Erased)

             -- Re-add the unquotes, letting Idris infer the (fictional)
             -- types. Here, they represent the real type rather than the type
             -- of their reflection.
             forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
n -> do Name
ty <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"unqTy")
                             forall aux. Name -> Raw -> Elab' aux ()
claim Name
ty Raw
RType
                             forall aux. Name -> Elab' aux ()
movelast Name
ty
                             forall aux. Name -> Raw -> Elab' aux ()
claim Name
n (Name -> Raw
Var Name
ty)
                             forall aux. Name -> Elab' aux ()
movelast Name
n)
                   [Name]
unquoteNames

             -- 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 <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"qquoteTy")
             forall aux. Name -> Raw -> Elab' aux ()
claim Name
qTy Raw
RType
             forall aux. Name -> Elab' aux ()
movelast Name
qTy
             Name
qTm <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"qquoteTm")
             forall aux. Name -> Raw -> Elab' aux ()
claim Name
qTm (Name -> Raw
Var Name
qTy)

             -- Let-bind the result of elaborating the contained term, so that
             -- the hole doesn't disappear
             Name
nTm <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"quotedTerm")
             forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
nTm RigCount
RigW (Name -> Raw
Var Name
qTy) (Name -> Raw
Var Name
qTm)

             -- Fill out the goal type, if relevant
             case Maybe PTerm
goalt of
               Maybe PTerm
Nothing  -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
               Just PTerm
gTy -> do forall aux. Name -> Elab' aux ()
focus Name
qTy
                              ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_qq :: Bool
e_qq = Bool
True }) Maybe FC
fc PTerm
gTy

             -- Elaborate the quasiquoted term into the hole
             forall aux. Name -> Elab' aux ()
focus Name
qTm
             ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_qq :: Bool
e_qq = Bool
True }) Maybe FC
fc PTerm
t
             forall aux. Elab' aux ()
end_unify

             -- We now have an elaborated term. Reflect it and solve the
             -- original goal in the original proof state, preserving highlighting
             Env
env <- forall aux. Elab' aux Env
get_env
             EState [(Name, PDecl)]
_ [(Int, ElabD ())]
_ [RDeclInstructions]
_ Set (FC', OutputAnnotation)
hs [Name]
_ [(FC, Name)]
_ <- forall aux. Elab' aux aux
getAux
             forall aux. Elab' aux ()
loadState
             forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
aux -> EState
aux { highlighting :: Set (FC', OutputAnnotation)
highlighting = Set (FC', OutputAnnotation)
hs })

             let quoted :: Maybe Term
quoted = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall n. TT n -> TT n
explicitNames forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Binder b -> b
binderVal) forall a b. (a -> b) -> a -> b
$ forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
nTm Env
env
                 isRaw :: Bool
isRaw = case forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env Term
finalTy) of
                           (P NameType
_ Name
n Term
_, []) | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
reflm String
"Raw" -> Bool
True
                           (Term, [Term])
_ -> Bool
False
             case Maybe Term
quoted of
               Just Term
q -> do Context
ctxt <- forall aux. Elab' aux Context
get_context
                            (Term
q', Term
_, UCs
_) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> Context -> Env -> Raw -> Term -> TC (Term, Term, UCs)
recheck (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt [(Name
uq, RigCount
RigW, forall b. RigCount -> b -> Binder b
Lam RigCount
RigW forall n. TT n
Erased) | Name
uq <- [Name]
unquoteNames] (Term -> Raw
forget Term
q) Term
q
                            if Bool
pattern
                              then if Bool
isRaw
                                      then [Name] -> Raw -> ElabD ()
reflectRawQuotePattern [Name]
unquoteNames (Term -> Raw
forget Term
q')
                                      else [Name] -> Term -> ElabD ()
reflectTTQuotePattern [Name]
unquoteNames Term
q'
                              else do if Bool
isRaw
                                        then -- we forget q' instead of using q to ensure rechecking
                                             forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ [Name] -> Raw -> Raw
reflectRawQuote [Name]
unquoteNames (Term -> Raw
forget Term
q')
                                        else forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ [Name] -> Term -> Raw
reflectTTQuote [Name]
unquoteNames Term
q'
                                      forall aux. Elab' aux ()
solve

               Maybe Term
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Broken elaboration of quasiquote"

             -- Finally fill in the terms or patterns from the unquotes. This
             -- happens last so that their holes still exist while elaborating
             -- the main quotation.
             forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Name, PTerm) -> ElabD ()
elabUnquote [(Name, PTerm)]
unq
      where elabUnquote :: (Name, PTerm) -> ElabD ()
elabUnquote (Name
n, PTerm
tm)
                = do forall aux. Name -> Elab' aux ()
focus Name
n
                     ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE (ElabCtxt
ina { e_qq :: Bool
e_qq = Bool
False }) Maybe FC
fc PTerm
tm


    elab' ElabCtxt
ina Maybe FC
fc (PUnquote PTerm
t) = forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Found unquote outside of quasiquote"
    elab' ElabCtxt
ina Maybe FC
fc (PQuoteName Name
n Bool
False FC
nfc) =
      do forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n
         forall aux. Elab' aux ()
solve
    elab' ElabCtxt
ina Maybe FC
fc (PQuoteName Name
n Bool
True FC
nfc) =
      do Context
ctxt <- forall aux. Elab' aux Context
get_context
         Env
env <- forall aux. Elab' aux Env
get_env
         case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
           Just Binder Term
_ -> do forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n
                        forall aux. Elab' aux ()
solve
                        FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
           Maybe (Binder Term)
Nothing ->
             case Name -> Context -> [(Name, Def)]
lookupNameDef Name
n Context
ctxt of
               [(Name
n', Def
_)] -> do forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n'
                               forall aux. Elab' aux ()
solve
                               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n' forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
               [] -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. Name -> Err' t
NoSuchVariable forall a b. (a -> b) -> a -> b
$ Name
n
               [(Name, Def)]
more -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. [Name] -> Err' t
CantResolveAlts forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, Def)]
more
    elab' ElabCtxt
ina Maybe FC
fc (PAs FC
_ Name
n PTerm
t) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"@-pattern not allowed here"
    elab' ElabCtxt
ina Maybe FC
fc (PHidden PTerm
t)
      | Bool
reflection = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
      | Bool
otherwise
        = do ~(Name
h : [Name]
hs) <- forall aux. Elab' aux [Name]
get_holes
             -- 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
             forall aux. Name -> Elab' aux ()
movelast Name
h
             ~(Name
h' : [Name]
hs) <- forall aux. Elab' aux [Name]
get_holes
             -- If we're at the end anyway, do it now
             if Name
h forall a. Eq a => a -> a -> Bool
== Name
h' then Name -> ElabD ()
elabHidden Name
h
                        else Int -> ElabD () -> ElabD ()
delayElab Int
10 forall a b. (a -> b) -> a -> b
$ Name -> ElabD ()
elabHidden Name
h
     where
      elabHidden :: Name -> ElabD ()
elabHidden Name
h = do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
h forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$ do
                            forall aux. Name -> Elab' aux ()
focus Name
h
                            forall aux. Elab' aux ()
dotterm
                            ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
    elab' ElabCtxt
ina Maybe FC
fc (PRunElab FC
fc' PTerm
tm [String]
ns) =
      do forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
ElabReflection forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist) forall a b. (a -> b) -> a -> b
$
           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
fc' (forall t. String -> Err' t
Msg String
"You must turn on the ElabReflection extension to use %runElab")
         forall aux. Elab' aux ()
attack
         let elabName :: Name
elabName = Name -> [String] -> Name
sNS (String -> Name
sUN String
"Elab") [String
"Elab", String
"Reflection", String
"Language"]
         Name
n <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"tacticScript")
         let scriptTy :: Raw
scriptTy = Raw -> Raw -> Raw
RApp (Name -> Raw
Var Name
elabName) (Name -> Raw
Var Name
unitTy)
         forall aux. Name -> Raw -> Elab' aux ()
claim Name
n Raw
scriptTy
         forall aux. Name -> Elab' aux ()
focus Name
n
         Term
elabUnit <- forall aux. Elab' aux Term
goal
         forall aux. Elab' aux ()
attack -- to get an extra hole
         ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (forall a. a -> Maybe a
Just FC
fc') PTerm
tm
         Term
script <- forall aux. Elab' aux Term
get_guess
         Term -> ElabD ()
fullyElaborated Term
script
         forall aux. Elab' aux ()
solve -- eliminate the hole. Because there are no references, the script is only in the binding
         Context
ctxt <- forall aux. Elab' aux Context
get_context
         Env
env <- forall aux. Elab' aux Env
get_env
         (Term
scriptTm, Term
scriptTy) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] (Term -> Raw
forget Term
script)
         forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term -> TC ()
converts Context
ctxt Env
env Term
elabUnit Term
scriptTy
         Env
env <- forall aux. Elab' aux Env
get_env
         ElabInfo -> IState -> FC -> Env -> Term -> [String] -> ElabD Term
runElabAction ElabInfo
info IState
ist (forall b a. b -> (a -> b) -> Maybe a -> b
maybe FC
fc' forall a. a -> a
id Maybe FC
fc) Env
env Term
script [String]
ns
         forall aux. Elab' aux ()
solve
    elab' ElabCtxt
ina Maybe FC
fc (PConstSugar FC
constFC PTerm
tm) =
      -- 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 forall aux. Elab' aux ()
saveState -- so we don't pollute the elaborated term
         Name
n <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"cstI")
         Name
n' <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"cstIhole")
         Raw
g <- Term -> Raw
forget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall aux. Elab' aux Term
goal
         forall aux. Name -> Raw -> Elab' aux ()
claim Name
n' Raw
g
         forall aux. Name -> Elab' aux ()
movelast Name
n'
         -- In order to intercept the elaborated value, we need to
         -- let-bind it.
         forall aux. Elab' aux ()
attack
         forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n RigCount
RigW Raw
g (Name -> Raw
Var Name
n')
         forall aux. Name -> Elab' aux ()
focus Name
n'
         ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
tm
         Env
env <- forall aux. Elab' aux Env
get_env
         Context
ctxt <- forall aux. Elab' aux Context
get_context
         let v :: Maybe Term
v = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall n. Eq n => TT n -> TT n
finalise forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b. Binder b -> b
binderVal)
                      (forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env)
         forall aux. Elab' aux ()
loadState -- 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 -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
       where highlightConst :: FC -> Term -> ElabD ()
highlightConst FC
fc (P NameType
_ Name
n Term
_) =
               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing)
             highlightConst FC
fc (App AppStatus Name
_ Term
f Term
_) =
               FC -> Term -> ElabD ()
highlightConst FC
fc Term
f
             highlightConst FC
fc (Constant Const
c) =
               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Const -> OutputAnnotation
AnnConst Const
c)
             highlightConst FC
_ Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    elab' ElabCtxt
ina Maybe FC
fc PTerm
x = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Unelaboratable syntactic form " forall a. [a] -> [a] -> [a]
++ PTerm -> String
showTmImpls PTerm
x

    -- 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
       = forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
e -> EState
e { delayed_elab :: [(Int, ElabD ())]
delayed_elab = EState -> [(Int, ElabD ())]
delayed_elab EState
e forall a. [a] -> [a] -> [a]
++ [(Int
pri, ElabD ()
t)] })

    -- 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 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]
caseBlock FC
fc Name
n PTerm
scr [(Name, (Bool, Binder Term))]
env [(PTerm, PTerm)]
opts
        = let args' :: [(Name, (Bool, Binder Term))]
args' = forall {a} {b}. [(a, (Bool, b))] -> [(a, (Bool, b))]
findScr [(Name, (Bool, Binder Term))]
env
              args :: [(PTerm, Bool)]
args = forall a b. (a -> b) -> [a] -> [b]
map forall {b}. (Name, b) -> (PTerm, b)
mkarg (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {b}. (a, (b, b)) -> (a, b)
getNmScr [(Name, (Bool, Binder Term))]
args') in
              forall a b. (a -> b) -> [a] -> [b]
map ([(PTerm, Bool)] -> (PTerm, PTerm) -> PClause
mkClause [(PTerm, Bool)]
args) [(PTerm, PTerm)]
opts

       where -- 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)) forall a. a -> [a] -> [a]
: forall {t} {b}. t -> [(t, b)] -> [(t, b)]
scrName a
n [(a, (Bool, b))]
xs
             findScr [(a
n, (Bool
_, b
t))] = [(a
n, (Bool
True, b
t))]
             findScr ((a, (Bool, b))
x : [(a, (Bool, b))]
xs) = (a, (Bool, b))
x forall a. a -> [a] -> [a]
: [(a, (Bool, b))] -> [(a, (Bool, b))]
findScr [(a, (Bool, b))]
xs
             -- [] can't happen since scrutinee is in the environment!
             findScr [] = 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 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
mkClause [(PTerm, Bool)]
args (PTerm
l, PTerm
r)
                   = let args' :: [(PTerm, Bool)]
args' = forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {b}.
Foldable t =>
t Name -> (PTerm, b) -> (PTerm, b)
shadowed (PTerm -> [Name]
allNamesIn PTerm
l)) [(PTerm, Bool)]
args
                         args'' :: [(PTerm, Bool)]
args'' = forall a b. (a -> b) -> [a] -> [b]
map (forall {t :: * -> *} {b}.
Foldable t =>
t Name -> (PTerm, b) -> (PTerm, b)
implicitable (PTerm -> [Name]
allNamesIn PTerm
r forall a. [a] -> [a] -> [a]
++
                                                     PTerm -> [Name]
keepscrName PTerm
scr)) [(PTerm, Bool)]
args'
                         lhs :: PTerm
lhs = FC -> PTerm -> [PArg] -> PTerm
PApp (FC -> PTerm -> FC
getFC FC
fc PTerm
l) (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
n)
                                 (forall a b. (a -> b) -> [a] -> [b]
map (forall {t}. t -> (t, Bool) -> PArg' t
mkLHSarg PTerm
l) [(PTerm, Bool)]
args'') in
                            forall t. FC -> Name -> t -> [t] -> t -> [PDecl' t] -> PClause' t
PClause (FC -> PTerm -> FC
getFC FC
fc PTerm
l) Name
n PTerm
lhs [] PTerm
r []

             -- 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) = forall {t}. t -> PArg' t
pexp t
l
             mkLHSarg t
l (t
tm, Bool
False) = forall {t}. t -> PArg' t
pexp t
tm

             shadowed :: t Name -> (PTerm, b) -> (PTerm, b)
shadowed t Name
new (PRef FC
_ [FC]
_ Name
n, b
s) | Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Name
new = (PTerm
Placeholder, b
s)
             shadowed t Name
new (PTerm, b)
t = (PTerm, b)
t

             implicitable :: t Name -> (PTerm, b) -> (PTerm, b)
implicitable t Name
rhs (PRef FC
_ [FC]
_ Name
n, b
s) | Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`notElem` t Name
rhs = (PTerm
Placeholder, b
s)
             implicitable t Name
rhs (PTerm, b)
t = (PTerm, b)
t


    getFC :: FC -> PTerm -> FC
getFC FC
d (PApp FC
fc PTerm
_ [PArg]
_) = FC
fc
    getFC FC
d (PRef FC
fc [FC]
_ Name
_) = FC
fc
    getFC FC
d (PAlternative [(Name, Name)]
_ PAltType
_ (PTerm
x:[PTerm]
_)) = FC -> PTerm -> FC
getFC FC
d PTerm
x
    getFC FC
d PTerm
x = FC
d

    -- 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 <- forall aux. Elab' aux aux
getAux
         case forall a b. Eq a => a -> [(a, b)] -> Maybe b
lookup Name
n (EState -> [(Name, PDecl)]
case_decls EState
estate) of
           Maybe PDecl
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Just PDecl
_  -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. Name -> Err' t
ElabScriptStaging Name
n
    fullyElaborated (Bind Name
n Binder Term
b Term
body) = Term -> ElabD ()
fullyElaborated Term
body forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Binder Term
b Term -> ElabD ()
fullyElaborated
    fullyElaborated (App AppStatus Name
_ Term
l Term
r) = Term -> ElabD ()
fullyElaborated Term
l forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Term -> ElabD ()
fullyElaborated Term
r
    fullyElaborated (Proj Term
t Int
_) = Term -> ElabD ()
fullyElaborated Term
t
    fullyElaborated Term
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- 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 -> ElabD PTerm
insertLazy ElabCtxt
ina t :: PTerm
t@(PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg]
_) | Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delay" = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    insertLazy ElabCtxt
ina t :: PTerm
t@(PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg]
_) | Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Force" = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    insertLazy ElabCtxt
ina (PCoerced PTerm
t) = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    -- 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) = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    insertLazy ElabCtxt
ina PTerm
t =
        do Term
ty <- forall aux. Elab' aux Term
goal
           Env
env <- forall aux. Elab' aux Env
get_env
           let (Term
tyh, [Term]
_) = forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty)
           let tries :: [PTerm]
tries = [forall {b} {c}. [(Name, b, c)] -> PTerm -> PTerm
mkDelay Env
env PTerm
t, PTerm
t]
           case Term
tyh of
                P NameType
_ (UN Text
l) Term
_ | Text
l forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed"
                    -> forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [] PAltType
FirstSuccess [PTerm]
tries)
                Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
      where
        mkDelay :: [(Name, b, c)] -> PTerm -> PTerm
mkDelay [(Name, b, c)]
env (PAlternative [(Name, Name)]
ms PAltType
b [PTerm]
xs) = [(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms PAltType
b (forall a b. (a -> b) -> [a] -> [b]
map ([(Name, b, c)] -> PTerm -> PTerm
mkDelay [(Name, b, c)]
env) [PTerm]
xs)
        mkDelay [(Name, b, c)]
env PTerm
t
            = let fc :: FC
fc = String -> FC
fileFC String
"Delay" in
                  IState -> [Name] -> PTerm -> PTerm
addImplBound IState
ist (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv [(Name, b, c)]
env) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] (String -> Name
sUN String
"Delay"))
                                                    [forall {t}. t -> PArg' t
pexp PTerm
t])


    -- 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] <- forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
n (IState -> Ctxt FnOpts
idris_flags IState
ist)
            = FnOpt
NoImplicit forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts
    notImplicitable (PAlternative [(Name, Name)]
_ PAltType
_ [PTerm]
as) = forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PTerm -> Bool
notImplicitable [PTerm]
as
    -- 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 <- 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 <- forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
f Env
env ->
               do let a :: Int
a = forall (t :: * -> *) a. Foldable t => t a -> Int
length (forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env (forall b. Binder b -> b
binderTy Binder Term
aty)))
                  forall (m :: * -> *) a. Monad m => a -> m a
return (FC -> Int -> PTerm -> [PArg] -> PTerm
mkPApp FC
fc Int
a PTerm
ftm [PArg]
args)
            PTerm
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
tm
    expandToArity PTerm
t = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t

    fullApp :: PTerm -> PTerm
fullApp (PApp FC
_ (PApp FC
fc PTerm
f [PArg]
args) [PArg]
xs) = PTerm -> PTerm
fullApp (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc PTerm
f ([PArg]
args forall a. [a] -> [a] -> [a]
++ [PArg]
xs))
    fullApp PTerm
x = PTerm
x

    -- 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 [] = (forall a. Maybe a
Nothing, [])
    findImplicit Name
n (i :: PArg
i@(PImp Int
_ Bool
_ [ArgOpt]
_ Name
n' PTerm
_) : [PArg]
args)
        | Name
n forall a. Eq a => a -> a -> Bool
== Name
n' = (forall a. a -> Maybe a
Just PArg
i, [PArg]
args)
    findImplicit Name
n (i :: PArg
i@(PTacImplicit Int
_ [ArgOpt]
_ Name
n' PTerm
_ PTerm
_) : [PArg]
args)
        | Name
n forall a. Eq a => a -> a -> Bool
== Name
n' = (forall a. a -> Maybe a
Just PArg
i, [PArg]
args)
    findImplicit Name
n (PArg
x : [PArg]
xs) = let (Maybe PArg
arg, [PArg]
rest) = Name -> [PArg] -> (Maybe PArg, [PArg])
findImplicit Name
n [PArg]
xs in
                                  (Maybe PArg
arg, PArg
x forall a. a -> [a] -> [a]
: [PArg]
rest)

    insertScopedImps :: FC -> Name -> [Name] -> Type -> [PArg] -> ElabD [PArg]
    insertScopedImps :: FC -> Name -> [Name] -> Term -> [PArg] -> ElabD [PArg]
insertScopedImps FC
fc Name
f [Name]
knowns Term
ty [PArg]
xs =
         do forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall {t :: * -> *} {t :: (* -> *) -> * -> *} {t}.
(Foldable t, Monad (t TC), MonadTrans t) =>
t Name -> PArg' t -> t TC ()
checkKnownImplicit (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst (forall n. TT n -> [(n, TT n)]
getArgTys Term
ty) forall a. [a] -> [a] -> [a]
++ [Name]
knowns)) [PArg]
xs
            forall {m :: * -> *}. Monad m => Term -> [PArg] -> m [PArg]
doInsert Term
ty [PArg]
xs
      where
        doInsert :: Term -> [PArg] -> m [PArg]
doInsert ty :: Term
ty@(Bind Name
n (Pi RigCount
_ im :: Maybe ImplicitInfo
im@(Just ImplicitInfo
i) Term
_ Term
_) Term
sc) [PArg]
xs
          | (Just PArg
arg, [PArg]
xs') <- Name -> [PArg] -> (Maybe PArg, [PArg])
findImplicit Name
n [PArg]
xs,
            Bool -> Bool
not (ImplicitInfo -> Bool
toplevel_imp ImplicitInfo
i)
              = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PArg
arg forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs')
          | ImplicitInfo -> Bool
tcimplementation ImplicitInfo
i Bool -> Bool -> Bool
&& Bool -> Bool
not (ImplicitInfo -> Bool
toplevel_imp ImplicitInfo
i)
              = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall {t}. Name -> t -> Bool -> PArg' t
pimp Name
n (FC -> PTerm
PResolveTC FC
fc) Bool
True forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs)
          | Bool -> Bool
not (ImplicitInfo -> Bool
toplevel_imp ImplicitInfo
i)
              = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (forall {t}. Name -> t -> Bool -> PArg' t
pimp Name
n PTerm
Placeholder Bool
True forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs)
        doInsert (Bind Name
n (Pi RigCount
_ Maybe ImplicitInfo
_ Term
_ Term
_) Term
sc) (PArg
x : [PArg]
xs)
              = forall (m :: * -> *) a1 r. Monad m => (a1 -> r) -> m a1 -> m r
liftM (PArg
x forall a. a -> [a] -> [a]
:) (Term -> [PArg] -> m [PArg]
doInsert Term
sc [PArg]
xs)
        doInsert Term
ty [PArg]
xs = forall (m :: * -> *) a. Monad m => a -> m a
return [PArg]
xs

        -- 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{})
             | forall t. PArg' t -> Name
pname PArg' t
imp forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Name
ns = forall (m :: * -> *) a. Monad m => a -> m a
return ()
             | Bool
otherwise = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. FC -> Err' t -> Err' t
At FC
fc forall a b. (a -> b) -> a -> b
$ forall t. Name -> Name -> Err' t
UnknownImplicit (forall t. PArg' t -> Name
pname PArg' t
imp) Name
f
        checkKnownImplicit t Name
ns PArg' t
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    insertImpLam :: p -> PTerm -> StateT (ElabState aux) TC PTerm
insertImpLam p
ina PTerm
t =
        do Term
ty <- forall aux. Elab' aux Term
goal
           Env
env <- forall aux. Elab' aux Env
get_env
           let ty' :: Term
ty' = Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty
           forall {aux}. Term -> PTerm -> StateT (ElabState aux) TC PTerm
addLam Term
ty' PTerm
t
      where
        -- 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 <- forall aux. Name -> Elab' aux Name
unique_hole Name
n -- (sMN 0 "scoped_imp")
                    forall (m :: * -> *) a. Monad m => a -> m a
return (FC -> Name -> FC -> PTerm -> PTerm -> PTerm
PLam FC
emptyFC Name
impn FC
NoFC PTerm
Placeholder PTerm
t)
        addLam Term
_ PTerm
t = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t

    insertCoerce :: p -> PTerm -> StateT (ElabState aux) TC PTerm
insertCoerce p
ina t :: PTerm
t@(PCase FC
_ PTerm
_ [(PTerm, PTerm)]
_) = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    insertCoerce p
ina PTerm
t | PTerm -> Bool
notImplicitable PTerm
t = forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    insertCoerce p
ina PTerm
t =
        do Term
ty <- forall aux. Elab' aux Term
goal
           -- Check for possible coercions to get to the goal
           -- and add them as 'alternatives'
           Env
env <- forall aux. Elab' aux Env
get_env
           let ty' :: Term
ty' = Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty
           let cs :: [Name]
cs = IState -> Term -> [Name]
getCoercionsTo IState
ist Term
ty'
           let t' :: PTerm
t' = case (PTerm
t, [Name]
cs) of
                         (PCoerced PTerm
tm, [Name]
_) -> PTerm
tm
                         (PTerm
_, []) -> PTerm
t
                         (PTerm
_, [Name]
cs) -> [(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [] PAltType
TryImplicit
                                         (PTerm
t forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (forall {b} {c}. [(Name, b, c)] -> PTerm -> Name -> PTerm
mkCoerce Env
env PTerm
t) [Name]
cs)
           forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t'
       where
         mkCoerce :: [(Name, b, c)] -> PTerm -> Name -> PTerm
mkCoerce [(Name, b, c)]
env (PAlternative [(Name, Name)]
ms PAltType
aty [PTerm]
tms) Name
n
             = [(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms PAltType
aty (forall a b. (a -> b) -> [a] -> [b]
map (\PTerm
t -> [(Name, b, c)] -> PTerm -> Name -> PTerm
mkCoerce [(Name, b, c)]
env PTerm
t Name
n) [PTerm]
tms)
         mkCoerce [(Name, b, c)]
env PTerm
t Name
n = let fc :: FC
fc = forall b a. b -> (a -> b) -> Maybe a -> b
maybe (String -> FC
fileFC String
"Coercion") forall a. a -> a
id (PTerm -> Maybe FC
highestFC PTerm
t) in
                                IState -> [Name] -> PTerm -> PTerm
addImplBound IState
ist (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv [(Name, b, c)]
env)
                                  (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
n) [forall {t}. t -> PArg' t
pexp (PTerm -> PTerm
PCoerced PTerm
t)])

    elabRef :: ElabCtxt -> Maybe FC -> FC -> [FC] -> Name -> PTerm -> ElabD ()
    elabRef :: ElabCtxt -> Maybe FC -> FC -> [FC] -> Name -> PTerm -> ElabD ()
elabRef ElabCtxt
ina Maybe FC
fc' FC
fc [FC]
hls Name
n PTerm
tm =
               do Term
fty <- forall aux. Raw -> Elab' aux Term
get_type (Name -> Raw
Var Name
n) -- check for implicits
                  Context
ctxt <- forall aux. Elab' aux Context
get_context
                  Env
env <- forall aux. Elab' aux Env
get_env
                  [PArg]
a' <- FC -> Name -> [Name] -> Term -> [PArg] -> ElabD [PArg]
insertScopedImps FC
fc Name
n [] (Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
fty) []
                  if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PArg]
a'
                     then forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc forall a b. (a -> b) -> a -> b
$
                            do forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
n) []
                               OutputAnnotation
hilite <- Name -> ElabD OutputAnnotation
findHighlight Name
n
                               forall aux. Elab' aux ()
solve
                               forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (forall a b c. (a -> b -> c) -> (a, b) -> c
uncurry FC -> OutputAnnotation -> ElabD ()
highlightSource) forall a b. (a -> b) -> a -> b
$
                                 (FC
fc, OutputAnnotation
hilite) forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map (\FC
f -> (FC
f, OutputAnnotation
hilite)) [FC]
hls
                     else ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc' (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc PTerm
tm [])

    -- | 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]
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f (((Name
argName, Name
holeName), Bool
unm):[((Name, Name), Bool)]
ns) Bool
force (PTerm
t : [PTerm]
args)
        = do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
             if Name
holeName forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs then
                do forall aux. Name -> Elab' aux ()
focus Name
holeName
                   case PTerm
t of
                      PTerm
Placeholder -> do forall aux. Name -> Elab' aux ()
movelast Name
holeName
                                        IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f [((Name, Name), Bool)]
ns Bool
force [PTerm]
args
                      PTerm
_ -> PTerm -> ElabD ()
elabArg PTerm
t
                else IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f [((Name, Name), Bool)]
ns Bool
force [PTerm]
args
      where elabArg :: PTerm -> ElabD ()
elabArg PTerm
t =
              do -- solveAutos ist fn False
                 forall aux. FC -> Name -> Name -> Elab' aux ()
now_elaborating FC
fc Name
f Name
argName
                 forall {aux} {b}.
Name
-> Name
-> StateT (ElabState aux) TC b
-> StateT (ElabState aux) TC b
wrapErr Name
f Name
argName forall a b. (a -> b) -> a -> b
$ do
                   [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
                   Term
tm <- forall aux. Elab' aux Term
get_term
                   -- 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 forall aux. Name -> Elab' aux ()
focus Name
holeName;
                                 Term
g <- forall aux. Elab' aux Term
goal
                                 -- Can't pattern match on polymorphic goals
                                 Bool
poly <- ElabD Bool
goal_polymorphic
                                 Bool
ulog <- forall aux. Elab' aux Bool
getUnifyLog
                                 forall {a}. Bool -> String -> a -> a
traceWhen Bool
ulog (String
"Elaborating argument " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Name
argName, Name
holeName, Term
g)) forall a b. (a -> b) -> a -> b
$
                                  ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab (ElabCtxt
ina { e_nomatching :: Bool
e_nomatching = Bool
unm Bool -> Bool -> Bool
&& Bool
poly }) (forall a. a -> Maybe a
Just FC
fc) PTerm
t
                                 forall (m :: * -> *) a. Monad m => a -> m a
return [Bool]
failed
                   forall aux. Name -> Name -> Elab' aux ()
done_elaborating_arg Name
f Name
argName
                   IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f [((Name, Name), Bool)]
ns Bool
force [PTerm]
args
            wrapErr :: Name
-> Name
-> StateT (ElabState aux) TC b
-> StateT (ElabState aux) TC b
wrapErr Name
f Name
argName StateT (ElabState aux) TC b
action =
              do ElabState aux
elabState <- forall s (m :: * -> *). MonadState s m => m s
get
                 [(FC, Name, Name)]
while <- forall aux. Elab' aux [(FC, Name, Name)]
elaborating_app
                 let while' :: [(Name, Name)]
while' = forall a b. (a -> b) -> [a] -> [b]
map (\(FC
x, Name
y, Name
z)-> (Name
y, Name
z)) [(FC, Name, Name)]
while
                 (b
result, ElabState aux
newState) <- case forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT StateT (ElabState aux) TC b
action ElabState aux
elabState of
                                         OK (b
res, ElabState aux
newState) -> forall (m :: * -> *) a. Monad m => a -> m a
return (b
res, ElabState aux
newState)
                                         Error Err
e -> do forall aux. Name -> Name -> Elab' aux ()
done_elaborating_arg Name
f Name
argName
                                                       forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
tfail ([(Name, Name)] -> Err -> Err
elaboratingArgErr [(Name, Name)]
while' Err
e))
                 forall s (m :: * -> *). MonadState s m => s -> m ()
put ElabState aux
newState
                 forall (m :: * -> *) a. Monad m => a -> m a
return b
result
    elabArgs IState
_ ElabCtxt
_ [Bool]
_ FC
_ Bool
_ Name
_ (((Name
arg, Name
hole), Bool
_) : [((Name, Name), Bool)]
_) Bool
_ [] =
      forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Can't elaborate these args: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
arg forall a. [a] -> [a] -> [a]
++ String
" " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
hole

    addAutoBind :: Plicity -> Name -> ElabD ()
    addAutoBind :: Plicity -> Name -> ElabD ()
addAutoBind (Imp [ArgOpt]
_ Static
_ Bool
_ Maybe ImplicitInfo
_ Bool
False RigCount
_) Name
n
         = forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
est -> EState
est { auto_binds :: [Name]
auto_binds = Name
n forall a. a -> [a] -> [a]
: EState -> [Name]
auto_binds EState
est })
    addAutoBind Plicity
_ Name
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

    testImplicitWarning :: FC -> Name -> Type -> ElabD ()
    testImplicitWarning :: FC -> Name -> Term -> ElabD ()
testImplicitWarning FC
fc Name
n Term
goal
       | Name -> Bool
implicitable Name
n Bool -> Bool -> Bool
&& ElabMode
emode forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl
           = do Env
env <- forall aux. Elab' aux Env
get_env
                EState
est <- forall aux. Elab' aux aux
getAux
                forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` EState -> [Name]
auto_binds EState
est) forall a b. (a -> b) -> a -> b
$
                    Env -> [(Name, Term)] -> ElabD ()
tryUnify Env
env (Name -> Context -> [(Name, Term)]
lookupTyName Name
n (IState -> Context
tt_ctxt IState
ist))
       | Bool
otherwise = forall (m :: * -> *) a. Monad m => a -> m a
return ()
      where
        tryUnify :: Env -> [(Name, Term)] -> ElabD ()
tryUnify Env
env [] = forall (m :: * -> *) a. Monad m => a -> m a
return ()
        tryUnify Env
env ((Name
nm, Term
ty) : [(Name, Term)]
ts)
             = do [Name]
inj <- forall aux. Elab' aux [Name]
get_inj
                  [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
                  case Context
-> Env
-> (Term, Maybe Provenance)
-> (Term, Maybe Provenance)
-> [Name]
-> [Name]
-> [Name]
-> [FailContext]
-> TC ([(Name, Term)], Fails)
unify (IState -> Context
tt_ctxt IState
ist) Env
env (Term
ty, forall a. Maybe a
Nothing) (Term
goal, forall a. Maybe a
Nothing)
                          [Name]
inj [Name]
hs [] [] of
                    OK ([(Name, Term)], Fails)
_ ->
                       forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
est -> EState
est { implicit_warnings :: [(FC, Name)]
implicit_warnings =
                                          (FC
fc, Name
nm) forall a. a -> [a] -> [a]
: EState -> [(FC, Name)]
implicit_warnings EState
est })
                    TC ([(Name, Term)], Fails)
_ -> Env -> [(Name, Term)] -> ElabD ()
tryUnify Env
env [(Name, Term)]
ts

-- 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 = forall a b. (a -> b) -> [a] -> [b]
map PTerm -> PTerm
prune [PTerm]
xs
  where
    prune :: PTerm -> PTerm
prune (PApp FC
fc1 (PRef FC
fc2 [FC]
hls Name
f) [PArg]
as)
        = FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc1 (FC -> [FC] -> Name -> PTerm
PRef FC
fc2 [FC]
hls Name
f) (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> PTerm -> PTerm
choose Name
f)) [PArg]
as)
    prune PTerm
t = PTerm
t

    choose :: Name -> PTerm -> PTerm
choose Name
f (PAlternative [(Name, Name)]
ms PAltType
a [PTerm]
as)
        = let as' :: [PTerm]
as' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> PTerm -> PTerm
choose Name
f) [PTerm]
as
              fs :: [PTerm]
fs = forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> PTerm -> Bool
headIs Name
f) [PTerm]
as' in
              case [PTerm]
fs of
                 [PTerm
a] -> PTerm
a
                 [PTerm]
_ -> [(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms PAltType
a [PTerm]
as'

    choose Name
f (PApp FC
fc PTerm
f' [PArg]
as) = FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (Name -> PTerm -> PTerm
choose Name
f PTerm
f') (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Name -> PTerm -> PTerm
choose Name
f)) [PArg]
as)
    choose Name
f PTerm
t = PTerm
t

    headIs :: Name -> PTerm -> Bool
headIs Name
f (PApp FC
_ (PRef FC
_ [FC]
_ Name
f') [PArg]
_) = Name
f forall a. Eq a => a -> a -> Bool
== Name
f'
    headIs Name
f (PApp FC
_ PTerm
f' [PArg]
_) = Name -> PTerm -> Bool
headIs Name
f PTerm
f'
    headIs Name
f PTerm
_ = Bool
True -- 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 <- forall aux. Elab' aux Context
get_context
                     Env
env <- forall aux. Elab' aux Env
get_env
                     case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env of
                       Just Binder Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False
                       Maybe (Binder Term)
Nothing -> case Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt of
                                    Just Term
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n forall a. Maybe a
Nothing forall a. Maybe a
Nothing forall a. Maybe a
Nothing
                                    Maybe Term
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$
                                                 String
"Can't find name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n

-- 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 <- forall aux. Elab' aux [Name]
get_holes
       forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
hs)) forall a b. (a -> b) -> a -> b
$ do
        Env
env <- forall aux. Elab' aux Env
get_env
        Term
g <- forall aux. Elab' aux Term
goal
        forall aux a.
(Err -> Bool) -> Elab' aux a -> Elab' aux a -> Elab' aux a
handleError forall {t}. Err' t -> Bool
cantsolve (forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs) forall a b. (a -> b) -> a -> b
$ do
                        forall aux. Name -> Elab' aux ()
focus Name
n
                        Bool
isg <- forall aux. Elab' aux Bool
is_guess -- if it's a guess, we're working on it recursively, so stop
                        forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not Bool
isg) forall a b. (a -> b) -> a -> b
$
                          IState
-> Bool
-> Bool
-> Int
-> Bool
-> Maybe Name
-> Name
-> [Name]
-> [Name]
-> ElabD ()
proofSearch' IState
ist Bool
True Bool
ambigok Int
100 Bool
True forall a. Maybe a
Nothing Name
fn [] [])
             (forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall a. Err -> TC a
Error (forall {t}. [FailContext] -> Err' t -> Err' t
addLoc [FailContext]
failc
                   (forall t. t -> [(Name, t)] -> Err' t
CantSolveGoal Term
g (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, forall b. Binder b -> b
binderTy Binder Term
b)) Env
env))))
        forall (m :: * -> *) a. Monad m => a -> m a
return ()
  where addLoc :: [FailContext] -> Err' t -> Err' t
addLoc (FailContext FC
fc Name
f Name
x : [FailContext]
prev) Err' t
err
           = forall t. FC -> Err' t -> Err' t
At FC
fc (forall t. Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
ElaboratingArg Name
f Name
x
                   (forall a b. (a -> b) -> [a] -> [b]
map (\(FailContext FC
_ Name
f' Name
x') -> (Name
f', Name
x')) [FailContext]
prev) Err' t
err)
        addLoc [FailContext]
_ Err' t
err = Err' t
err

        cantsolve :: Err' t -> Bool
cantsolve (CantSolveGoal t
_ [(Name, t)]
_) = Bool
True
        cantsolve (InternalMsg String
_) = Bool
True
        cantsolve (At FC
_ Err' t
e) = Err' t -> Bool
cantsolve Err' t
e
        cantsolve (Elaborating String
_ Name
_ Maybe t
_ Err' t
e) = Err' t -> Bool
cantsolve Err' t
e
        cantsolve (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err' t
e) = Err' t -> Bool
cantsolve Err' t
e
        cantsolve Err' t
_ = Bool
False

solveAutos :: IState -> Name -> Bool -> ElabD ()
solveAutos :: IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
ambigok
           = do [(Name, ([FailContext], [Name]))]
autos <- forall aux. Elab' aux [(Name, ([FailContext], [Name]))]
get_autos
                forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
solveAuto IState
ist Name
fn Bool
ambigok) (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, ([FailContext]
fc, [Name]
_)) -> (Name
n, [FailContext]
fc)) [(Name, ([FailContext], [Name]))]
autos)

-- 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 forall aux. Elab' aux ()
unifyProblems
         Bool
-> Bool
-> Bool
-> Bool
-> Int
-> (PTerm -> ElabD ())
-> Maybe Name
-> Name
-> [Name]
-> [Name]
-> IState
-> ElabD ()
proofSearch Bool
rec Bool
prv Bool
ambigok (Bool -> Bool
not Bool
prv) Int
depth
                     (IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")) Maybe Name
top Name
n [Name]
psns [Name]
hints IState
ist
resolveTC' :: Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
resolveTC' Bool
di Bool
mv Int
depth Term
tm Name
n IState
ist
    = Bool
-> Bool
-> Int
-> Term
-> Name
-> (PTerm -> ElabD ())
-> IState
-> ElabD ()
resolveTC Bool
di Bool
mv Int
depth Term
tm Name
n (IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")) IState
ist

collectDeferred :: Maybe Name -> [Name] -> Context ->
                   Term -> State [(Name, (Int, Maybe Name, Type, [Name]))] Term
collectDeferred :: Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred Maybe Name
top [Name]
casenames Context
ctxt Term
tm = [(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [] Term
tm
  where
    cd :: [(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env (Bind Name
n (GHole Int
i [Name]
psns Term
t) Term
app) =
        do [(Name, (Int, Maybe Name, Term, [Name]))]
ds <- forall s (m :: * -> *). MonadState s m => m s
get
           Term
t' <- Maybe Name
-> [Name]
-> Context
-> Term
-> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
collectDeferred Maybe Name
top [Name]
casenames Context
ctxt Term
t
           forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Bool -> Bool
not (Name
n forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, (Int, Maybe Name, Term, [Name]))]
ds)) forall a b. (a -> b) -> a -> b
$ forall s (m :: * -> *). MonadState s m => s -> m ()
put ([(Name, (Int, Maybe Name, Term, [Name]))]
ds forall a. [a] -> [a] -> [a]
++ [(Name
n, (Int
i, Maybe Name
top, Term
t', [Name]
psns))])
           [(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
app
    cd [(Name, Binder Term)]
env (Bind Name
n Binder Term
b Term
t)
         = do Binder Term
b' <- Binder Term
-> StateT
     [(Name, (Int, Maybe Name, Term, [Name]))] Identity (Binder Term)
cdb Binder Term
b
              Term
t' <- [(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd ((Name
n, Binder Term
b) forall a. a -> [a] -> [a]
: [(Name, Binder Term)]
env) Term
t
              forall (m :: * -> *) a. Monad m => a -> m a
return (forall n. n -> Binder (TT n) -> TT n -> TT n
Bind Name
n Binder Term
b' Term
t')
      where
        cdb :: Binder Term
-> StateT
     [(Name, (Int, Maybe Name, Term, [Name]))] Identity (Binder Term)
cdb (Let RigCount
rig Term
t Term
v) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall b. RigCount -> b -> b -> Binder b
Let RigCount
rig) ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
t) ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
v)
        cdb (Guess Term
t Term
v) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 forall b. b -> b -> Binder b
Guess ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
t) ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
v)
        cdb Binder Term
b           = do Term
ty' <- [(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env (forall b. Binder b -> b
binderTy Binder Term
b)
                             forall (m :: * -> *) a. Monad m => a -> m a
return (Binder Term
b { binderTy :: Term
binderTy = Term
ty' })
    cd [(Name, Binder Term)]
env (App AppStatus Name
s Term
f Term
a) = forall (m :: * -> *) a1 a2 r.
Monad m =>
(a1 -> a2 -> r) -> m a1 -> m a2 -> m r
liftM2 (forall n. AppStatus n -> TT n -> TT n -> TT n
App AppStatus Name
s) ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
f)
                                        ([(Name, Binder Term)]
-> Term -> State [(Name, (Int, Maybe Name, Term, [Name]))] Term
cd [(Name, Binder Term)]
env Term
a)
    cd [(Name, Binder Term)]
env Term
t = forall (m :: * -> *) a. Monad m => a -> m a
return Term
t

-- | 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] -> ElabD Term
runElabAction ElabInfo
info IState
ist FC
fc Env
env Term
tm [String]
ns = do Term
tm' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
tm
                                         Term -> ElabD Term
runTacTm Term
tm'

  where
    eval :: Term -> StateT (ElabState aux) TC Term
eval Term
tm = do Context
ctxt <- forall aux. Elab' aux Context
get_context
                 forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env (forall n. Eq n => TT n -> TT n
finalise Term
tm)

    returnUnit :: ElabD Term
returnUnit = forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall n. NameType -> n -> TT n -> TT n
P (Int -> Int -> Bool -> NameType
DCon Int
0 Int
0 Bool
False) Name
unitCon (forall n. NameType -> n -> TT n -> TT n
P (Int -> Int -> NameType
TCon Int
0 Int
0) Name
unitTy forall n. TT n
Erased)

    patvars :: [(Name, Term)] -> Term -> ([(Name, Term)], Term)
    patvars :: [(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [(Name, Term)]
ns (Bind Name
n (PVar RigCount
_ Term
t) Term
sc) = [(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars ((Name
n, Term
t) forall a. a -> [a] -> [a]
: [(Name, Term)]
ns) (forall n. TT n -> TT n -> TT n
instantiate (forall n. NameType -> n -> TT n -> TT n
P NameType
Bound Name
n Term
t) Term
sc)
    patvars [(Name, Term)]
ns Term
tm                   = ([(Name, Term)]
ns, Term
tm)

    pullVars :: (Term, Term) -> ([(Name, Term)], Term, Term)
    pullVars :: (Term, Term) -> ([(Name, Term)], Term, Term)
pullVars (Term
lhs, Term
rhs) = (forall a b. (a, b) -> a
fst ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs), forall a b. (a, b) -> b
snd ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs), forall a b. (a, b) -> b
snd ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
rhs)) -- 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 <- forall s (m :: * -> *). MonadState s m => m s
get
         case forall s (m :: * -> *) a. StateT s m a -> s -> m (a, s)
runStateT ElabD a
elab ElabState EState
state of
           OK (a
_, ElabState EState
state') -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (forall a. Err -> TC a
tfail Err
orErr)
           Error Err
e -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- 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
_)] -> forall n. NameType -> n -> TT n -> TT n
P NameType
nt Name
n' forall n. TT n
Erased
        [(Name, Def)]
_ -> forall n. NameType -> n -> TT n -> TT n
P NameType
Ref Name
n forall n. TT n
Erased
    fakeTT (RBind Name
n Binder Raw
b Raw
body) = forall n. n -> Binder (TT n) -> TT n -> TT n
Bind Name
n (forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Raw -> Term
fakeTT Binder Raw
b) (Raw -> Term
fakeTT Raw
body)
    fakeTT (RApp Raw
f Raw
a) = forall n. AppStatus n -> TT n -> TT n -> TT n
App forall n. AppStatus n
Complete (Raw -> Term
fakeTT Raw
f) (Raw -> Term
fakeTT Raw
a)
    fakeTT Raw
RType = forall n. UExp -> TT n
TType (String -> Int -> UExp
UVar [] (-Int
1))
    fakeTT (RUType Universe
u) = forall n. Universe -> TT n
UType Universe
u
    fakeTT (RConstant Const
c) = forall n. Const -> TT n
Constant Const
c

    defineFunction :: RFunDefn Raw -> ElabD ()
    defineFunction :: RFunDefn Raw -> ElabD ()
defineFunction (RDefineFun Name
n [RFunClause Raw]
clauses) =
      do Context
ctxt <- forall aux. Elab' aux Context
get_context
         Term
ty <- forall b a. b -> (a -> b) -> Maybe a -> b
maybe (forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no type decl") forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt
         let info :: CaseInfo
info = Bool -> Bool -> Bool -> CaseInfo
CaseInfo Bool
True Bool
True Bool
False -- TODO document and figure out
         [Either Term (Term, Term)]
clauses' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
t a -> (a -> m b) -> m (t b)
forM [RFunClause Raw]
clauses (\case
                                      RMkFunClause Raw
lhs Raw
rhs ->
                                        do (Term
lhs', Term
lty) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
lhs
                                           (Term
rhs', Term
rty) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
rhs
                                           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term -> TC ()
converts Context
ctxt [] Term
lty Term
rty
                                           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. b -> Either a b
Right (Term
lhs', Term
rhs')
                                      RMkImpossibleClause Raw
lhs ->
                                        do forall a. Err -> ElabD a -> ElabD ()
requireError (forall t. String -> Err' t
Msg String
"Not an impossible case") forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
                                             Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
lhs
                                           forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. a -> Either a b
Left (Raw -> Term
fakeTT Raw
lhs))
         let clauses'' :: [([(Name, Term)], Term, Term)]
clauses'' = forall a b. (a -> b) -> [a] -> [b]
map (\case Right (Term, Term)
c -> (Term, Term) -> ([(Name, Term)], Term, Term)
pullVars (Term, Term)
c
                                    Left Term
lhs -> let ([(Name, Term)]
ns, Term
lhs') = [(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs
                                                in ([(Name, Term)]
ns, Term
lhs', forall n. TT n
Impossible))
                            [Either Term (Term, Term)]
clauses'
         let clauses''' :: [([Name], Term, Term)]
clauses''' = forall a b. (a -> b) -> [a] -> [b]
map (\([(Name, Term)]
ns, Term
lhs, Term
rhs) -> (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, Term)]
ns, Term
lhs, Term
rhs)) [([(Name, Term)], Term, Term)]
clauses''
         let argtys :: [(Term, Bool)]
argtys = forall a b. (a -> b) -> [a] -> [b]
map (\Term
x -> (Term
x, Term -> Context -> Bool
isCanonical Term
x Context
ctxt))
                          (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd (forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise Context
ctxt [] Term
ty)))
         Context
ctxt'<- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$
                  Name
-> ErasureInfo
-> CaseInfo
-> Bool
-> SC
-> Bool
-> Bool
-> [(Term, Bool)]
-> [Int]
-> [Either Term (Term, Term)]
-> [([Name], Term, Term)]
-> [([Name], Term, Term)]
-> Term
-> Context
-> TC Context
addCasedef Name
n (forall a b. a -> b -> a
const [])
                             CaseInfo
info Bool
False (forall t. t -> SC' t
STerm forall n. TT n
Erased)
                             Bool
True Bool
False -- 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
         forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
         forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = Name -> [([(Name, Term)], Term, Term)] -> RDeclInstructions
RClausesInstrs Name
n [([(Name, Term)], Term, Term)]
clauses'' forall a. a -> [a] -> [a]
: EState -> [RDeclInstructions]
new_tyDecls EState
e}
         forall (m :: * -> *) a. Monad m => a -> m a
return ()


    checkClosed :: Raw -> Elab' aux (Term, Type)
    checkClosed :: forall aux. Raw -> Elab' aux (Term, Term)
checkClosed Raw
tm = do Context
ctxt <- forall aux. Elab' aux Context
get_context
                        (Term
val, Term
ty) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
tm
                        forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$! (forall n. Eq n => TT n -> TT n
finalise Term
val, forall n. Eq n => TT n -> TT n
finalise Term
ty)

    -- | 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) (forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW forall a. Maybe a
Nothing (RFunArg -> Raw
argTy RFunArg
arg) (Universe -> Raw
RUType Universe
AllTypes)) Raw
rTy

    mustBeType :: Context -> a -> Term -> t TC ()
mustBeType Context
ctxt a
tm Term
ty =
      case Context -> Env -> Term -> Term
normaliseAll Context
ctxt [] (forall n. Eq n => TT n -> TT n
finalise Term
ty) of
        UType Universe
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        TType UExp
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
        Term
ty'    -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$
                     forall a. Show a => a -> String
show a
tm forall a. [a] -> [a] -> [a]
++ String
" is not a type: it's " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
ty'

    mustNotBeDefined :: Context -> Name -> t TC ()
mustNotBeDefined Context
ctxt Name
n =
      case Name -> Context -> Maybe Def
lookupDefExact Name
n Context
ctxt of
        Just Def
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$
                    forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" is already defined."
        Maybe Def
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- | 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 <- forall aux. Elab' aux Context
get_context
         -- ensure the constructor name is not qualified, and
         -- construct a qualified one
         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
         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 = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RFunArg -> Raw -> Raw
mkPi Raw
resTy [RFunArg]
args
         (Term
checkedTy, Term
ctyTy) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
cty
         forall {t :: (* -> *) -> * -> *} {a}.
(Monad (t TC), MonadTrans t, Show a) =>
Context -> a -> Term -> t TC ()
mustBeType Context
ctxt Term
checkedTy Term
ctyTy

         -- ensure that the constructor builds the right family
         case forall n. TT n -> (TT n, [TT n])
unApply (Term -> Term
getRetTy (Context -> Env -> Term -> Term
normaliseAll Context
ctxt [] (forall n. Eq n => TT n -> TT n
finalise Term
checkedTy))) of
           (P NameType
_ Name
n Term
_, [Term]
_) | Name
n forall a. Eq a => a -> a -> Bool
== Name
tyn -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
           (Term, [Term])
t -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"The constructor " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
cn forall a. [a] -> [a] -> [a]
++
                                     String
" doesn't construct " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
tyn forall a. [a] -> [a] -> [a]
++
                                     String
" (return type is " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show (Term, [Term])
t forall a. [a] -> [a] -> [a]
++ String
")"

         -- add temporary type declaration for constructor (so it can
         -- occur in later constructor types)
         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 = forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> PArg
rFunArgToPArg [RFunArg]
args

         forall (m :: * -> *) a. Monad m => a -> m a
return (Name
qcn, [PArg]
impls, Term
checkedTy)

      where
        notQualified :: Name -> t TC ()
notQualified (NS Name
_ [Text]
_) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Constructor names may not be qualified"
        notQualified Name
_ = forall (m :: * -> *) a. Monad m => a -> m a
return ()

        qualify :: Name -> Name
qualify Name
n = case Name
tyn of
                      (NS Name
_ [Text]
ns) -> Name -> [Text] -> Name
NS Name
n [Text]
ns
                      Name
_ -> Name
n

        getRetTy :: Type -> Type
        getRetTy :: Term -> Term
getRetTy (Bind Name
_ (Pi RigCount
_ Maybe ImplicitInfo
_ Term
_ Term
_) Term
sc) = Term -> Term
getRetTy Term
sc
        getRetTy Term
ty = Term
ty

    elabScriptStuck :: Term -> ElabD a
    elabScriptStuck :: forall a. Term -> ElabD a
elabScriptStuck Term
x = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. t -> Err' t
ElabScriptStuck Term
x


    -- Should be dependent
    tacTmArgs :: Int -> Term -> [Term] -> ElabD [Term]
    tacTmArgs :: Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
l Term
t [Term]
args | forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
args forall a. Eq a => a -> a -> Bool
== Int
l = forall (m :: * -> *) a. Monad m => a -> m a
return [Term]
args
                       | Bool
otherwise        = forall a. Term -> ElabD a
elabScriptStuck Term
t -- 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 -> ElabD Term
runTacTm tac :: Term
tac@(forall n. TT n -> (TT n, [TT n])
unApply -> (P NameType
_ Name
n Term
_, [Term]
args))
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Solve"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args -- patterns are irrefutable because `tacTmArgs` returns lists of exactly the size given to it as first argument
           forall aux. Elab' aux ()
solve
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Goal"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
           case [Name]
hs of
             (Name
h : [Name]
_) -> do Term
t <- forall aux. Elab' aux Term
goal
                           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
                             (Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var (String -> Name
reflm String
"TTName"), Name -> Raw
Var (String -> Name
reflm String
"TT"))
                                     (Name -> Raw
reflectName Name
h,        Term -> Raw
reflect Term
t)
             [] -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$
                     String
"Elaboration is complete. There are no goals."

      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Holes"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             Raw -> [Raw] -> Raw
mkList (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName") (forall a b. (a -> b) -> [a] -> [b]
map Name -> Raw
reflectName [Name]
hs)
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Guess"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           Term
g <- forall aux. Elab' aux Term
get_guess
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Term -> Raw
reflect Term
g
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupTy"
      = do ~[Term
name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           let getNameTypeAndType :: Def -> (NameType, Term)
getNameTypeAndType = \case Function Term
ty Term
_       -> (NameType
Ref, Term
ty)
                                          TyDecl NameType
nt Term
ty        -> (NameType
nt, Term
ty)
                                          Operator Term
ty Int
_ [Value] -> Maybe Value
_     -> (NameType
Ref, Term
ty)
                                          CaseOp CaseInfo
_ Term
ty [(Term, Bool)]
_ [Either Term (Term, Term)]
_ [([Name], Term, Term)]
_ CaseDefs
_ -> (NameType
Ref, Term
ty)
               -- 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 ]
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             Raw -> [Raw] -> Raw
rawList (Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [ Name -> Raw
Var (String -> Name
reflm String
"TTName")
                                             , Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [ Name -> Raw
Var (String -> Name
reflm String
"NameType")
                                                                       , Name -> Raw
Var (String -> Name
reflm String
"TT")]])
                     [Raw]
defs
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupDatatype"
      = do ~[Term
name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
           Ctxt TypeInfo
datatypes <- forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             Raw -> [Raw] -> Raw
rawList (Name -> Raw
Var (String -> Name
tacN String
"Datatype"))
                     (forall a b. (a -> b) -> [a] -> [b]
map RDatatype -> Raw
reflectDatatype (IState -> Name -> [RDatatype]
buildDatatypes IState
ist Name
n'))
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupFunDefn"
      = do ~[Term
name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             Raw -> [Raw] -> Raw
rawList (Raw -> Raw -> Raw
RApp (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
tacN String
"FunDefn") (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT"))
               (forall a b. (a -> b) -> [a] -> [b]
map RFunDefn Term -> Raw
reflectFunDefn (IState -> Name -> [RFunDefn Term]
buildFunDefns IState
ist Name
n'))
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupArgs"
      = do ~[Term
name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
           let listTy :: Raw
listTy = Name -> Raw
Var (Name -> [String] -> Name
sNS (String -> Name
sUN String
"List") [String
"List", String
"Prelude"])
               listFunArg :: Raw
listFunArg = Raw -> Raw -> Raw
RApp Raw
listTy (Name -> Raw
Var (String -> Name
tacN String
"FunArg"))
            -- 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")) (forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> Raw
reflectArg [RFunArg]
args), Raw -> Raw
reflectRaw Raw
res)
                 | (Name
fn, [PArg]
pargs) <- forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
n' (IState -> Ctxt [PArg]
idris_implicits IState
ist)
                 , ([RFunArg]
args, Raw
res) <- [PArg] -> Raw -> ([RFunArg], Raw)
getArgs [PArg]
pargs forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Raw
forget forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                   forall a. Maybe a -> [a]
maybeToList (Name -> Context -> Maybe Term
lookupTyExact Name
fn (IState -> Context
tt_ctxt IState
ist))
                 ]

           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             Raw -> [Raw] -> Raw
rawList (Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [Name -> Raw
Var (String -> Name
reflm String
"TTName")
                                             , Raw -> [Raw] -> Raw
raw_apply (Name -> Raw
Var Name
pairTy) [ Raw -> Raw -> Raw
RApp Raw
listTy
                                                                             (Name -> Raw
Var (String -> Name
tacN String
"FunArg"))
                                                                      , Name -> Raw
Var (String -> Name
reflm String
"Raw")]])
                     [Raw]
out
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__SourceLocation"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             FC -> Raw
reflectFC FC
fc
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Namespace"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             Raw -> [Raw] -> Raw
rawList (Const -> Raw
RConstant Const
StrType) (forall a b. (a -> b) -> [a] -> [b]
map (Const -> Raw
RConstant forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Const
Str) [String]
ns)
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Env"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           Env
env <- forall aux. Elab' aux Env
get_env
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Env -> Raw
reflectEnv Env
env
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Fail"
      = do ~[Term
_a, Term
errs] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Term
errs' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
errs
           [ErrorReportPart]
parts <- Term -> ElabD [ErrorReportPart]
reifyReportParts Term
errs'
           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. [[ErrorReportPart]] -> Err' t -> Err' t
ReflectionError [[ErrorReportPart]
parts] (forall t. String -> Err' t
Msg String
"")
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__PureElab"
      = do ~[Term
_a, Term
tm] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           forall (m :: * -> *) a. Monad m => a -> m a
return Term
tm
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__BindElab"
      = do ~[Term
_a, Term
_b, Term
first, Term
andThen] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
4 Term
tac [Term]
args
           Term
first' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
first
           Term
res <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< Term -> ElabD Term
runTacTm Term
first'
           Term
next <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval (forall n. AppStatus n -> TT n -> TT n -> TT n
App forall n. AppStatus n
Complete Term
andThen Term
res)
           Term -> ElabD Term
runTacTm Term
next
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Try"
      = do ~[Term
_a, Term
first, Term
alt] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
3 Term
tac [Term]
args
           Term
first' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
first
           Term
alt' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
alt
           forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (Term -> ElabD Term
runTacTm Term
first') (Term -> ElabD Term
runTacTm Term
alt') Bool
True
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__TryCatch"
      = do ~[Term
_a, Term
first, Term
f] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
3 Term
tac [Term]
args
           Term
first' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
first
           Term
f' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
f
           forall aux a. Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
tryCatch (Term -> ElabD Term
runTacTm Term
first') forall a b. (a -> b) -> a -> b
$ \Err
err ->
             do (Term
err', Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
checkClosed (Err -> Raw
reflectErr Err
err)
                Term
f' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval (forall n. AppStatus n -> TT n -> TT n -> TT n
App forall n. AppStatus n
Complete Term
f Term
err')
                Term -> ElabD Term
runTacTm Term
f'
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Fill"
      = do ~[Term
raw] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Raw
raw' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
raw
           forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply Raw
raw' []
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Apply" Bool -> Bool -> Bool
|| Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__MatchApply"
      = do ~[Term
raw, Term
argSpec] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Raw
raw' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
raw
           [(Bool, Int)]
argSpec' <- forall a b. (a -> b) -> [a] -> [b]
map (\Bool
b -> (Bool
b, Int
0)) forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> forall a. (Term -> ElabD a) -> Term -> ElabD [a]
reifyList Term -> ElabD Bool
reifyBool Term
argSpec
           let op :: Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
op = if Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Apply"
                       then forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply
                       else forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
match_apply
           [(Name, Name)]
ns <- forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
op Raw
raw' [(Bool, Int)]
argSpec'
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             Raw -> [Raw] -> Raw
rawList (Raw -> Raw -> Raw
rawPairTy (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName") (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName"))
                     [ (Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName", Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TTName")
                               (Name -> Raw
reflectName Name
n1, Name -> Raw
reflectName Name
n2)
                     | (Name
n1, Name
n2) <- [(Name, Name)]
ns
                     ]
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Gensym"
      = do ~[Term
hint] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Term
hintStr <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
hint
           case Term
hintStr of
             Constant (Str String
h) -> do
               Name
n <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
h)
               forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
reflectName Name
n)
             Term
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"no hint"
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Claim"
      = do ~[Term
n, Term
ty] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
           Raw
ty' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
ty
           forall aux. Name -> Raw -> Elab' aux ()
claim Name
n' Raw
ty'
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Check"
      = do ~[Term
env', Term
raw] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Env
env <- Term -> ElabD Env
reifyEnv Term
env'
           Raw
raw' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw forall (m :: * -> *) a b. Monad m => (a -> m b) -> m a -> m b
=<< forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
raw
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           (Term
tm, Term
ty) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt Env
env Raw
raw'
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             (Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var (String -> Name
reflm String
"TT"), Name -> Raw
Var (String -> Name
reflm String
"TT"))
                     (Term -> Raw
reflect Term
tm,       Term -> Raw
reflect Term
ty)
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Attack"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           forall aux. Elab' aux ()
attack
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Rewrite"
      = do ~[Term
rule] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Raw
r <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
rule
           forall aux. Raw -> Elab' aux ()
rewrite Raw
r
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Focus"
      = do ~[Term
what] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
what
           [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
           if forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem Name
n' [Name]
hs
              then forall aux. Name -> Elab' aux ()
focus Name
n' forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> ElabD Term
returnUnit
              else forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"The name " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n' forall a. [a] -> [a] -> [a]
++ String
" does not denote a hole"
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Unfocus"
      = do ~[Term
what] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
what
           forall aux. Name -> Elab' aux ()
movelast Name
n'
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Intro"
      = do ~[Term
mn] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Maybe Name
n <- case Term -> Maybe Term
fromTTMaybe Term
mn of
                  Maybe Term
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a. Maybe a
Nothing
                  Just Term
name -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a. a -> Maybe a
Just forall a b. (a -> b) -> a -> b
$ Term -> StateT (ElabState EState) TC Name
reifyTTName Term
name
           forall aux. Maybe Name -> Elab' aux ()
intro Maybe Name
n
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Forall"
      = do ~[Term
n, Term
ty] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
           Raw
ty' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
ty
           forall aux.
Name -> RigCount -> Maybe ImplicitInfo -> Raw -> Elab' aux ()
forAll Name
n' RigCount
RigW forall a. Maybe a
Nothing Raw
ty'
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__PatVar"
      = do ~[Term
n] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
           forall aux. Name -> Elab' aux ()
patvar' Name
n'
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__PatBind"
      = do ~[Term
n] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
           forall aux. Name -> RigCount -> Elab' aux ()
patbind Name
n' RigCount
RigW
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LetBind"
      = do ~[Term
n, Term
ty, Term
tm] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
3 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
           Raw
ty' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
ty
           Raw
tm' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
tm
           forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
n' RigCount
RigW Raw
ty' Raw
tm'
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Compute"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args; forall aux. Elab' aux ()
compute ; ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Normalise"
      = do ~[Term
env, Term
tm] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Env
env' <- Term -> ElabD Env
reifyEnv Term
env
           Term
tm' <- Term -> ElabD Term
reifyTT Term
tm
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           let out :: Term
out = Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env' (forall n. Eq n => TT n -> TT n
finalise Term
tm')
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Term -> Raw
reflect Term
out
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Whnf"
      = do ~[Term
tm] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Term
tm' <- Term -> ElabD Term
reifyTT Term
tm
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Raw
reflect forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term
whnf Context
ctxt [] Term
tm'
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Converts"
      = do ~[Term
env, Term
tm1, Term
tm2] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
3 Term
tac [Term]
args
           Env
env' <- Term -> ElabD Env
reifyEnv Term
env
           Term
tm1' <- Term -> ElabD Term
reifyTT Term
tm1
           Term
tm2' <- Term -> ElabD Term
reifyTT Term
tm2
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> Term -> TC ()
converts Context
ctxt Env
env' Term
tm1' Term
tm2'
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__DeclareType"
      = do ~[Term
decl] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           (RDeclare Name
n [RFunArg]
args Raw
res) <- Term -> ElabD RTyDecl
reifyTyDecl Term
decl
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           let rty :: Raw
rty = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RFunArg -> Raw -> Raw
mkPi Raw
res [RFunArg]
args
           (Term
checked, Term
ty') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
rty
           forall {t :: (* -> *) -> * -> *} {a}.
(Monad (t TC), MonadTrans t, Show a) =>
Context -> a -> Term -> t TC ()
mustBeType Context
ctxt Term
checked Term
ty'
           forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Context -> Name -> t TC ()
mustNotBeDefined Context
ctxt Name
n
           let decl :: Def
decl = NameType -> Term -> Def
TyDecl NameType
Ref Term
checked
               ctxt' :: Context
ctxt' = Name -> Def -> Context -> Context
addCtxtDef Name
n Def
decl Context
ctxt
           forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
           forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = (Name -> FC -> [PArg] -> Term -> RDeclInstructions
RTyDeclInstrs Name
n FC
fc (forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> PArg
rFunArgToPArg [RFunArg]
args) Term
checked) forall a. a -> [a] -> [a]
:
                                               EState -> [RDeclInstructions]
new_tyDecls EState
e }
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__DefineFunction"
      = do ~[Term
decl] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           RFunDefn Raw
defn <- Term -> ElabD (RFunDefn Raw)
reifyFunDefn Term
decl
           RFunDefn Raw -> ElabD ()
defineFunction RFunDefn Raw
defn
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__DeclareDatatype"
      = do ~[Term
decl] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           RDeclare Name
n [RFunArg]
args Raw
resTy <- Term -> ElabD RTyDecl
reifyTyDecl Term
decl
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           let tcTy :: Raw
tcTy = forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RFunArg -> Raw -> Raw
mkPi Raw
resTy [RFunArg]
args
           (Term
checked, Term
ty') <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
tcTy
           forall {t :: (* -> *) -> * -> *} {a}.
(Monad (t TC), MonadTrans t, Show a) =>
Context -> a -> Term -> t TC ()
mustBeType Context
ctxt Term
checked Term
ty'
           forall {t :: (* -> *) -> * -> *}.
(MonadTrans t, Monad (t TC)) =>
Context -> Name -> t TC ()
mustNotBeDefined Context
ctxt Name
n
           let ctxt' :: Context
ctxt' = Name -> NameType -> Term -> Context -> Context
addTyDecl Name
n (Int -> Int -> NameType
TCon Int
0 Int
0) Term
checked Context
ctxt
           forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
           forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = Name -> [PArg] -> RDeclInstructions
RDatatypeDeclInstrs Name
n (forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> PArg
rFunArgToPArg [RFunArg]
args) forall a. a -> [a] -> [a]
: EState -> [RDeclInstructions]
new_tyDecls EState
e }
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__DefineDatatype"
      = do ~[Term
defn] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           RDefineDatatype Name
n [RConstructorDefn]
ctors <- Term -> ElabD RDataDefn
reifyRDataDefn Term
defn
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           Term
tyconTy <- case Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt of
                        Just Term
t -> forall (m :: * -> *) a. Monad m => a -> m a
return Term
t
                        Maybe Term
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Type not previously declared"
           Ctxt TypeInfo
datatypes <- forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
           case forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
n Ctxt TypeInfo
datatypes of
             [] -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
             [(Name, TypeInfo)]
_  -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" is already defined as a datatype."
           -- Prepare the constructors
           [(Name, [PArg], Term)]
ctors' <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Name -> RConstructorDefn -> ElabD (Name, [PArg], Term)
prepareConstructor Name
n) [RConstructorDefn]
ctors
           Int
ttag <- do ES (ProofState
ps, EState
aux) String
str Maybe (ElabState EState)
prev <- forall s (m :: * -> *). MonadState s m => m s
get
                      let i :: Int
i = ProofState -> Int
global_nextname ProofState
ps
                      forall s (m :: * -> *). MonadState s m => s -> m ()
put forall a b. (a -> b) -> a -> b
$ forall aux.
(ProofState, aux)
-> String -> Maybe (ElabState aux) -> ElabState aux
ES (ProofState
ps { global_nextname :: Int
global_nextname = ProofState -> Int
global_nextname ProofState
ps forall a. Num a => a -> a -> a
+ Int
1 },
                                EState
aux)
                               String
str
                               Maybe (ElabState EState)
prev
                      forall (m :: * -> *) a. Monad m => a -> m a
return Int
i
           let ctxt' :: Context
ctxt' = Datatype Name -> Context -> Context
addDatatype (forall n. n -> Int -> TT n -> Bool -> [(n, TT n)] -> Datatype n
Data Name
n Int
ttag Term
tyconTy Bool
False (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
cn, [PArg]
_, Term
cty) -> (Name
cn, Term
cty)) [(Name, [PArg], Term)]
ctors')) Context
ctxt
           forall aux. Context -> Elab' aux ()
set_context Context
ctxt'
           -- the rest happens in a bit
           forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = Name -> Term -> [(Name, [PArg], Term)] -> RDeclInstructions
RDatatypeDefnInstrs Name
n Term
tyconTy [(Name, [PArg], Term)]
ctors' forall a. a -> [a] -> [a]
: EState -> [RDeclInstructions]
new_tyDecls EState
e }
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__AddImplementation"
      = do ~[Term
cls, Term
impl] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Name
interfaceName <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
cls
           Name
implName <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
impl
           forall aux. (aux -> aux) -> Elab' aux ()
updateAux forall a b. (a -> b) -> a -> b
$ \EState
e -> EState
e { new_tyDecls :: [RDeclInstructions]
new_tyDecls = Name -> Name -> RDeclInstructions
RAddImplementation Name
interfaceName Name
implName forall a. a -> [a] -> [a]
:
                                               EState -> [RDeclInstructions]
new_tyDecls EState
e }
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__IsTCName"
      = do ~[Term
n] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
           case forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
n' (IState -> Ctxt InterfaceInfo
idris_interfaces IState
ist) of
             Just InterfaceInfo
_ -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Name -> Raw
Var (Name -> [String] -> Name
sNS (String -> Name
sUN String
"True") [String
"Bool", String
"Prelude"])
             Maybe InterfaceInfo
Nothing -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Name -> Raw
Var (Name -> [String] -> Name
sNS (String -> Name
sUN String
"False") [String
"Bool", String
"Prelude"])
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__ResolveTC"
      = do ~[Term
fn] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Term
g <- forall aux. Elab' aux Term
goal
           Name
fn <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
fn
           Bool -> Bool -> Int -> Term -> Name -> IState -> ElabD ()
resolveTC' Bool
False Bool
True Int
100 Term
g Name
fn IState
ist
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Search"
      = do ~[Term
depth, Term
hints] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Term
d <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
depth
           Term
hints' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
hints
           case (Term
d, Term -> Maybe [Term]
unList Term
hints') of
             (Constant (I Int
i), Just [Term]
hs) ->
               do [Name]
actualHints <- forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Term -> StateT (ElabState EState) TC Name
reifyTTName [Term]
hs
                  forall aux. Elab' aux ()
unifyProblems
                  let psElab :: PTerm -> ElabD ()
psElab = IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")
                  Bool
-> Bool
-> Bool
-> Bool
-> Int
-> (PTerm -> ElabD ())
-> Maybe Name
-> Name
-> [Name]
-> [Name]
-> IState
-> ElabD ()
proofSearch Bool
True Bool
True Bool
False Bool
False Int
i PTerm -> ElabD ()
psElab forall a. Maybe a
Nothing (Int -> String -> Name
sMN Int
0 String
"search ") [] [Name]
actualHints IState
ist
                  ElabD Term
returnUnit
             (Constant (I Int
_), Maybe [Term]
Nothing ) ->
               forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$ String
"Not a list: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
hints'
             (Term
_, Maybe [Term]
_) -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$ String
"Can't reify int " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
d
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__RecursiveElab"
      = do ~[Term
goal, Term
script] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Raw
goal' <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
goal
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           Term
script <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
script
           (Term
goalTT, Term
goalTy) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Raw -> TC (Term, Term)
check Context
ctxt [] Raw
goal'
           forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ Context -> Env -> Term -> TC ()
isType Context
ctxt [] Term
goalTy
           Name
recH <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"recElabHole")
           EState
aux <- forall aux. Elab' aux aux
getAux
           Ctxt TypeInfo
datatypes <- forall aux. Elab' aux (Ctxt TypeInfo)
get_datatypes
           Env
env <- forall aux. Elab' aux Env
get_env
           Int
g_next <- forall aux. Elab' aux Int
get_global_nextname

           (Context
ctxt', ES (ProofState
p, EState
aux') String
_ Maybe (ElabState EState)
_) <-
              do (ES (ProofState
current_p, EState
_) String
_ Maybe (ElabState EState)
_) <- forall s (m :: * -> *). MonadState s m => m s
get
                 forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ forall aux a.
aux -> Elab' aux a -> ProofState -> TC (a, ElabState aux)
runElab EState
aux
                             (do ElabInfo -> IState -> FC -> Env -> Term -> [String] -> ElabD Term
runElabAction ElabInfo
info IState
ist FC
fc [] Term
script [String]
ns
                                 Context
ctxt' <- forall aux. Elab' aux Context
get_context
                                 forall (m :: * -> *) a. Monad m => a -> m a
return Context
ctxt')
                             ((Name
-> String -> Context -> Ctxt TypeInfo -> Int -> Term -> ProofState
newProof Name
recH (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt Ctxt TypeInfo
datatypes Int
g_next Term
goalTT)
                              { nextname :: Int
nextname = ProofState -> Int
nextname ProofState
current_p })
           forall aux. Context -> Elab' aux ()
set_context Context
ctxt'

           let tm_out :: Term
tm_out = ProofTerm -> Term
getProofTerm (ProofState -> ProofTerm
pterm ProofState
p)
           do (ES (ProofState
prf, EState
_) String
s Maybe (ElabState EState)
e) <- forall s (m :: * -> *). MonadState s m => m s
get
              let p' :: ProofState
p' = ProofState
prf { nextname :: Int
nextname = ProofState -> Int
nextname ProofState
p
                           , global_nextname :: Int
global_nextname = ProofState -> Int
global_nextname ProofState
p
                           }
              forall s (m :: * -> *). MonadState s m => s -> m ()
put (forall aux.
(ProofState, aux)
-> String -> Maybe (ElabState aux) -> ElabState aux
ES (ProofState
p', EState
aux') String
s Maybe (ElabState EState)
e)
           Env
env' <- forall aux. Elab' aux Env
get_env
           (Term
tm, Term
ty, UCs
_) <- forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall a b. (a -> b) -> a -> b
$ String -> Context -> Env -> Raw -> Term -> TC (Term, Term, UCs)
recheck (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt' Env
env (Term -> Raw
forget Term
tm_out) Term
tm_out
           let (Raw
tm', Raw
ty') = (Term -> Raw
reflect Term
tm, Term -> Raw
reflect Term
ty)
           forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$
             (Raw, Raw) -> (Raw, Raw) -> Raw
rawPair (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT", Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT")
                     (Raw
tm', Raw
ty')
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Metavar"
      = do ~[Term
n] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Name
n' <- Term -> StateT (ElabState EState) TC Name
reifyTTName Term
n
           Context
ctxt <- forall aux. Elab' aux Context
get_context
           Term
ptm <- forall aux. Elab' aux Term
get_term
           -- 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'
           forall aux. Elab' aux ()
attack
           forall aux. [Name] -> [Name] -> Name -> Elab' aux Name
defer [Name]
unique_used [Name]
lin_used Name
mvn
           forall aux. Elab' aux ()
solve
           ElabD Term
returnUnit
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Fixity"
      = do ~[Term
op'] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           Term
opTm <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
op'
           case Term
opTm of
             Constant (Str String
op) ->
               let opChars :: String
opChars = String
":!#$%&*+./<=>?@\\^|-~"
                   invalidOperators :: [String]
invalidOperators = [String
":", String
"=>", String
"->", String
"<-", String
"=", String
"?=", String
"|", String
"**", String
"==>", String
"\\", String
"%", String
"~", String
"?", String
"!"]
                   fixities :: [FixDecl]
fixities = IState -> [FixDecl]
idris_infixes IState
ist
               in if Bool -> Bool
not (forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (forall a b c. (a -> b -> c) -> b -> a -> c
flip forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
opChars) String
op) Bool -> Bool -> Bool
|| forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
elem String
op [String]
invalidOperators
                     then forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"'" forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ String
"' is not a valid operator name."
                     else case forall a. Eq a => [a] -> [a]
nub [Fixity
f | Fix Fixity
f String
someOp <- [FixDecl]
fixities, String
someOp forall a. Eq a => a -> a -> Bool
== String
op] of
                            []   -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"No fixity found for operator '" forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ String
"'."
                            [Fixity
f]  -> forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall a b. (a, b) -> a
fst forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall aux. Raw -> Elab' aux (Term, Term)
checkClosed forall a b. (a -> b) -> a -> b
$ Fixity -> Raw
reflectFixity Fixity
f
                            [Fixity]
many -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
InternalMsg forall a b. (a -> b) -> a -> b
$ String
"Ambiguous fixity for '" forall a. [a] -> [a] -> [a]
++ String
op forall a. [a] -> [a] -> [a]
++ String
"'!  Found " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Fixity]
many
             Term
_ -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall t. String -> Err' t
Msg forall a b. (a -> b) -> a -> b
$ String
"Not a constant string for an operator name: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
opTm
      | Name
n forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Debug"
      = do ~[Term
ty, Term
msg] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
2 Term
tac [Term]
args
           Term
msg' <- forall {aux}. Term -> StateT (ElabState aux) TC Term
eval Term
msg
           [ErrorReportPart]
parts <- Term -> ElabD [ErrorReportPart]
reifyReportParts Term
msg
           forall aux a. [ErrorReportPart] -> Elab' aux a
debugElaborator [ErrorReportPart]
parts
    runTacTm Term
x = forall a. Term -> ElabD a
elabScriptStuck Term
x

-- 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 <- forall aux. Elab' aux Env
get_env
         Term
g <- forall aux. Elab' aux Term
goal
         let tac' :: PTactic
tac' = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IState -> [Name] -> PTerm -> PTerm
addImplBound IState
ist (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
env)) PTactic
tac
         if Bool
autoSolve
            then PTactic -> ElabD ()
runT PTactic
tac'
            else forall aux. Elab' aux () -> Maybe Err -> Elab' aux ()
no_errors (PTactic -> ElabD ()
runT PTactic
tac')
                   (forall a. a -> Maybe a
Just (forall t. t -> [(Name, t)] -> Err' t
CantSolveGoal Term
g (forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, forall b. Binder b -> b
binderTy Binder Term
b)) Env
env)))
  where
    runT :: PTactic -> ElabD ()
runT (Intro []) = do Term
g <- forall aux. Elab' aux Term
goal
                         forall aux. Elab' aux ()
attack; forall aux. Maybe Name -> Elab' aux ()
intro (forall {a}. TT a -> Maybe a
bname Term
g)
      where
        bname :: TT a -> Maybe a
bname (Bind a
n Binder (TT a)
_ TT a
_) = forall a. a -> Maybe a
Just a
n
        bname TT a
_ = forall a. Maybe a
Nothing
    runT (Intro [Name]
xs) = forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (\Name
x -> do forall aux. Elab' aux ()
attack; forall aux. Maybe Name -> Elab' aux ()
intro (forall a. a -> Maybe a
Just Name
x)) [Name]
xs
    runT PTactic
Intros = do Term
g <- forall aux. Elab' aux Term
goal
                     forall aux. Elab' aux ()
attack;
                     forall aux. Maybe Name -> Elab' aux ()
intro (forall {a}. TT a -> Maybe a
bname Term
g)
                     forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (PTactic -> ElabD ()
runT forall t. PTactic' t
Intros)
                          (forall (m :: * -> *) a. Monad m => a -> m a
return ()) Bool
True
      where
        bname :: TT a -> Maybe a
bname (Bind a
n Binder (TT a)
_ TT a
_) = forall a. a -> Maybe a
Just a
n
        bname TT a
_ = forall a. Maybe a
Nothing
    runT (Exact PTerm
tm) = do IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
                         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
    runT (MatchRefine Name
fn)
        = do [(Name, [Bool])]
fnimps <-
               case forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
                    [] -> do [Bool]
a <- forall {aux}. Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
fn
                             forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
fn, [Bool]
a)]
                    [(Name, [PArg])]
ns -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
n, [PArg]
a) -> (Name
n, forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Bool
True) [PArg]
a)) [(Name, [PArg])]
ns)
             let tacs :: [(Elab' aux [(Name, Name)], Name)]
tacs = forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
fn', [Bool]
imps) ->
                                 (forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
match_apply (Name -> Raw
Var Name
fn') (forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x, Int
0)) [Bool]
imps),
                                     Name
fn')) [(Name, [Bool])]
fnimps
             forall aux a. [(Elab' aux a, Name)] -> Elab' aux a
tryAll forall {aux}. [(Elab' aux [(Name, Name)], Name)]
tacs
             forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
       where envArgs :: Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
n = do Env
e <- forall aux. Elab' aux Env
get_env
                            case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
e of
                               Just Binder Term
t -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Bool
False)
                                                      (forall n. TT n -> [(n, TT n)]
getArgTys (forall b. Binder b -> b
binderTy Binder Term
t))
                               Maybe (Binder Term)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    runT (Refine Name
fn [])
        = do [(Name, [Bool])]
fnimps <-
               case forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
                    [] -> do [Bool]
a <- forall {aux}. Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
fn
                             forall (m :: * -> *) a. Monad m => a -> m a
return [(Name
fn, [Bool]
a)]
                    [(Name, [PArg])]
ns -> forall (m :: * -> *) a. Monad m => a -> m a
return (forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
n, [PArg]
a) -> (Name
n, forall a b. (a -> b) -> [a] -> [b]
map forall {t}. PArg' t -> Bool
isImp [PArg]
a)) [(Name, [PArg])]
ns)
             let tacs :: [(Elab' aux [(Name, Name)], Name)]
tacs = forall a b. (a -> b) -> [a] -> [b]
map (\ (Name
fn', [Bool]
imps) ->
                                 (forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
fn') (forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x, Int
0)) [Bool]
imps),
                                     Name
fn')) [(Name, [Bool])]
fnimps
             forall aux a. [(Elab' aux a, Name)] -> Elab' aux a
tryAll forall {aux}. [(Elab' aux [(Name, Name)], Name)]
tacs
             forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
       where isImp :: PArg' t -> Bool
isImp (PImp Int
_ Bool
_ [ArgOpt]
_ Name
_ t
_) = Bool
True
             isImp PArg' t
_ = Bool
False
             envArgs :: Name -> StateT (ElabState aux) TC [Bool]
envArgs Name
n = do Env
e <- forall aux. Elab' aux Env
get_env
                            case forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
e of
                               Just Binder Term
t -> forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ forall a b. (a -> b) -> [a] -> [b]
map (forall a b. a -> b -> a
const Bool
False)
                                                      (forall n. TT n -> [(n, TT n)]
getArgTys (forall b. Binder b -> b
binderTy Binder Term
t))
                               Maybe (Binder Term)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return []
    runT (Refine Name
fn [Bool]
imps) = do [(Name, Name)]
ns <- forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Name -> Raw
Var Name
fn) (forall a b. (a -> b) -> [a] -> [b]
map (\Bool
x -> (Bool
x,Int
0)) [Bool]
imps)
                               forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
    runT PTactic
DoUnify = do forall aux. Elab' aux ()
unify_all
                      forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
    runT (Claim Name
n PTerm
tm) = do Name
tmHole <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"newGoal")
                           forall aux. Name -> Raw -> Elab' aux ()
claim Name
tmHole Raw
RType
                           forall aux. Name -> Raw -> Elab' aux ()
claim Name
n (Name -> Raw
Var Name
tmHole)
                           forall aux. Name -> Elab' aux ()
focus Name
tmHole
                           IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
                           forall aux. Name -> Elab' aux ()
focus Name
n
    runT (Equiv PTerm
tm) -- let bind tm, then
              = do forall aux. Elab' aux ()
attack
                   Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"ety")
                   forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
                   Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"eqval")
                   forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
                   Name
letn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"equiv_val")
                   forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
                   forall aux. Name -> Elab' aux ()
focus Name
tyn
                   IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
                   forall aux. Name -> Elab' aux ()
focus Name
valn
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
    runT (Rewrite PTerm
tm) -- to elaborate tm, let bind it, then rewrite by that
              = do forall aux. Elab' aux ()
attack; -- (h:_) <- get_holes
                   Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rty")
                   -- start_unify h
                   forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
                   Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rval")
                   forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
                   Name
letn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"rewrite_rule")
                   forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
                   forall aux. Name -> Elab' aux ()
focus Name
valn
                   IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
                   forall aux. Raw -> Elab' aux ()
rewrite (Name -> Raw
Var Name
letn)
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
    runT (LetTac Name
n PTerm
tm)
              = do forall aux. Elab' aux ()
attack
                   Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
                   forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
                   Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
                   forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
                   Name
letn <- forall aux. Name -> Elab' aux Name
unique_hole Name
n
                   forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
                   forall aux. Name -> Elab' aux ()
focus Name
valn
                   IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
    runT (LetTacTy Name
n PTerm
ty PTerm
tm)
              = do forall aux. Elab' aux ()
attack
                   Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
                   forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
                   Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
                   forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
                   Name
letn <- forall aux. Name -> Elab' aux Name
unique_hole Name
n
                   forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
                   forall aux. Name -> Elab' aux ()
focus Name
tyn
                   IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
ty
                   forall aux. Name -> Elab' aux ()
focus Name
valn
                   IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
                   forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
    runT PTactic
Compute = forall aux. Elab' aux ()
compute
    runT PTactic
Trivial = do IState -> ElabD ()
trivial' IState
ist; forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
    runT PTactic
TCImplementation = PTactic -> ElabD ()
runT (forall t. t -> PTactic' t
Exact (FC -> PTerm
PResolveTC FC
emptyFC))
    runT (ProofSearch Bool
rec Bool
prover Int
depth Maybe Name
top [Name]
psns [Name]
hints)
         = do IState
-> Bool
-> Bool
-> Int
-> Bool
-> Maybe Name
-> Name
-> [Name]
-> [Name]
-> ElabD ()
proofSearch' IState
ist Bool
rec Bool
False Int
depth Bool
prover Maybe Name
top Name
fn [Name]
psns [Name]
hints
              forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when Bool
autoSolve forall aux. Elab' aux ()
solveAll
    runT (Focus Name
n) = forall aux. Name -> Elab' aux ()
focus Name
n
    runT PTactic
Unfocus = do [Name]
hs <- forall aux. Elab' aux [Name]
get_holes
                      case [Name]
hs of
                        []      -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
                        (Name
h : [Name]
_) -> forall aux. Name -> Elab' aux ()
movelast Name
h
    runT PTactic
Solve = forall aux. Elab' aux ()
solve
    runT (Try PTactic
l PTactic
r) = do forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (PTactic -> ElabD ()
runT PTactic
l) (PTactic -> ElabD ()
runT PTactic
r) Bool
True
    runT (TSeq PTactic
l PTactic
r) = do PTactic -> ElabD ()
runT PTactic
l; PTactic -> ElabD ()
runT PTactic
r
    runT (ApplyTactic PTerm
tm) = do Env
tenv <- forall aux. Elab' aux Env
get_env -- store the environment
                               Term
tgoal <- forall aux. Elab' aux Term
goal -- store the goal
                               forall aux. Elab' aux ()
attack -- let f : List (TTName, Binder TT) -> TT -> Tactic = tm in ...
                               Name
script <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"script")
                               forall aux. Name -> Raw -> Elab' aux ()
claim Name
script Raw
scriptTy
                               Name
scriptvar <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scriptvar" )
                               forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
scriptvar RigCount
RigW Raw
scriptTy (Name -> Raw
Var Name
script)
                               forall aux. Name -> Elab' aux ()
focus Name
script
                               IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
tm
                               (Term
script', Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
scriptvar)
                               -- now that we have the script apply
                               -- it to the reflected goal and context
                               Name
restac <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"restac")
                               forall aux. Name -> Raw -> Elab' aux ()
claim Name
restac Raw
tacticTy
                               forall aux. Name -> Elab' aux ()
focus Name
restac
                               forall aux. Raw -> Elab' aux ()
fill (Raw -> [Raw] -> Raw
raw_apply (Term -> Raw
forget Term
script')
                                               [Env -> Raw
reflectEnv Env
tenv, Term -> Raw
reflect Term
tgoal])
                               Term
restac' <- forall aux. Elab' aux Term
get_guess
                               forall aux. Elab' aux ()
solve
                               -- normalise the result in order to
                               -- reify it
                               Context
ctxt <- forall aux. Elab' aux Context
get_context
                               Env
env <- forall aux. Elab' aux Env
get_env
                               let tactic :: Term
tactic = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
restac'
                               Term -> ElabD ()
runReflected Term
tactic
        where tacticTy :: Raw
tacticTy = Name -> Raw
Var (String -> Name
reflm String
"Tactic")
              listTy :: Raw
listTy = Name -> Raw
Var (Name -> [String] -> Name
sNS (String -> Name
sUN String
"List") [String
"List", String
"Prelude"])
              scriptTy :: Raw
scriptTy = (Name -> Binder Raw -> Raw -> Raw
RBind (Int -> String -> Name
sMN Int
0 String
"__pi_arg")
                                (forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW forall a. Maybe a
Nothing (Raw -> Raw -> Raw
RApp Raw
listTy Raw
envTupleType) Raw
RType)
                                    (Name -> Binder Raw -> Raw -> Raw
RBind (Int -> String -> Name
sMN Int
1 String
"__pi_arg")
                                           (forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW forall a. Maybe a
Nothing (Name -> Raw
Var forall a b. (a -> b) -> a -> b
$ String -> Name
reflm String
"TT") Raw
RType) Raw
tacticTy))
    runT (ByReflection PTerm
tm) -- run the reflection function 'tm' on the
                           -- goal, then apply the resulting reflected Tactic
        = do Term
tgoal <- forall aux. Elab' aux Term
goal
             forall aux. Elab' aux ()
attack
             Name
script <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"script")
             forall aux. Name -> Raw -> Elab' aux ()
claim Name
script Raw
scriptTy
             Name
scriptvar <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"scriptvar" )
             forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
scriptvar RigCount
RigW Raw
scriptTy (Name -> Raw
Var Name
script)
             forall aux. Name -> Elab' aux ()
focus Name
script
             Term
ptm <- forall aux. Elab' aux Term
get_term
             Env
env <- forall aux. Elab' aux Env
get_env
             let denv :: [(Name, Term)]
denv = forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, forall b. Binder b -> b
binderTy Binder Term
b)) Env
env
             IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac")
                  (FC -> PTerm -> [PArg] -> PTerm
PApp FC
emptyFC PTerm
tm [forall {t}. t -> PArg' t
pexp (IState
-> [PArg]
-> [(Name, Term)]
-> Term
-> Bool
-> Bool
-> Bool
-> PTerm
delabTy' IState
ist [] [(Name, Term)]
denv Term
tgoal Bool
True Bool
True Bool
True)])
             (Term
script', Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
scriptvar)
             -- now that we have the script apply
             -- it to the reflected goal
             Name
restac <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"restac")
             forall aux. Name -> Raw -> Elab' aux ()
claim Name
restac Raw
tacticTy
             forall aux. Name -> Elab' aux ()
focus Name
restac
             forall aux. Raw -> Elab' aux ()
fill (Term -> Raw
forget Term
script')
             Term
restac' <- forall aux. Elab' aux Term
get_guess
             forall aux. Elab' aux ()
solve
             -- normalise the result in order to
             -- reify it
             Context
ctxt <- forall aux. Elab' aux Context
get_context
             Env
env <- forall aux. Elab' aux Env
get_env
             let tactic :: Term
tactic = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
restac'
             Term -> ElabD ()
runReflected Term
tactic
      where tacticTy :: Raw
tacticTy = Name -> Raw
Var (String -> Name
reflm String
"Tactic")
            scriptTy :: Raw
scriptTy = Raw
tacticTy

    runT (Reflect PTerm
v) = do forall aux. Elab' aux ()
attack -- let x = reflect v in ...
                          Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
                          forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
                          Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
                          forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
                          Name
letn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letvar")
                          forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
                          forall aux. Name -> Elab' aux ()
focus Name
valn
                          IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
v
                          (Term
value, Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
letn)
                          Context
ctxt <- forall aux. Elab' aux Context
get_context
                          Env
env <- forall aux. Elab' aux Env
get_env
                          let value' :: Term
value' = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
value
                          Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
autoSolve IState
ist Maybe FC
perhapsFC Name
fn (forall t. t -> PTactic' t
Exact forall a b. (a -> b) -> a -> b
$ Raw -> PTerm
PQuote (Term -> Raw
reflect Term
value'))
    runT (Fill PTerm
v) = do forall aux. Elab' aux ()
attack -- let x = fill x in ...
                       Name
tyn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letty")
                       forall aux. Name -> Raw -> Elab' aux ()
claim Name
tyn Raw
RType
                       Name
valn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letval")
                       forall aux. Name -> Raw -> Elab' aux ()
claim Name
valn (Name -> Raw
Var Name
tyn)
                       Name
letn <- forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"letvar")
                       forall aux. Name -> RigCount -> Raw -> Raw -> Elab' aux ()
letbind Name
letn RigCount
RigW (Name -> Raw
Var Name
tyn) (Name -> Raw
Var Name
valn)
                       forall aux. Name -> Elab' aux ()
focus Name
valn
                       IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
toplevel ElabMode
ERHS [] (Int -> String -> Name
sMN Int
0 String
"tac") PTerm
v
                       (Term
value, Term
_) <- forall aux. Raw -> Elab' aux (Term, Term)
get_type_val (Name -> Raw
Var Name
letn)
                       Context
ctxt <- forall aux. Elab' aux Context
get_context
                       Env
env <- forall aux. Elab' aux Env
get_env
                       let value' :: Term
value' = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
value
                       Raw
rawValue <- Term -> StateT (ElabState EState) TC Raw
reifyRaw Term
value'
                       Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
autoSolve IState
ist Maybe FC
perhapsFC Name
fn (forall t. t -> PTactic' t
Exact forall a b. (a -> b) -> a -> b
$ Raw -> PTerm
PQuote Raw
rawValue)
    runT (GoalType String
n PTactic
tac) = do Term
g <- forall aux. Elab' aux Term
goal
                               case forall n. TT n -> (TT n, [TT n])
unApply Term
g of
                                    (P NameType
_ Name
n' Term
_, [Term]
_) ->
                                       if Name -> Name
nsroot Name
n' forall a. Eq a => a -> a -> Bool
== String -> Name
sUN String
n
                                          then PTactic -> ElabD ()
runT PTactic
tac
                                          else forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong goal type"
                                    (Term, [Term])
_ -> forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Wrong goal type"
    runT PTactic
ProofState = do Term
g <- forall aux. Elab' aux Term
goal
                         forall (m :: * -> *) a. Monad m => a -> m a
return ()
    runT PTactic
Skip = forall (m :: * -> *) a. Monad m => a -> m a
return ()
    runT (TFail [ErrorReportPart]
err) = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. [[ErrorReportPart]] -> Err' t -> Err' t
ReflectionError [[ErrorReportPart]
err] (forall t. String -> Err' t
Msg String
"")
    runT PTactic
SourceFC =
      case Maybe FC
perhapsFC of
        Maybe FC
Nothing -> forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg String
"There is no source location available."
        Just FC
fc ->
          do forall aux. Raw -> Elab' aux ()
fill forall a b. (a -> b) -> a -> b
$ FC -> Raw
reflectFC FC
fc
             forall aux. Elab' aux ()
solve
    runT PTactic
Qed = forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall a. Err -> TC a
tfail forall a b. (a -> b) -> a -> b
$ forall t. String -> Err' t
Msg String
"The qed command is only valid in the interactive prover"
    runT PTactic
x = forall (m :: * -> *) a. MonadFail m => String -> m a
fail forall a b. (a -> b) -> a -> b
$ String
"Not implemented " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show PTactic
x

    runReflected :: Term -> ElabD ()
runReflected Term
t = do PTactic
t' <- IState -> Term -> ElabD PTactic
reify IState
ist Term
t
                        Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
autoSolve IState
ist Maybe FC
perhapsFC Name
fn PTactic
t'

elaboratingArgErr :: [(Name, Name)] -> Err -> Err
elaboratingArgErr :: [(Name, Name)] -> Err -> Err
elaboratingArgErr [] Err
err = Err
err
elaboratingArgErr ((Name
f,Name
x):[(Name, Name)]
during) Err
err = forall a. a -> Maybe a -> a
fromMaybe Err
err (forall {t}. Err' t -> Maybe (Err' t)
rewrite Err
err)
  where rewrite :: Err' t -> Maybe (Err' t)
rewrite (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err' t
_) = forall a. Maybe a
Nothing
        rewrite (ProofSearchFail Err' t
e) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap forall t. Err' t -> Err' t
ProofSearchFail (Err' t -> Maybe (Err' t)
rewrite Err' t
e)
        rewrite (At FC
fc Err' t
e) = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (forall t. FC -> Err' t -> Err' t
At FC
fc) (Err' t -> Maybe (Err' t)
rewrite Err' t
e)
        rewrite Err' t
err = forall a. a -> Maybe a
Just (forall t. Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
ElaboratingArg Name
f Name
x [(Name, Name)]
during Err' t
err)


withErrorReflection :: Idris a -> Idris a
withErrorReflection :: forall a. Idris a -> Idris a
withErrorReflection Idris a
x = forall a. Idris a -> (Err -> Idris a) -> Idris a
idrisCatch Idris a
x (\ Err
e -> Err -> Idris Err
handle Err
e forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= forall a. Err -> Idris a
ierror)
    where handle :: Err -> Idris Err
          handle :: Err -> Idris Err
handle e :: Err
e@(ReflectionError [[ErrorReportPart]]
_ Err
_)  = do Int -> String -> Idris ()
logElab Int
3 String
"Skipping reflection of error reflection result"
                                               forall (m :: * -> *) a. Monad m => a -> m a
return Err
e -- 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"
                                               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
                                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall t. FC -> Err' t -> Err' t
At FC
fc Err
err')
          handle e :: Err
e@(Elaborating String
what Name
n Maybe Term
ty Err
err) = do Int -> String -> Idris ()
logElab Int
3 String
"Reflecting body of Elaborating"
                                                    Err
err' <- Err -> Idris Err
handle Err
err
                                                    forall (m :: * -> *) a. Monad m => a -> m a
return (forall t. String -> Name -> Maybe t -> Err' t -> Err' t
Elaborating String
what Name
n Maybe Term
ty Err
err')
          handle e :: Err
e@(ElaboratingArg Name
f Name
a [(Name, Name)]
prev Err
err) = do Int -> String -> Idris ()
logElab Int
3 String
"Reflecting body of ElaboratingArg"
                                                      [Name]
hs <- Name -> Name -> Idris [Name]
getFnHandlers Name
f Name
a
                                                      Err
err' <- if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [Name]
hs
                                                                 then Err -> Idris Err
handle Err
err
                                                                 else Err -> [Name] -> Idris Err
applyHandlers Err
err [Name]
hs
                                                      forall (m :: * -> *) a. Monad m => a -> m a
return (forall t. Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
ElaboratingArg Name
f Name
a [(Name, Name)]
prev Err
err')
          -- 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 (forall a. Show a => a -> String
show Err
e)
                        let handlers :: [Name]
handlers = IState -> [Name]
idris_errorhandlers IState
ist
                        Err -> [Name] -> Idris Err
applyHandlers Err
e [Name]
handlers
          getFnHandlers :: Name -> Name -> Idris [Name]
          getFnHandlers :: Name -> Name -> Idris [Name]
getFnHandlers Name
f Name
arg = do IState
ist <- Idris IState
getIState
                                   let funHandlers :: Map Name (Set Name)
funHandlers = forall b a. b -> (a -> b) -> Maybe a -> b
maybe forall k a. Map k a
M.empty forall a. a -> a
id forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                                     forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
f forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                                     IState -> Ctxt (Map Name (Set Name))
idris_function_errorhandlers forall a b. (a -> b) -> a -> b
$ IState
ist
                                   forall (m :: * -> *) a. Monad m => a -> m a
return forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall b a. b -> (a -> b) -> Maybe a -> b
maybe [] forall a. Set a -> [a]
S.toList forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall k a. Ord k => k -> Map k a -> Maybe a
M.lookup Name
arg forall a b. (a -> b) -> a -> b
$ Map Name (Set Name)
funHandlers


          applyHandlers :: Err -> [Name] -> Idris Err
applyHandlers Err
e [Name]
handlers =
                      do IState
ist <- Idris IState
getIState
                         let err :: Err
err = forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (IState -> Term -> Term
errReverse IState
ist) Err
e
                         Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
"Using reflection handlers " forall a. [a] -> [a] -> [a]
++
                                    forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
", " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Name]
handlers))
                         let reports :: [Raw]
reports = forall a b. (a -> b) -> [a] -> [b]
map (\Name
n -> Raw -> Raw -> Raw
RApp (Name -> Raw
Var Name
n) (Err -> Raw
reflectErr Err
err)) [Name]
handlers

                         -- 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 forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (Context -> Env -> Raw -> TC (Term, Term)
check (IState -> Context
tt_ctxt IState
ist) []) [Raw]
reports of
                                       Error Err
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return [] -- ierror $ ReflectionFailed "Type error while constructing reflected error" e
                                       OK [(Term, Term)]
hs   -> 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 = forall a b. (a -> b) -> [a] -> [b]
map (Context -> Env -> Term -> Term
normaliseAll Context
ctxt []) (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Term, Term)]
handlers)
                         Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
"New error message info: " forall a. [a] -> [a] -> [a]
++ forall (t :: * -> *) a. Foldable t => t [a] -> [a]
concat (forall a. a -> [a] -> [a]
intersperse String
" and " (forall a b. (a -> b) -> [a] -> [b]
map forall a. Show a => a -> String
show [Term]
results))

                         -- For each handler term output, either discard it if it is Nothing or reify it the Haskell equivalent
                         let errorpartsTT :: [[Term]]
errorpartsTT = forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Term -> Maybe [Term]
unList (forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Term -> Maybe Term
fromTTMaybe [Term]
results)
                         [[ErrorReportPart]]
errorparts <- case forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM (forall (t :: * -> *) (m :: * -> *) a b.
(Traversable t, Monad m) =>
(a -> m b) -> t a -> m (t b)
mapM Term -> Either Err ErrorReportPart
reifyReportPart) [[Term]]
errorpartsTT of
                                         Left Err
err -> forall a. Err -> Idris a
ierror Err
err
                                         Right [[ErrorReportPart]]
ok -> forall (m :: * -> *) a. Monad m => a -> m a
return [[ErrorReportPart]]
ok
                         forall (m :: * -> *) a. Monad m => a -> m a
return forall a b. (a -> b) -> a -> b
$ case [[ErrorReportPart]]
errorparts of
                                    []    -> Err
e
                                    [[ErrorReportPart]]
parts -> forall t. [[ErrorReportPart]] -> Err' t -> Err' t
ReflectionError [[ErrorReportPart]]
errorparts Err
e

solveAll :: Elab' aux ()
solveAll = forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do forall aux. Elab' aux ()
solve; Elab' aux ()
solveAll) (forall (m :: * -> *) a. Monad m => a -> m a
return ())

-- | 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.
  forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ (forall a. [a] -> [a]
reverse [RDeclInstructions]
steps) forall a b. (a -> b) -> a -> b
$ \case
    RTyDeclInstrs Name
n FC
fc [PArg]
impls Term
ty ->
      do Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
"Declaration from tactics: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n forall a. [a] -> [a] -> [a]
++ String
" : " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Term
ty
         Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
"  It has impls " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [PArg]
impls
         (IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits :: Ctxt [PArg]
idris_implicits =
                                    forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
n [PArg]
impls (IState -> Ctxt [PArg]
idris_implicits IState
i) }
         IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCImp Name
n)
         [(Name, (Int, Maybe Name, Term, [Name]))]
ds <- ElabInfo
-> FC
-> (Name -> Err -> Err)
-> Bool
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> Idris [(Name, (Int, Maybe Name, Term, [Name]))]
checkDef ElabInfo
info FC
fc (\Name
_ Err
e -> Err
e) Bool
True [(Name
n, (-Int
1, forall a. Maybe a
Nothing, Term
ty, []))]
         IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCDef Name
n)
         Context
ctxt <- Idris Context
getContext
         case Name -> Context -> [Def]
lookupDef Name
n Context
ctxt of
           (TyDecl NameType
_ Term
_ : [Def]
_) ->
             -- 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' = forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, (Int
i, Maybe Name
top, Term
t, [Name]
ns)) -> (Name
n, (Int
i, Maybe Name
top, Term
t, [Name]
ns, Bool
True, Bool
True))) [(Name, (Int, Maybe Name, Term, [Name]))]
ds
             in [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))] -> Idris ()
addDeferred [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))]
ds'
           [Def]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
    RDatatypeDeclInstrs Name
n [PArg]
impls ->
      do IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCDef Name
n)
         (IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits :: Ctxt [PArg]
idris_implicits = forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
n [PArg]
impls (IState -> Ctxt [PArg]
idris_implicits IState
i) }
         IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCImp Name
n)

    RDatatypeDefnInstrs Name
tyn Term
tyconTy [(Name, [PArg], Term)]
ctors ->
      do let cn :: (a, b, c) -> a
cn (a
n, b
_, c
_) = a
n
             cty :: (a, b, c) -> c
cty (a
_, b
_, c
t) = c
t
         IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCDef Name
tyn)
         forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (IBCWrite -> Idris ()
addIBC forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> IBCWrite
IBCDef forall b c a. (b -> c) -> (a -> b) -> a -> c
. forall {a} {b} {c}. (a, b, c) -> a
cn) [(Name, [PArg], Term)]
ctors
         Context
ctxt <- Idris Context
getContext
         let params :: [Int]
params = Name -> Term -> [Term] -> [Int]
findParams Name
tyn (Context -> Env -> Term -> Term
normalise Context
ctxt [] Term
tyconTy) (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> c
cty [(Name, [PArg], Term)]
ctors)
         let typeInfo :: TypeInfo
typeInfo = [Name] -> Bool -> DataOpts -> [Int] -> [Name] -> Bool -> TypeInfo
TI (forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
cn [(Name, [PArg], Term)]
ctors) Bool
False [] [Int]
params [] Bool
False
         -- implicit precondition to IBCData is that idris_datatypes on the IState is populated.
         -- otherwise writing the IBC just fails silently!
         (IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_datatypes :: Ctxt TypeInfo
idris_datatypes =
                                    forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
tyn TypeInfo
typeInfo (IState -> Ctxt TypeInfo
idris_datatypes IState
i) }
         IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCData Name
tyn)


         Int
ttag <- Idris Int
getName -- 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)

         forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Name, [PArg], Term)]
ctors forall a b. (a -> b) -> a -> b
$ \(Name
cn, [PArg]
impls, Term
_) ->
           do (IState -> IState) -> Idris ()
updateIState forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits :: Ctxt [PArg]
idris_implicits = forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
cn [PArg]
impls (IState -> Ctxt [PArg]
idris_implicits IState
i) }
              IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCImp Name
cn)

         forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ [(Name, [PArg], Term)]
ctors forall a b. (a -> b) -> a -> b
$ \(Name
ctorN, [PArg]
_, Term
_) ->
           do (FC, Name) -> Idris ()
totcheck (FC
NoFC, Name
ctorN)
              Context
ctxt <- IState -> Context
tt_ctxt forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$> Idris IState
getIState
              case Name -> Context -> Maybe Term
lookupTyExact Name
ctorN Context
ctxt of
                Just Term
cty -> do [Name] -> (Name, Term) -> Idris Totality
checkPositive (Name
tyn forall a. a -> [a] -> [a]
: forall a b. (a -> b) -> [a] -> [b]
map forall {a} {b} {c}. (a, b, c) -> a
cn [(Name, [PArg], Term)]
ctors) (Name
ctorN, Term
cty)
                               forall (m :: * -> *) a. Monad m => a -> m a
return ()
                Maybe Term
Nothing -> forall (m :: * -> *) a. Monad m => a -> m a
return ()

         case [(Name, [PArg], Term)]
ctors of
            [(Name, [PArg], Term)
ctor] -> do Name -> Idris ()
setDetaggable (forall {a} {b} {c}. (a, b, c) -> a
cn (Name, [PArg], Term)
ctor); Name -> Idris ()
setDetaggable Name
tyn
                         IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCOpt (forall {a} {b} {c}. (a, b, c) -> a
cn (Name, [PArg], Term)
ctor)); IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCOpt Name
tyn)
            [(Name, [PArg], Term)]
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return ()
         -- TODO: inaccessible

    RAddImplementation Name
interfaceName Name
implName ->
      do -- The interface resolution machinery relies on a special
         Int -> String -> Idris ()
logElab Int
2 forall a b. (a -> b) -> a -> b
$ String
"Adding elab script implementation " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
implName forall a. [a] -> [a] -> [a]
++
                     String
" for " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
interfaceName
         Bool -> Bool -> Name -> Name -> Idris ()
addImplementation Bool
False Bool
True Name
interfaceName Name
implName
         IBCWrite -> Idris ()
addIBC (Bool -> Bool -> Name -> Name -> IBCWrite
IBCImplementation Bool
False Bool
True Name
interfaceName Name
implName)
    RClausesInstrs Name
n [([(Name, Term)], Term, Term)]
cs ->
      do Int -> String -> Idris ()
logElab Int
3 forall a b. (a -> b) -> a -> b
$ String
"Pattern-matching definition from tactics: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show Name
n
         FC -> Name -> Idris ()
solveDeferred FC
emptyFC Name
n
         let lhss :: [([Name], Term)]
lhss = forall a b. (a -> b) -> [a] -> [b]
map (\([(Name, Term)]
ns, Term
lhs, Term
_) -> (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst [(Name, Term)]
ns, Term
lhs)) [([(Name, Term)], Term, Term)]
cs
         let fc :: FC
fc = String -> FC
fileFC String
"elab_reflected"
         [PTerm]
pmissing <-
           do IState
ist <- Idris IState
getIState
              [PTerm]
possible <- FC
-> Name
-> [([Name], Term)]
-> [PTerm]
-> StateT IState (ExceptT Err IO) [PTerm]
genClauses FC
fc Name
n [([Name], Term)]
lhss
                                     (forall a b. (a -> b) -> [a] -> [b]
map (\ ([Name]
ns, Term
lhs) ->
                                        IState -> Term -> Bool -> Bool -> PTerm
delab' IState
ist Term
lhs Bool
True Bool
True) [([Name], Term)]
lhss)
              [PTerm]
missing <- forall (m :: * -> *) a.
Applicative m =>
(a -> m Bool) -> [a] -> m [a]
filterM (Name -> PTerm -> Idris Bool
checkPossible Name
n) [PTerm]
possible
              let undef :: [PTerm]
undef = forall a. (a -> Bool) -> [a] -> [a]
filter (forall {t :: * -> *}.
Foldable t =>
IState -> t Term -> PTerm -> Bool
noMatch IState
ist (forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> b
snd [([Name], Term)]
lhss)) [PTerm]
missing
              forall (m :: * -> *) a. Monad m => a -> m a
return [PTerm]
undef
         let tot :: Totality
tot = if forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PTerm]
pmissing
                      then Totality
Unchecked -- 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 forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_patdefs :: Ctxt ([([(Name, Term)], Term, Term)], [PTerm])
idris_patdefs =
                                    forall a. Name -> a -> Ctxt a -> Ctxt a
addDef Name
n ([([(Name, Term)], Term, Term)]
cs, [PTerm]
pmissing) forall a b. (a -> b) -> a -> b
$ IState -> Ctxt ([([(Name, Term)], Term, Term)], [PTerm])
idris_patdefs IState
i }
         IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCDef Name
n)

         Context
ctxt <- Idris Context
getContext
         case Name -> Context -> Maybe Def
lookupDefExact Name
n Context
ctxt of
           Just (CaseOp CaseInfo
_ Term
_ [(Term, Bool)]
_ [Either Term (Term, Term)]
_ [([Name], Term, Term)]
_ CaseDefs
cd) ->
             -- 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 = forall a b. (a -> b) -> [a] -> [b]
map forall a b. (a, b) -> a
fst forall a b. (a -> b) -> a -> b
$ SC -> [Name] -> [(Name, [[Name]])]
findCalls SC
sc [Name]
scargs
             in do Int -> String -> Idris ()
logElab Int
2 forall a b. (a -> b) -> a -> b
$ String
"Called names in reflected elab: " forall a. [a] -> [a] -> [a]
++ forall a. Show a => a -> String
show [Name]
calls
                   Name -> [Name] -> Idris ()
addCalls Name
n [Name]
calls
                   IBCWrite -> Idris ()
addIBC forall a b. (a -> b) -> a -> b
$ Name -> IBCWrite
IBCCG Name
n
           Just Def
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO throw internal error
           Maybe Def
Nothing -> 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'
         forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Totality
tot' forall a. Eq a => a -> a -> Bool
/= Totality
Unchecked) forall a b. (a -> b) -> a -> b
$ IBCWrite -> Idris ()
addIBC (Name -> Totality -> IBCWrite
IBCTotal Name
n Totality
tot')
  where
    -- 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 -> Idris Bool
checkPossible Name
fname PTerm
lhs_in =
       do Context
ctxt <- Idris Context
getContext
          IState
ist <- Idris IState
getIState
          let lhs :: PTerm
lhs = IState -> PTerm -> PTerm
addImplPat IState
ist PTerm
lhs_in
          let fc :: FC
fc = String -> FC
fileFC String
"elab_reflected_totality"
          case forall aux a.
String
-> Context
-> Ctxt TypeInfo
-> Int
-> Name
-> Term
-> aux
-> Elab' aux a
-> TC (a, String)
elaborate (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt (IState -> Ctxt TypeInfo
idris_datatypes IState
ist) (IState -> Int
idris_name IState
ist) (Int -> String -> Name
sMN Int
0 String
"refPatLHS") Term
infP EState
initEState
                (forall aux a. FC -> Elab' aux a -> Elab' aux a
erun FC
fc (IState
-> ElabInfo
-> ElabMode
-> FnOpts
-> Name
-> [Name]
-> PTerm
-> ElabD ElabResult
buildTC IState
ist ElabInfo
info ElabMode
EImpossible [] Name
fname (PTerm -> [Name]
allNamesIn PTerm
lhs_in)
                                                                (PTerm -> PTerm
infTerm PTerm
lhs))) of
            OK (ElabResult Term
lhs' [(Name, (Int, Maybe Name, Term, [Name]))]
_ [PDecl]
_ Context
_ [RDeclInstructions]
_ Set (FC', OutputAnnotation)
_ Int
name', String
_) ->
              do -- 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 forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_name :: Int
idris_name = Int
name' }
                 case String -> Context -> Env -> Raw -> Term -> TC (Term, Term, UCs)
recheck (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt [] (Term -> Raw
forget Term
lhs_tm) Term
lhs_tm of
                      OK (Term, Term, UCs)
_ -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                      TC (Term, Term, UCs)
err -> forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            -- if it's a recoverable error, the case may become possible
            Error Err
err -> 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 = 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