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

License     : BSD3
Maintainer  : The Idris Community.
-}
{-# LANGUAGE LambdaCase, PatternGuards, ViewPatterns #-}
{-# OPTIONS_GHC -fwarn-incomplete-patterns #-}
module Idris.Elab.Term where

import Idris.AbsSyntax
import Idris.Core.CaseTree (SC'(STerm), findCalls)
import Idris.Core.Elaborate hiding (Tactic(..))
import Idris.Core.Evaluate
import Idris.Core.ProofTerm (getProofTerm)
import Idris.Core.TT
import Idris.Core.Typecheck (check, converts, isType, recheck)
import Idris.Core.Unify
import Idris.Core.WHNF (whnf)
import Idris.Coverage (genClauses, recoverableCoverage)
import Idris.Delaborate
import Idris.Elab.Quasiquote (extractUnquotes)
import Idris.Elab.Rewrite
import Idris.Elab.Utils
import Idris.Error
import Idris.ErrReverse (errReverse)
import Idris.Options
import Idris.ProofSearch
import Idris.Reflection
import Idris.Termination (buildSCG, checkDeclTotality, checkPositive)

import Control.Monad
import Control.Monad.State.Strict
import Data.Foldable (for_)
import Data.List
import qualified Data.Map as M
import Data.Maybe (fromMaybe, mapMaybe, maybeToList)
import qualified Data.Set as S
import Debug.Trace

data ElabMode = ETyDecl | ETransLHS | ELHS | EImpossible | ERHS
  deriving ElabMode -> ElabMode -> Bool
(ElabMode -> ElabMode -> Bool)
-> (ElabMode -> ElabMode -> Bool) -> Eq ElabMode
forall a. (a -> a -> Bool) -> (a -> a -> Bool) -> Eq a
$c== :: ElabMode -> ElabMode -> Bool
== :: ElabMode -> ElabMode -> Bool
$c/= :: ElabMode -> ElabMode -> Bool
/= :: ElabMode -> ElabMode -> Bool
Eq


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



-- | Using the elaborator, convert a term in raw syntax to a fully
-- elaborated, typechecked term.
--
-- If building a pattern match, we convert undeclared variables from
-- holes to pattern bindings.
--
-- Also find deferred names in the term and their types
build :: IState
      -> ElabInfo
      -> ElabMode
      -> FnOpts
      -> Name
      -> PTerm
      -> ElabD ElabResult
build :: IState
-> ElabInfo
-> ElabMode
-> FnOpts
-> Name
-> PTerm
-> ElabD ElabResult
build IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn PTerm
tm
    = do IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn PTerm
tm
         let inf :: Bool
inf = case Name -> Ctxt TIData -> [TIData]
forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
fn (IState -> Ctxt TIData
idris_tyinfodata IState
ist) of
                        [TIData
TIPartial] -> Bool
True
                        [TIData]
_ -> Bool
False

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

         when (not pattern) $ solveAutos ist fn False

         tm <- get_term
         ctxt <- get_context
         probs <- get_probs
         u <- getUnifyLog
         hs <- get_holes

         when (not pattern) $
           traceWhen u ("Remaining holes:\n" ++ show hs ++ "\n" ++
                        "Remaining problems:\n" ++ qshow probs) $
             do unify_all; matchProblems True; unifyProblems

         when (not pattern) $ solveAutos ist fn True

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

         when tydecl (do mkPat
                         update_term liftPats
                         update_term orderPats)
         EState is _ impls highlights _ _ <- getAux
         tt <- get_term
         ctxt <- get_context
         let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []
         log <- getLog
         g_nextname <- get_global_nextname
         if log /= ""
            then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
            else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
  where pattern :: Bool
pattern = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
        tydecl :: Bool
tydecl = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl

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

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

buildTC :: IState -> ElabInfo -> ElabMode -> FnOpts -> Name ->
         [Name] -> -- Cached names in the PTerm, before adding PAlternatives
         PTerm ->
         ElabD ElabResult
buildTC :: IState
-> ElabInfo
-> ElabMode
-> FnOpts
-> Name
-> [Name]
-> PTerm
-> ElabD ElabResult
buildTC IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn [Name]
ns PTerm
tm
    = do let inf :: Bool
inf = case Name -> Ctxt TIData -> [TIData]
forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
fn (IState -> Ctxt TIData
idris_tyinfodata IState
ist) of
                        [TIData
TIPartial] -> Bool
True
                        [TIData]
_ -> Bool
False
         -- set name supply to begin after highest index in tm
         [Name] -> ElabD ()
forall aux. [Name] -> Elab' aux ()
initNextNameFrom [Name]
ns
         IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn PTerm
tm
         probs <- Elab' EState Fails
forall aux. Elab' aux Fails
get_probs
         tm <- get_term
         case probs of
            [] -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
            ((Term
_,Term
_,Bool
_,Env
_,Err
e,[FailContext]
_,FailAt
_):Fails
es) -> if Bool
inf then () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                                           else TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Err -> TC ()
forall a. Err -> TC a
Error Err
e)
         dots <- get_dotterm
         -- 'dots' are the PHidden things which have not been solved by
         -- unification
         when (not (null dots)) $
            lift (Error (CantMatch (getInferTerm tm)))
         EState is _ impls highlights _ _ <- getAux
         tt <- get_term
         ctxt <- get_context
         let (tm, ds) = runState (collectDeferred (Just fn) (map fst is) ctxt tt) []
         log <- getLog
         g_nextname <- get_global_nextname
         if (log /= "")
            then trace log $ return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)
            else return (ElabResult tm ds (map snd is) ctxt impls highlights g_nextname)

-- | return whether arguments of the given constructor name can be
-- matched on. If they're polymorphic, no, unless the type has beed
-- made concrete by the time we get around to elaborating the
-- argument.
getUnmatchable :: Context -> Name -> [Bool]
getUnmatchable :: Context -> Name -> [Bool]
getUnmatchable Context
ctxt Name
n | Name -> Context -> Bool
isDConName Name
n Context
ctxt Bool -> Bool -> Bool
&& Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
inferCon
   = case Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt of
          Maybe Term
Nothing -> []
          Just Term
ty -> [Name] -> [[Name]] -> Term -> [Bool]
checkArgs [] [] Term
ty
  where checkArgs :: [Name] -> [[Name]] -> Type -> [Bool]
        checkArgs :: [Name] -> [[Name]] -> Term -> [Bool]
checkArgs [Name]
env [[Name]]
ns (Bind Name
n (Pi RigCount
_ Maybe ImplicitInfo
_ Term
t Term
_) Term
sc)
            = let env' :: [Name]
env' = case Term
t of
                              TType UExp
_ -> Name
n Name -> [Name] -> [Name]
forall a. a -> [a] -> [a]
: [Name]
env
                              Term
_ -> [Name]
env in
                  [Name] -> [[Name]] -> Term -> [Bool]
checkArgs [Name]
env' ([Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
intersect [Name]
env (Term -> [Name]
refsIn Term
t) [Name] -> [[Name]] -> [[Name]]
forall a. a -> [a] -> [a]
: [[Name]]
ns)
                            (Term -> Term -> Term
forall n. TT n -> TT n -> TT n
instantiate (NameType -> Name -> Term -> Term
forall n. NameType -> n -> TT n -> TT n
P NameType
Bound Name
n Term
t) Term
sc)
        checkArgs [Name]
env [[Name]]
ns Term
t
            = ([Name] -> Bool) -> [[Name]] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> Bool
not (Bool -> Bool) -> ([Name] -> Bool) -> [Name] -> Bool
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null) ([[Name]] -> [[Name]]
forall a. [a] -> [a]
reverse [[Name]]
ns)

getUnmatchable Context
ctxt Name
n = []

data ElabCtxt = ElabCtxt { ElabCtxt -> Bool
e_inarg :: Bool,
                           ElabCtxt -> Bool
e_isfn :: Bool, -- ^ Function part of application
                           ElabCtxt -> Bool
e_guarded :: Bool,
                           ElabCtxt -> Bool
e_intype :: Bool,
                           ElabCtxt -> Bool
e_qq :: Bool,
                           ElabCtxt -> Bool
e_nomatching :: Bool -- ^ can't pattern match
                         }

initElabCtxt :: ElabCtxt
initElabCtxt = Bool -> Bool -> Bool -> Bool -> Bool -> Bool -> ElabCtxt
ElabCtxt Bool
False Bool
False Bool
False Bool
False Bool
False Bool
False

goal_polymorphic :: ElabD Bool
goal_polymorphic :: Elab' EState Bool
goal_polymorphic =
   do ty <- Elab' EState Term
forall aux. Elab' aux Term
goal
      case ty of
           P NameType
_ Name
n Term
_ -> do env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
                         case lookupBinder n env of
                              Maybe (Binder Term)
Nothing -> Bool -> Elab' EState Bool
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
                              Maybe (Binder Term)
_ -> Bool -> Elab' EState Bool
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
           Term
_ -> Bool -> Elab' EState Bool
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False

-- | Returns the set of declarations we need to add to complete the
-- definition (most likely case blocks to elaborate) as well as
-- declarations resulting from user tactic scripts (%runElab)
elab :: IState
     -> ElabInfo
     -> ElabMode
     -> FnOpts
     -> Name
     -> PTerm
     -> ElabD ()
elab :: IState
-> ElabInfo -> ElabMode -> FnOpts -> Name -> PTerm -> ElabD ()
elab IState
ist ElabInfo
info ElabMode
emode FnOpts
opts Name
fn PTerm
tm
    = do let loglvl :: Int
loglvl = IOption -> Int
opt_logLevel (IState -> IOption
idris_options IState
ist)
         Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
when (Int
loglvl Int -> Int -> Bool
forall a. Ord a => a -> a -> Bool
> Int
5) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
unifyLog Bool
True
         ElabD ()
forall aux. Elab' aux ()
compute -- expand type synonyms, etc
         ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
initElabCtxt (ElabInfo -> Maybe FC
elabFC ElabInfo
info) PTerm
tm -- (in argument, guarded, in type, in qquote)
         est <- Elab' EState EState
forall aux. Elab' aux aux
getAux
         sequence_ (get_delayed_elab est)
         end_unify
         when (pattern || intransform) $
              -- convert remaining holes to pattern vars
              do unify_all
                 matchProblems False -- only the ones we matched earlier
                 unifyProblems
                 mkPat
                 update_term liftPats
         ptm <- get_term
         when pattern $
              -- Look for Rig1 (linear) pattern bindings
              do let pnms = RigCount -> IState -> [Name] -> Term -> [(Name, RigCount)]
findLinear RigCount
Rig1 IState
ist [] Term
ptm
                 update_term (setLinear pnms)
  where
    pattern :: Bool
pattern = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
    eimpossible :: Bool
eimpossible = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
    intransform :: Bool
intransform = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ETransLHS
    bindfree :: Bool
bindfree = ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ETyDecl Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ELHS Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
ETransLHS
               Bool -> Bool -> Bool
|| ElabMode
emode ElabMode -> ElabMode -> Bool
forall a. Eq a => a -> a -> Bool
== ElabMode
EImpossible
    autoimpls :: Bool
autoimpls = IOption -> Bool
opt_autoimpls (IState -> IOption
idris_options IState
ist)

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

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

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

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

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

    -- | elabE elaborates an expression, possibly wrapping implicit coercions
    -- and forces/delays.  If you make a recursive call in elab', it is
    -- normally correct to call elabE - the ones that don't are `desugarings
    -- typically
    elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
    elabE :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina Maybe FC
fc' PTerm
t =
     do solved <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_recents
        as <- get_autos
        hs <- get_holes
        -- If any of the autos use variables which have recently been solved,
        -- have another go at solving them now.
        mapM_ (\(Name
a, ([FailContext]
failc, [Name]
ns)) ->
                       if (Name -> Bool) -> [Name] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (\Name
n -> Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
solved) [Name]
ns Bool -> Bool -> Bool
&& [Name] -> Name
forall a. HasCallStack => [a] -> a
head [Name]
hs Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
a
                              then IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
solveAuto IState
ist Name
fn Bool
False (Name
a, [FailContext]
failc)
                              else () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()) as

        apt <- expandToArity t
        itm <- if not pattern then insertImpLam ina apt else return apt
        ct <- insertCoerce ina itm
        t' <- insertLazy ina ct
        g <- goal
        tm <- get_term
        ps <- get_probs
        hs <- 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 <- get_env
        let fc = String -> FC
fileFC String
"Force"
        handleError (forceErr t' env)
            (elab' ina fc' t')
            (elab' ina fc' (PApp fc (PRef fc [] (sUN "Force"))
                             [pimp (sUN "t") Placeholder True,
                              pimp (sUN "a") Placeholder True,
                              pexp ct]))

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

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

    elab' :: ElabCtxt  -- ^ (in an argument, guarded, in a type, in a quasiquote)
          -> Maybe FC -- ^ The closest FC in the syntax tree, if applicable
          -> PTerm -- ^ The term to elaborate
          -> ElabD ()
    elab' :: ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc (PNoImplicits PTerm
t) = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t -- skip elabE step
    elab' ElabCtxt
ina Maybe FC
fc (PType FC
fc')       =
      do Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply Raw
RType []
         ElabD ()
forall aux. Elab' aux ()
solve
         FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (String -> String -> OutputAnnotation
AnnType String
"Type" String
"The type of types")
    elab' ElabCtxt
ina Maybe FC
fc (PUniverse FC
fc' Universe
u)   =
      do Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
UniquenessTypes LanguageExt -> [LanguageExt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist
                  Bool -> Bool -> Bool
|| ElabCtxt -> Bool
e_qq ElabCtxt
ina) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
           TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ FC -> Err -> Err
forall t. FC -> Err' t -> Err' t
At FC
fc' (String -> Err
forall t. String -> Err' t
Msg String
"You must turn on the UniquenessTypes extension to use UniqueType or AnyType")
         Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Universe -> Raw
RUType Universe
u) []
         ElabD ()
forall aux. Elab' aux ()
solve
         FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (String -> String -> OutputAnnotation
AnnType (Universe -> String
forall a. Show a => a -> String
show Universe
u) String
"The type of unique types")
--  elab' (_,_,inty) (PConstant c)
--     | constType c && pattern && not reflection && not inty
--       = lift $ tfail (Msg "Typecase is not allowed")
    elab' ElabCtxt
ina Maybe FC
fc tm :: PTerm
tm@(PConstant FC
fc' Const
c)
         | Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_intype ElabCtxt
ina)
           Bool -> Bool -> Bool
&& Const -> Bool
isTypeConst Const
c
              = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"No explicit types on left hand side: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
forall a. Show a => a -> String
show PTerm
tm)
         | Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& ElabCtxt -> Bool
e_nomatching ElabCtxt
ina
              = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
forall a. Show a => a -> String
show PTerm
tm)
         | Bool
otherwise = do Raw -> [(Bool, Int)] -> Elab' EState [(Name, Name)]
forall aux. Raw -> [(Bool, Int)] -> Elab' aux [(Name, Name)]
apply (Const -> Raw
RConstant Const
c) []
                          ElabD ()
forall aux. Elab' aux ()
solve
                          FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc' (Const -> OutputAnnotation
AnnConst Const
c)
    elab' ElabCtxt
ina Maybe FC
fc (PQuote Raw
r)     = do Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill Raw
r; ElabD ()
forall aux. Elab' aux ()
solve
    elab' ElabCtxt
ina Maybe FC
_ (PTrue FC
fc PunInfo
_)   =
       do ElabD ()
forall aux. Elab' aux ()
compute
          g <- Elab' EState Term
forall aux. Elab' aux Term
goal
          case g of
            TType UExp
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
unitTy)
            UType Universe
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
unitTy)
            Term
_ -> ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
unitCon)
    elab' ElabCtxt
ina Maybe FC
fc (PResolveTC (FC String
"HACK" (Int, Int)
_ (Int, Int)
_)) -- for chasing parent interfaces
       = do g <- Elab' EState Term
forall aux. Elab' aux Term
goal; resolveTC False False 5 g fn elabRec ist
    elab' ElabCtxt
ina Maybe FC
fc (PResolveTC FC
fc')
        = do c <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"__interface")
             implementationArg c
    -- Elaborate the equality type first homogeneously, then
    -- heterogeneously as a fallback
    elab' ElabCtxt
ina Maybe FC
_ (PApp FC
fc (PRef FC
_ [FC]
_ Name
n) [PArg]
args)
       | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
eqTy, [PTerm
Placeholder, PTerm
Placeholder, PTerm
l, PTerm
r] <- (PArg -> PTerm) -> [PArg] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map PArg -> PTerm
forall t. PArg' t -> t
getTm [PArg]
args
       = ElabD () -> ElabD () -> ElabD ()
forall aux a. Elab' aux a -> Elab' aux a -> Elab' aux a
try (do tyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"aqty")
                 claim tyn RType
                 movelast tyn
                 elab' ina (Just fc) (PApp fc (PRef fc [] eqTy)
                              [pimp (sUN "A") (PRef NoFC [] tyn) True,
                               pimp (sUN "B") (PRef NoFC [] tyn) False,
                               pexp l, pexp r]))
             (do atyn <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"aqty")
                 btyn <- getNameFrom (sMN 0 "bqty")
                 claim atyn RType
                 movelast atyn
                 claim btyn RType
                 movelast btyn
                 elab' ina (Just fc) (PApp fc (PRef fc [] eqTy)
                   [pimp (sUN "A") (PRef NoFC [] atyn) True,
                    pimp (sUN "B") (PRef NoFC [] btyn) False,
                    pexp l, pexp r]))

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

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

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

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

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

    elab' ElabCtxt
ina Maybe FC
fc (PAlternative [(Name, Name)]
ms PAltType
FirstSuccess [PTerm]
as_in)
        = do -- finish the mkUniqueNames job
             uns <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_usedns
             let as = (PTerm -> PTerm) -> [PTerm] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> [(Name, Name)] -> PTerm -> PTerm
mkUniqueNames ([Name]
uns [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++ ((Name, Name) -> Name) -> [(Name, Name)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Name) -> Name
forall a b. (a, b) -> b
snd [(Name, Name)]
ms) [(Name, Name)]
ms) [PTerm]
as_in
             trySeq as
        where -- if none work, take the error from the first
              trySeq :: [PTerm] -> ElabD ()
trySeq (PTerm
x : [PTerm]
xs) = let e1 :: ElabD ()
e1 = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x in
                                    ElabD () -> ElabD () -> Bool -> ElabD ()
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' ElabD ()
e1 (ElabD () -> [PTerm] -> ElabD ()
forall {a}. StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' ElabD ()
e1 [PTerm]
xs) Bool
True
              trySeq [] = String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Nothing to try in sequence"
              trySeq' :: StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' StateT (ElabState EState) TC a
deferr [] = do StateT (ElabState EState) TC a
deferr; ElabD ()
forall aux. Elab' aux ()
unifyProblems
              trySeq' StateT (ElabState EState) TC a
deferr (PTerm
x : [PTerm]
xs)
                  = ElabD () -> ElabD () -> Bool -> ElabD ()
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (ElabD () -> (Err -> ElabD ()) -> ElabD ()
forall aux a. Elab' aux a -> (Err -> Elab' aux a) -> Elab' aux a
tryCatch (do ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
x
                                       IState -> Name -> Bool -> ElabD ()
solveAutos IState
ist Name
fn Bool
False
                                       ElabD ()
forall aux. Elab' aux ()
unifyProblems)
                             (\Err
_ -> StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' StateT (ElabState EState) TC a
deferr []))
                         (StateT (ElabState EState) TC a -> [PTerm] -> ElabD ()
trySeq' StateT (ElabState EState) TC a
deferr [PTerm]
xs) Bool
True
    elab' ElabCtxt
ina Maybe FC
fc (PAlternative [(Name, Name)]
ms PAltType
TryImplicit (PTerm
orig : [PTerm]
alts)) = do
        env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
        compute
        ty <- goal
        let doelab = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
orig
        tryCatch doelab
            (\Err
err ->
                if Err -> Bool
forall {t}. Err' t -> Bool
recoverableErr Err
err
                   then -- trace ("NEED IMPLICIT! " ++ show orig ++ "\n" ++
                        --      show alts ++ "\n" ++
                        --      showQuick err) $
                    -- Prune the coercions so that only the ones
                    -- with the right type to fix the error will be tried!
                    case Err -> [PTerm] -> Env -> [PTerm]
pruneAlts Err
err [PTerm]
alts Env
env of
                         [] -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail Err
err
                         [PTerm]
alts' -> do
                             ElabD () -> ElabD () -> Bool -> ElabD ()
forall aux a. Elab' aux a -> Elab' aux a -> Bool -> Elab' aux a
try' (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc ([(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms (Bool -> PAltType
ExactlyOne Bool
False) [PTerm]
alts'))
                                  (TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail Err
err) -- take error from original if all fail
                                  Bool
True
                   else TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail Err
err)
      where
        recoverableErr :: Err' t -> Bool
recoverableErr (CantUnify Bool
_ (t, Maybe Provenance)
_ (t, Maybe Provenance)
_ Err' t
_ [(Name, t)]
_ Int
_) = Bool
True
        recoverableErr (TooManyArguments Name
_) = Bool
False
        recoverableErr (CantSolveGoal t
_ [(Name, t)]
_) = Bool
False
        recoverableErr (CantResolveAlts [Name]
_) = Bool
False
        recoverableErr (NoValidAlts [Name]
_) = Bool
True
        recoverableErr (ProofSearchFail (Msg String
_)) = Bool
True
        recoverableErr (ProofSearchFail Err' t
_) = Bool
False
        recoverableErr (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err' t
e) = Err' t -> Bool
recoverableErr Err' t
e
        recoverableErr (At FC
_ Err' t
e) = Err' t -> Bool
recoverableErr Err' t
e
        recoverableErr (ElabScriptDebug [ErrorReportPart]
_ t
_ [(Name, t, [(Name, Binder t)])]
_) = Bool
False
        recoverableErr Err' t
_ = Bool
True

        pruneAlts :: Err -> [PTerm] -> Env -> [PTerm]
pruneAlts (CantUnify Bool
_ (Term
inc, Maybe Provenance
_) (Term
outc, Maybe Provenance
_) Err
_ [(Name, Term)]
_ Int
_) [PTerm]
alts Env
env
            = case Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
inc) of
                   (P (TCon Int
_ Int
_) Name
n Term
_, [Term]
_) -> (PTerm -> Bool) -> [PTerm] -> [PTerm]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Env -> PTerm -> Bool
hasArg Name
n Env
env) [PTerm]
alts
                   (Constant Const
_, [Term]
_) -> [PTerm]
alts
                   (Term, [Term])
_ -> (PTerm -> Bool) -> [PTerm] -> [PTerm]
forall a. (a -> Bool) -> [a] -> [a]
filter PTerm -> Bool
isLend [PTerm]
alts -- special case hack for 'Borrowed'
        pruneAlts (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err
e) [PTerm]
alts Env
env = Err -> [PTerm] -> Env -> [PTerm]
pruneAlts Err
e [PTerm]
alts Env
env
        pruneAlts (At FC
_ Err
e) [PTerm]
alts Env
env = Err -> [PTerm] -> Env -> [PTerm]
pruneAlts Err
e [PTerm]
alts Env
env
        pruneAlts (NoValidAlts [Name]
as) [PTerm]
alts Env
env = [PTerm]
alts
        pruneAlts Err
err [PTerm]
alts Env
_ = (PTerm -> Bool) -> [PTerm] -> [PTerm]
forall a. (a -> Bool) -> [a] -> [a]
filter PTerm -> Bool
isLend [PTerm]
alts

        hasArg :: Name -> Env -> PTerm -> Bool
hasArg Name
n Env
env PTerm
ap | PTerm -> Bool
isLend PTerm
ap = Bool
True -- special case hack for 'Borrowed'
        hasArg Name
n Env
env (PApp FC
_ (PRef FC
_ [FC]
_ Name
a) [PArg]
_)
             = case Name -> Context -> Maybe Term
lookupTyExact Name
a (IState -> Context
tt_ctxt IState
ist) of
                    Just Term
ty -> let args :: [Term]
args = ((Name, Term) -> Term) -> [(Name, Term)] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Term) -> Term
forall a b. (a, b) -> b
snd (Term -> [(Name, Term)]
forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env Term
ty)) in
                                   (Term -> Bool) -> [Term] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> Term -> Bool
forall {a}. Eq a => a -> TT a -> Bool
fnIs Name
n) [Term]
args
                    Maybe Term
Nothing -> Bool
False
        hasArg Name
n Env
env (PAlternative [(Name, Name)]
_ PAltType
_ [PTerm]
as) = (PTerm -> Bool) -> [PTerm] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any (Name -> Env -> PTerm -> Bool
hasArg Name
n Env
env) [PTerm]
as
        hasArg Name
n Env
_ PTerm
tm = Bool
False

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

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

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

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

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

             elabIArg :: ((Name, (Bool, b)), PArg) -> ElabD ()
elabIArg ((Name
n, (Bool
True, b
ty)), PArg
def) =
               do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n; ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) (PArg -> PTerm
forall t. PArg' t -> t
getTm PArg
def)
             elabIArg ((Name, (Bool, b)), PArg)
_ = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- already done, just a name

             mkN :: Name -> Name
mkN n :: Name
n@(NS Name
_ [Text]
_) = Name
n
             mkN n :: Name
n@(SN SpecialName
_) = Name
n
             mkN Name
n = case ElabInfo -> [String]
namespace ElabInfo
info of
                          xs :: [String]
xs@(String
_:[String]
_) -> Name -> [String] -> Name
sNS Name
n [String]
xs
                          [String]
_ -> Name
n

    elab' ElabCtxt
ina Maybe FC
_ (PMatchApp FC
fc Name
fn)
       = do (fn', imps) <- case Name -> Ctxt [PArg] -> [(Name, [PArg])]
forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
fn (IState -> Ctxt [PArg]
idris_implicits IState
ist) of
                             [(Name
n, [PArg]
args)] -> (Name, [Bool]) -> StateT (ElabState EState) TC (Name, [Bool])
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (Name
n, (PArg -> Bool) -> [PArg] -> [Bool]
forall a b. (a -> b) -> [a] -> [b]
map (Bool -> PArg -> Bool
forall a b. a -> b -> a
const Bool
True) [PArg]
args)
                             [(Name, [PArg])]
_ -> TC (Name, [Bool]) -> StateT (ElabState EState) TC (Name, [Bool])
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC (Name, [Bool]) -> StateT (ElabState EState) TC (Name, [Bool]))
-> TC (Name, [Bool]) -> StateT (ElabState EState) TC (Name, [Bool])
forall a b. (a -> b) -> a -> b
$ Err -> TC (Name, [Bool])
forall a. Err -> TC a
tfail (Name -> Err
forall t. Name -> Err' t
NoSuchVariable Name
fn)
            ns <- match_apply (Var fn') (map (\Bool
x -> (Bool
x,Int
0)) imps)
            solve
    -- if f is local, just do a simple_app
    -- FIXME: Anyone feel like refactoring this mess? - EB
    elab' ElabCtxt
ina Maybe FC
topfc tm :: PTerm
tm@(PApp FC
fc (PRef FC
ffc [FC]
hls Name
f) [PArg]
args_in)
      | Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not Bool
reflection Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_qq ElabCtxt
ina) Bool -> Bool -> Bool
&& ElabCtxt -> Bool
e_nomatching ElabCtxt
ina
              = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ String -> Err
forall t. String -> Err' t
Msg (String
"Attempting concrete match on polymorphic argument: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
forall a. Show a => a -> String
show PTerm
tm)
      | Bool
otherwise = ElabD [ImplicitInfo] -> ElabD ()
implicitApp (ElabD [ImplicitInfo] -> ElabD ())
-> ElabD [ImplicitInfo] -> ElabD ()
forall a b. (a -> b) -> a -> b
$
         do env <- Elab' EState Env
forall aux. Elab' aux Env
get_env
            ty <- goal
            fty <- get_type (Var f)
            ctxt <- get_context
            let dataCon = Name -> Context -> Bool
isDConName Name
f Context
ctxt
            annot <- findHighlight f
            knowns_m <- mapM getKnownImplicit args_in
            let knowns = (Maybe Name -> Maybe Name) -> [Maybe Name] -> [Name]
forall a b. (a -> Maybe b) -> [a] -> [b]
mapMaybe Maybe Name -> Maybe Name
forall a. a -> a
id [Maybe Name]
knowns_m
            args <- insertScopedImps fc f knowns (normalise ctxt env fty) args_in

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

                    annot <- findHighlight f
                    mapM (uncurry highlightSource) $
                      (ffc, annot) : map (\FC
f -> (FC
f, OutputAnnotation
annot)) hls

                    elabArgs ist (ina { e_inarg = e_inarg ina || not isinf,
                                        e_guarded = dataCon })
                           [] fc False f
                             (zip ns (unmatchableArgs ++ repeat False))
                             (f == sUN "Force")
                             (map (\PArg
x -> PArg -> PTerm
forall t. PArg' t -> t
getTm PArg
x) args) -- TODO: remove this False arg
                    imp <- if (e_isfn ina) then
                              do guess <- get_guess
                                 env <- get_env
                                 case safeForgetEnv (map fstEnv env) guess of
                                      Maybe Raw
Nothing ->
                                         [ImplicitInfo] -> ElabD [ImplicitInfo]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return []
                                      Just Raw
rguess -> do
                                         gty <- Raw -> Elab' EState Term
forall aux. Raw -> Elab' aux Term
get_type Raw
rguess
                                         let ty_n = Context -> Env -> Term -> Term
normalise Context
ctxt Env
env Term
gty
                                         return $ getReqImps ty_n
                              else 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 imp of
                         rs :: [ImplicitInfo]
rs@(ImplicitInfo
_:[ImplicitInfo]
_) | Bool -> Bool
not Bool
pattern -> [ImplicitInfo] -> ElabD [ImplicitInfo]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return [ImplicitInfo]
rs -- quit, try again
                         [ImplicitInfo]
_ -> do ElabD ()
forall aux. Elab' aux ()
solve
                                 hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
                                 ivs' <- get_implementations
                                 -- Attempt to resolve any interfaces which have 'complete' types,
                                 -- i.e. no holes in them
                                 when (not pattern || (e_inarg ina && not tcgen)) $
                                    mapM_ (\Name
n -> do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
n
                                                    g <- Elab' EState Term
forall aux. Elab' aux Term
goal
                                                    env <- get_env
                                                    hs <- get_holes
                                                    if all (\Name
n -> Bool -> Bool
not (Name
n Name -> [Name] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` [Name]
hs)) (freeNames g)
                                                     then handleError (tcRecoverable emode)
                                                              (resolveTC False False 10 g fn elabRec ist)
                                                              (movelast n)
                                                     else movelast n)
                                          (ivs' \\ ivs)
                                 return []
      where
            -- Run the elaborator, which returns how many implicit
            -- args were needed, then run it again with those args. We need
            -- this because we have to elaborate the whole application to
            -- find out whether any computations have caused more implicits
            -- to be needed.
            implicitApp :: ElabD [ImplicitInfo] -> ElabD ()
            implicitApp :: ElabD [ImplicitInfo] -> ElabD ()
implicitApp ElabD [ImplicitInfo]
elab
              | Bool
pattern Bool -> Bool -> Bool
|| Bool
intransform = do ElabD [ImplicitInfo]
elab; () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
              | Bool
otherwise
                = do s <- StateT (ElabState EState) TC (ElabState EState)
forall s (m :: * -> *). MonadState s m => m s
get
                     imps <- elab
                     case imps of
                          [] -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                          [ImplicitInfo]
es -> do ElabState EState -> ElabD ()
forall s (m :: * -> *). MonadState s m => s -> m ()
put ElabState EState
s
                                   ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
topfc (PTerm -> [ImplicitInfo] -> PTerm
PAppImpl PTerm
tm [ImplicitInfo]
es)

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

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

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

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

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

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

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

    elab' ElabCtxt
ina Maybe FC
fc (PAppImpl PTerm
f [ImplicitInfo]
es) = do [ImplicitInfo] -> ElabD ()
forall {a}. [a] -> ElabD ()
appImpl ([ImplicitInfo] -> [ImplicitInfo]
forall a. [a] -> [a]
reverse [ImplicitInfo]
es) -- not that we look...
                                      ElabD ()
forall aux. Elab' aux ()
solve
        where appImpl :: [a] -> ElabD ()
appImpl [] = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' (ElabCtxt
ina { e_isfn = False }) Maybe FC
fc PTerm
f -- e_isfn not set, so no recursive expansion of implicits
              appImpl (a
e : [a]
es) = Bool -> ElabD () -> ElabD () -> String -> ElabD ()
forall aux.
Bool -> Elab' aux () -> Elab' aux () -> String -> Elab' aux ()
simple_app Bool
False
                                            ([a] -> ElabD ()
appImpl [a]
es)
                                            (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder)
                                            (PTerm -> String
forall a. Show a => a -> String
show PTerm
f)
    elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder
        = do ~(h : hs) <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
             movelast h
    elab' ElabCtxt
ina Maybe FC
fc (PMetavar FC
nfc Name
n) =
          do ptm <- Elab' EState Term
forall aux. Elab' aux Term
get_term
             -- When building the metavar application, leave out the unique
             -- names which have been used elsewhere in the term, since we
             -- won't be able to use them in the resulting application.
             env <- get_env
             let unique_used = Context -> Term -> [Name]
getUniqueUsed (IState -> Context
tt_ctxt IState
ist) Term
ptm
             let lin_used = Context -> Term -> [Name]
getLinearUsed (IState -> Context
tt_ctxt IState
ist) Term
ptm
             let n' = [String] -> Name -> Name
metavarName (ElabInfo -> [String]
namespace ElabInfo
info) Name
n
             attack
             psns <- getPSnames
             n' <- defer unique_used lin_used n'
             solve
             highlightSource nfc (AnnName n' (Just MetavarOutput) Nothing Nothing)
    elab' ElabCtxt
ina Maybe FC
fc (PProof [PTactic]
ts) = do ElabD ()
forall aux. Elab' aux ()
compute; (PTactic -> ElabD ()) -> [PTactic] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
True IState
ist (ElabInfo -> Maybe FC
elabFC ElabInfo
info) Name
fn) [PTactic]
ts
    elab' ElabCtxt
ina Maybe FC
fc (PTactics [PTactic]
ts)
        | Bool -> Bool
not Bool
pattern = do (PTactic -> ElabD ()) -> [PTactic] -> ElabD ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
(a -> m b) -> t a -> m ()
mapM_ (Bool -> IState -> Maybe FC -> Name -> PTactic -> ElabD ()
runTac Bool
False IState
ist Maybe FC
fc Name
fn) [PTactic]
ts
        | Bool
otherwise = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
Placeholder
    elab' ElabCtxt
ina Maybe FC
fc (PElabError Err
e) = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail Err
e
    elab' ElabCtxt
ina Maybe FC
mfc (PRewrite FC
fc Maybe Name
substfn PTerm
rule PTerm
sc Maybe PTerm
newg)
        = (PTerm -> ElabD ())
-> IState
-> FC
-> Maybe Name
-> PTerm
-> PTerm
-> Maybe PTerm
-> ElabD ()
elabRewrite (ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
mfc) IState
ist FC
fc Maybe Name
substfn PTerm
rule PTerm
sc Maybe PTerm
newg
    -- A common error case if trying to typecheck an autogenerated case block
    elab' ElabCtxt
ina Maybe FC
_ c :: PTerm
c@(PCase FC
fc PTerm
Placeholder [(PTerm, PTerm)]
opts)
        = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (String -> Err
forall t. String -> Err' t
Msg String
"No expression for the case to inspect.\nYou need to replace the _ with an expression.")
    elab' ElabCtxt
ina Maybe FC
_ c :: PTerm
c@(PCase FC
fc PTerm
scr [(PTerm, PTerm)]
opts)
        = do ElabD ()
forall aux. Elab' aux ()
attack

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

             let scrnames = PTerm -> [Name]
allNamesIn PTerm
scr
             letbind scvn (letrig scrnames env) (Var tyn) (Var valn)

             -- Start filling in the scrutinee type, if we can work one
             -- out from the case options
             let scrTy = [PTerm] -> Maybe PTerm
getScrType (((PTerm, PTerm) -> PTerm) -> [(PTerm, PTerm)] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map (PTerm, PTerm) -> PTerm
forall a b. (a, b) -> a
fst [(PTerm, PTerm)]
opts)
             case scrTy of
                  Maybe PTerm
Nothing -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
                  Just PTerm
ty -> do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
focus Name
tyn
                                ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE ElabCtxt
ina (FC -> Maybe FC
forall a. a -> Maybe a
Just FC
fc) PTerm
ty

             focus valn
             elabE (ina { e_inarg = True }) (Just fc) scr
             -- Solve any remaining implicits - we need to solve as many
             -- as possible before making the 'case' type
             unifyProblems
             matchProblems True
             args <- get_env
             envU <- mapM (getKind args) 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)
             ptm <- get_term
             let inOpts = ((Name -> Bool) -> [Name] -> [Name]
forall a. (a -> Bool) -> [a] -> [a]
filter (Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
/= Name
scvn) (((Name, RigCount, Binder Term) -> Name) -> Env -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, RigCount, Binder Term) -> Name
forall {a} {b} {c}. (a, b, c) -> a
fstEnv Env
args)) [Name] -> [Name] -> [Name]
forall a. Eq a => [a] -> [a] -> [a]
\\ (((PTerm, PTerm) -> [Name]) -> [(PTerm, PTerm)] -> [Name]
forall (t :: * -> *) a b. Foldable t => (a -> [b]) -> t a -> [b]
concatMap (\(PTerm, PTerm)
x -> PTerm -> [Name]
allNamesIn ((PTerm, PTerm) -> PTerm
forall a b. (a, b) -> b
snd (PTerm, PTerm)
x)) [(PTerm, PTerm)]
opts)

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

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

             -- trace (show lin_used ++ "\n" ++ show args ++ "\n" ++ show ptm) attack
             attack
             cname' <- defer argsDropped lin_used (mkN (mkCaseName fc fn))
             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 = FC -> FnOpts -> Name -> [PClause' PTerm] -> PDecl
forall t. FC -> FnOpts -> Name -> [PClause' t] -> PDecl' t
PClauses FC
fc [] Name
cname'
                             (FC
-> Name
-> PTerm
-> [(Name, (Bool, Binder Term))]
-> [(PTerm, PTerm)]
-> [PClause' PTerm]
caseBlock FC
fc Name
cname' PTerm
scr
                                (((Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term)))
-> Env -> [(Name, (Bool, Binder Term))]
forall a b. (a -> b) -> [a] -> [b]
map (PTerm
-> (Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term))
isScr PTerm
scr) (Env -> Env
forall a. [a] -> [a]
reverse Env
args')) [(PTerm, PTerm)]
opts)
             -- elaborate case
             updateAux (\EState
e -> EState
e { case_decls = (cname', newdef) : case_decls e } )
             -- if we haven't got the type yet, hopefully we'll get it later!
             movelast tyn
             solve
        where mkCaseName :: FC -> Name -> Name
mkCaseName FC
fc (NS Name
n [Text]
ns) = Name -> [Text] -> Name
NS (FC -> Name -> Name
mkCaseName FC
fc Name
n) [Text]
ns
              mkCaseName FC
fc Name
n = SpecialName -> Name
SN (FC' -> Name -> SpecialName
CaseN (FC -> FC'
FC' FC
fc) Name
n)
--               mkCaseName (UN x) = UN (x ++ "_case")
--               mkCaseName (MN i x) = MN i (x ++ "_case")
              mkN :: Name -> Name
mkN n :: Name
n@(NS Name
_ [Text]
_) = Name
n
              mkN Name
n = case ElabInfo -> [String]
namespace ElabInfo
info of
                        xs :: [String]
xs@(String
_:[String]
_) -> Name -> [String] -> Name
sNS Name
n [String]
xs
                        [String]
_ -> Name
n

              -- If any variables in the scrutinee are in the environment with
              -- multiplicity other than RigW, let bind the scrutinee variable
              -- with the smallest multiplicity
              letrig :: t a -> [(a, RigCount, c)] -> RigCount
letrig t a
ns [] = RigCount
RigW
              letrig t a
ns [(a, RigCount, c)]
env = RigCount -> t a -> [(a, RigCount, c)] -> RigCount
forall {t :: * -> *} {a} {c}.
(Foldable t, Eq a) =>
RigCount -> t a -> [(a, RigCount, c)] -> RigCount
letrig' RigCount
Rig1 t a
ns [(a, RigCount, c)]
env

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

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

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

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

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

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

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

    elab' ElabCtxt
ina Maybe FC
fc (PUnifyLog PTerm
t) = do Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
unifyLog Bool
True
                                    ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
                                    Bool -> ElabD ()
forall aux. Bool -> Elab' aux ()
unifyLog Bool
False
    elab' ElabCtxt
ina Maybe FC
fc (PQuasiquote PTerm
t Maybe PTerm
goalt)
        = do -- First extract the unquoted subterms, replacing them with fresh
             -- names in the quasiquoted term. Claim their reflections to be
             -- an inferred type (to support polytypic quasiquotes).
             finalTy <- Elab' EState Term
forall aux. Elab' aux Term
goal
             (t, unq) <- extractUnquotes 0 t
             let unquoteNames = ((Name, PTerm) -> Name) -> [(Name, PTerm)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, PTerm) -> Name
forall a b. (a, b) -> a
fst [(Name, PTerm)]
unq
             mapM_ (\Name
uqn -> Name -> Raw -> ElabD ()
forall aux. Name -> Raw -> Elab' aux ()
claim Name
uqn (Term -> Raw
forget Term
finalTy)) unquoteNames

             -- Save the old state - we need a fresh proof state to avoid
             -- capturing lexically available variables in the quoted term.
             ctxt <- get_context
             datatypes <- get_datatypes
             g_nextname <- get_global_nextname
             saveState
             updatePS (const .
                       newProof (sMN 0 "q") (constraintNS info) ctxt datatypes g_nextname $
                       P Ref (reflm "TT") Erased)

             -- Re-add the unquotes, letting Idris infer the (fictional)
             -- types. Here, they represent the real type rather than the type
             -- of their reflection.
             mapM_ (\Name
n -> do ty <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"unqTy")
                             claim ty RType
                             movelast ty
                             claim n (Var ty)
                             movelast n)
                   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
             qTy <- getNameFrom (sMN 0 "qquoteTy")
             claim qTy RType
             movelast qTy
             qTm <- getNameFrom (sMN 0 "qquoteTm")
             claim qTm (Var qTy)

             -- Let-bind the result of elaborating the contained term, so that
             -- the hole doesn't disappear
             nTm <- getNameFrom (sMN 0 "quotedTerm")
             letbind nTm RigW (Var qTy) (Var qTm)

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

             -- Elaborate the quasiquoted term into the hole
             focus qTm
             elabE (ina { e_qq = True }) fc t
             end_unify

             -- We now have an elaborated term. Reflect it and solve the
             -- original goal in the original proof state, preserving highlighting
             env <- get_env
             EState _ _ _ hs _ _ <- getAux
             loadState
             updateAux (\EState
aux -> EState
aux { highlighting = hs })

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

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

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


    elab' ElabCtxt
ina Maybe FC
fc (PUnquote PTerm
t) = String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail String
"Found unquote outside of quasiquote"
    elab' ElabCtxt
ina Maybe FC
fc (PQuoteName Name
n Bool
False FC
nfc) =
      do Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Raw -> ElabD ()) -> Raw -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n
         ElabD ()
forall aux. Elab' aux ()
solve
    elab' ElabCtxt
ina Maybe FC
fc (PQuoteName Name
n Bool
True FC
nfc) =
      do ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
         env <- get_env
         case lookupBinder n env of
           Just Binder Term
_ -> do Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Raw -> ElabD ()) -> Raw -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n
                        ElabD ()
forall aux. Elab' aux ()
solve
                        FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False)
           Maybe (Binder Term)
Nothing ->
             case Name -> Context -> [(Name, Def)]
lookupNameDef Name
n Context
ctxt of
               [(Name
n', Def
_)] -> do Raw -> ElabD ()
forall aux. Raw -> Elab' aux ()
fill (Raw -> ElabD ()) -> Raw -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> Raw
reflectName Name
n'
                               ElabD ()
forall aux. Elab' aux ()
solve
                               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
nfc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n' Maybe NameOutput
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
               [] -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (Name -> TC ()) -> Name -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (Name -> Err) -> Name -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Name -> Err
forall t. Name -> Err' t
NoSuchVariable (Name -> ElabD ()) -> Name -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name
n
               [(Name, Def)]
more -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> ([Name] -> TC ()) -> [Name] -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> ([Name] -> Err) -> [Name] -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. [Name] -> Err
forall t. [Name] -> Err' t
CantResolveAlts ([Name] -> ElabD ()) -> [Name] -> ElabD ()
forall a b. (a -> b) -> a -> b
$ ((Name, Def) -> Name) -> [(Name, Def)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Def) -> Name
forall a b. (a, b) -> a
fst [(Name, Def)]
more
    elab' ElabCtxt
ina Maybe FC
fc (PAs FC
_ Name
n PTerm
t) = TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (String -> TC ()) -> String -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> (String -> Err) -> String -> TC ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> ElabD ()) -> String -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String
"@-pattern not allowed here"
    elab' ElabCtxt
ina Maybe FC
fc (PHidden PTerm
t)
      | Bool
reflection = ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' ElabCtxt
ina Maybe FC
fc PTerm
t
      | Bool
otherwise
        = do ~(h : hs) <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
             -- Dotting a hole means that either the hole or any outer
             -- hole (a hole outside any occurrence of it)
             -- must be solvable by unification as well as being filled
             -- in directly.
             -- Delay dotted things to the end, then when we elaborate them
             -- we can check the result against what was inferred
             movelast h
             ~(h' : hs) <- get_holes
             -- If we're at the end anyway, do it now
             if h == h' then elabHidden h
                        else delayElab 10 $ elabHidden h
     where
      elabHidden :: Name -> ElabD ()
elabHidden Name
h = do hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
                        when (h `elem` hs) $ do
                            focus h
                            dotterm
                            elab' ina fc t
    elab' ElabCtxt
ina Maybe FC
fc (PRunElab FC
fc' PTerm
tm [String]
ns) =
      do Bool -> ElabD () -> ElabD ()
forall (f :: * -> *). Applicative f => Bool -> f () -> f ()
unless (LanguageExt
ElabReflection LanguageExt -> [LanguageExt] -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` IState -> [LanguageExt]
idris_language_extensions IState
ist) (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$
           TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> TC () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ FC -> Err -> Err
forall t. FC -> Err' t -> Err' t
At FC
fc' (String -> Err
forall t. String -> Err' t
Msg String
"You must turn on the ElabReflection extension to use %runElab")
         ElabD ()
forall aux. Elab' aux ()
attack
         let elabName :: Name
elabName = Name -> [String] -> Name
sNS (String -> Name
sUN String
"Elab") [String
"Elab", String
"Reflection", String
"Language"]
         n <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"tacticScript")
         let scriptTy = Raw -> Raw -> Raw
RApp (Name -> Raw
Var Name
elabName) (Name -> Raw
Var Name
unitTy)
         claim n scriptTy
         focus n
         elabUnit <- goal
         attack -- to get an extra hole
         elab' ina (Just fc') tm
         script <- get_guess
         fullyElaborated script
         solve -- eliminate the hole. Because there are no references, the script is only in the binding
         ctxt <- get_context
         env <- get_env
         (scriptTm, scriptTy) <- lift $ check ctxt [] (forget script)
         lift $ converts ctxt env elabUnit scriptTy
         env <- get_env
         runElabAction info ist (maybe fc' id fc) env script ns
         solve
    elab' ElabCtxt
ina Maybe FC
fc (PConstSugar FC
constFC PTerm
tm) =
      -- Here we elaborate the contained term, then calculate
      -- highlighting for constFC.  The highlighting is the
      -- highlighting for the outermost constructor of the result of
      -- evaluating the elaborated term, if one exists (it always
      -- should, but better to fail gracefully for something silly
      -- like highlighting info). This is how implicit applications of
      -- fromInteger get highlighted.
      do ElabD ()
forall aux. Elab' aux ()
saveState -- so we don't pollute the elaborated term
         n <- Name -> Elab' EState Name
forall aux. Name -> Elab' aux Name
getNameFrom (Int -> String -> Name
sMN Int
0 String
"cstI")
         n' <- getNameFrom (sMN 0 "cstIhole")
         g <- forget <$> goal
         claim n' g
         movelast n'
         -- In order to intercept the elaborated value, we need to
         -- let-bind it.
         attack
         letbind n RigW g (Var n')
         focus n'
         elab' ina fc tm
         env <- get_env
         ctxt <- get_context
         let v = (Binder Term -> Term) -> Maybe (Binder Term) -> Maybe Term
forall a b. (a -> b) -> Maybe a -> Maybe b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap (Context -> Env -> Term -> Term
normaliseAll Context
ctxt Env
env (Term -> Term) -> (Binder Term -> Term) -> Binder Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Term
forall n. Eq n => TT n -> TT n
finalise (Term -> Term) -> (Binder Term -> Term) -> Binder Term -> Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Binder Term -> Term
forall b. Binder b -> b
binderVal)
                      (Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
n Env
env)
         loadState -- we have the highlighting - re-elaborate the value
         elab' ina fc tm
         case v of
           Just Term
val -> FC -> Term -> ElabD ()
highlightConst FC
constFC Term
val
           Maybe Term
Nothing -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
       where highlightConst :: FC -> Term -> ElabD ()
highlightConst FC
fc (P NameType
_ Name
n Term
_) =
               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n Maybe NameOutput
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing)
             highlightConst FC
fc (App AppStatus Name
_ Term
f Term
_) =
               FC -> Term -> ElabD ()
highlightConst FC
fc Term
f
             highlightConst FC
fc (Constant Const
c) =
               FC -> OutputAnnotation -> ElabD ()
highlightSource FC
fc (Const -> OutputAnnotation
AnnConst Const
c)
             highlightConst FC
_ Term
_ = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    elab' ElabCtxt
ina Maybe FC
fc PTerm
x = String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ElabD ()) -> String -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String
"Unelaboratable syntactic form " String -> String -> String
forall a. [a] -> [a] -> [a]
++ PTerm -> String
showTmImpls PTerm
x

    -- delay elaboration of 't', with priority 'pri' until after everything
    -- else is done.
    -- The delayed things with lower numbered priority will be elaborated
    -- first. (In practice, this means delayed alternatives, then PHidden
    -- things.)
    delayElab :: Int -> ElabD () -> ElabD ()
delayElab Int
pri ElabD ()
t
       = (EState -> EState) -> ElabD ()
forall aux. (aux -> aux) -> Elab' aux ()
updateAux (\EState
e -> EState
e { delayed_elab = delayed_elab e ++ [(pri, t)] })

    -- If the variable in the environment is the scrutinee of the case,
    -- and has multiplicity W, keep it available
    isScr :: PTerm -> (Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term))
    isScr :: PTerm
-> (Name, RigCount, Binder Term) -> (Name, (Bool, Binder Term))
isScr (PRef FC
_ [FC]
_ Name
n) (Name
n', RigCount
RigW, Binder Term
b) = (Name
n', (Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n', Binder Term
b))
    isScr PTerm
_ (Name
n', RigCount
_, Binder Term
b) = (Name
n', (Bool
False, Binder Term
b))

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

       where -- Find the variable we want as the scrutinee and mark it as
             -- 'True'. If the scrutinee is available in the environment,
             -- match on that otherwise match on the new argument we're adding.
             findScr :: [(a, (Bool, b))] -> [(a, (Bool, b))]
findScr ((a
n, (Bool
True, b
t)) : [(a, (Bool, b))]
xs)
                        = (a
n, (Bool
True, b
t)) (a, (Bool, b)) -> [(a, (Bool, b))] -> [(a, (Bool, b))]
forall a. a -> [a] -> [a]
: a -> [(a, (Bool, b))] -> [(a, (Bool, b))]
forall {t} {b}. t -> [(t, b)] -> [(t, b)]
scrName a
n [(a, (Bool, b))]
xs
             findScr [(a
n, (Bool
_, b
t))] = [(a
n, (Bool
True, b
t))]
             findScr ((a, (Bool, b))
x : [(a, (Bool, b))]
xs) = (a, (Bool, b))
x (a, (Bool, b)) -> [(a, (Bool, b))] -> [(a, (Bool, b))]
forall a. a -> [a] -> [a]
: [(a, (Bool, b))] -> [(a, (Bool, b))]
findScr [(a, (Bool, b))]
xs
             -- [] can't happen since scrutinee is in the environment!
             findScr [] = String -> [(a, (Bool, b))]
forall a. HasCallStack => String -> a
error String
"The impossible happened - the scrutinee was not in the environment"

             -- To make sure top level pattern name remains in scope, put
             -- it at the end of the environment
             scrName :: t -> [(t, b)] -> [(t, b)]
scrName t
n []  = []
             scrName t
n [(t
_, b
t)] = [(t
n, b
t)]
             scrName t
n ((t, b)
x : [(t, b)]
xs) = (t, b)
x (t, b) -> [(t, b)] -> [(t, b)]
forall a. a -> [a] -> [a]
: t -> [(t, b)] -> [(t, b)]
scrName t
n [(t, b)]
xs

             getNmScr :: (a, (b, b)) -> (a, b)
getNmScr (a
n, (b
s, b
_)) = (a
n, b
s)

             mkarg :: (Name, b) -> (PTerm, b)
mkarg (Name
n, b
s) = (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] Name
n, b
s)
             -- may be shadowed names in the new pattern - so replace the
             -- old ones with an _
             -- Also, names which don't appear on the rhs should not be
             -- fixed on the lhs, or this restricts the kind of matching
             -- we can do to non-dependent types.
             mkClause :: [(PTerm, Bool)] -> (PTerm, PTerm) -> PClause' PTerm
mkClause [(PTerm, Bool)]
args (PTerm
l, PTerm
r)
                   = let args' :: [(PTerm, Bool)]
args' = ((PTerm, Bool) -> (PTerm, Bool))
-> [(PTerm, Bool)] -> [(PTerm, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> (PTerm, Bool) -> (PTerm, Bool)
forall {t :: * -> *} {b}.
Foldable t =>
t Name -> (PTerm, b) -> (PTerm, b)
shadowed (PTerm -> [Name]
allNamesIn PTerm
l)) [(PTerm, Bool)]
args
                         args'' :: [(PTerm, Bool)]
args'' = ((PTerm, Bool) -> (PTerm, Bool))
-> [(PTerm, Bool)] -> [(PTerm, Bool)]
forall a b. (a -> b) -> [a] -> [b]
map ([Name] -> (PTerm, Bool) -> (PTerm, Bool)
forall {t :: * -> *} {b}.
Foldable t =>
t Name -> (PTerm, b) -> (PTerm, b)
implicitable (PTerm -> [Name]
allNamesIn PTerm
r [Name] -> [Name] -> [Name]
forall a. [a] -> [a] -> [a]
++
                                                     PTerm -> [Name]
keepscrName PTerm
scr)) [(PTerm, Bool)]
args'
                         lhs :: PTerm
lhs = FC -> PTerm -> [PArg] -> PTerm
PApp (FC -> PTerm -> FC
getFC FC
fc PTerm
l) (FC -> [FC] -> Name -> PTerm
PRef FC
NoFC [] Name
n)
                                 (((PTerm, Bool) -> PArg) -> [(PTerm, Bool)] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
map (PTerm -> (PTerm, Bool) -> PArg
forall {t}. t -> (t, Bool) -> PArg' t
mkLHSarg PTerm
l) [(PTerm, Bool)]
args'') in
                            FC
-> Name -> PTerm -> [PTerm] -> PTerm -> [PDecl] -> PClause' PTerm
forall t. FC -> Name -> t -> [t] -> t -> [PDecl' t] -> PClause' t
PClause (FC -> PTerm -> FC
getFC FC
fc PTerm
l) Name
n PTerm
lhs [] PTerm
r []

             -- Keep scrutinee available if it's just a name (this makes
             -- the names in scope look better when looking at a hole on
             -- the rhs of a case)
             keepscrName :: PTerm -> [Name]
keepscrName (PRef FC
_ [FC]
_ Name
n) = [Name
n]
             keepscrName PTerm
_ = []

             mkLHSarg :: t -> (t, Bool) -> PArg' t
mkLHSarg t
l (t
tm, Bool
True) = t -> PArg' t
forall {t}. t -> PArg' t
pexp t
l
             mkLHSarg t
l (t
tm, Bool
False) = t -> PArg' t
forall {t}. t -> PArg' t
pexp t
tm

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

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


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

    -- Fail if a term is not yet fully elaborated (e.g. if it contains
    -- case block functions that don't yet exist)
    fullyElaborated :: Term -> ElabD ()
    fullyElaborated :: Term -> ElabD ()
fullyElaborated (P NameType
_ Name
n Term
_) =
      do estate <- Elab' EState EState
forall aux. Elab' aux aux
getAux
         case lookup n (case_decls estate) of
           Maybe PDecl
Nothing -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
           Just PDecl
_  -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> ElabD ()) -> (Err -> TC ()) -> Err -> ElabD ()
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC ()
forall a. Err -> TC a
tfail (Err -> ElabD ()) -> Err -> ElabD ()
forall a b. (a -> b) -> a -> b
$ Name -> Err
forall t. Name -> Err' t
ElabScriptStaging Name
n
    fullyElaborated (Bind Name
n Binder Term
b Term
body) = Term -> ElabD ()
fullyElaborated Term
body ElabD () -> ElabD () -> ElabD ()
forall a b.
StateT (ElabState EState) TC a
-> StateT (ElabState EState) TC b -> StateT (ElabState EState) TC b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Binder Term -> (Term -> ElabD ()) -> ElabD ()
forall (t :: * -> *) (f :: * -> *) a b.
(Foldable t, Applicative f) =>
t a -> (a -> f b) -> f ()
for_ Binder Term
b Term -> ElabD ()
fullyElaborated
    fullyElaborated (App AppStatus Name
_ Term
l Term
r) = Term -> ElabD ()
fullyElaborated Term
l ElabD () -> ElabD () -> ElabD ()
forall a b.
StateT (ElabState EState) TC a
-> StateT (ElabState EState) TC b -> StateT (ElabState EState) TC b
forall (m :: * -> *) a b. Monad m => m a -> m b -> m b
>> Term -> ElabD ()
fullyElaborated Term
r
    fullyElaborated (Proj Term
t Int
_) = Term -> ElabD ()
fullyElaborated Term
t
    fullyElaborated Term
_ = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- If the goal type is a "Lazy", then try elaborating via 'Delay'
    -- first. We need to do this brute force approach, rather than anything
    -- more precise, since there may be various other ambiguities to resolve
    -- first.
    insertLazy :: ElabCtxt -> PTerm -> ElabD PTerm
    insertLazy :: ElabCtxt -> PTerm -> StateT (ElabState EState) TC PTerm
insertLazy ElabCtxt
ina t :: PTerm
t@(PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg]
_) | Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delay" = PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    insertLazy ElabCtxt
ina t :: PTerm
t@(PApp FC
_ (PRef FC
_ [FC]
_ (UN Text
l)) [PArg]
_) | Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Force" = PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    insertLazy ElabCtxt
ina (PCoerced PTerm
t) = PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    -- Don't add a delay to top level pattern variables, since they
    -- can be forced on the rhs if needed
    insertLazy ElabCtxt
ina t :: PTerm
t@(PPatvar FC
_ Name
_) | Bool
pattern Bool -> Bool -> Bool
&& Bool -> Bool
not (ElabCtxt -> Bool
e_guarded ElabCtxt
ina) = PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
    insertLazy ElabCtxt
ina PTerm
t =
        do ty <- Elab' EState Term
forall aux. Elab' aux Term
goal
           env <- get_env
           let (tyh, _) = unApply (normalise (tt_ctxt ist) env ty)
           let tries = [Env -> PTerm -> PTerm
forall {b} {c}. [(Name, b, c)] -> PTerm -> PTerm
mkDelay Env
env PTerm
t, PTerm
t]
           case tyh of
                P NameType
_ (UN Text
l) Term
_ | Text
l Text -> Text -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Text
txt String
"Delayed"
                    -> PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ([(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [] PAltType
FirstSuccess [PTerm]
tries)
                Term
_ -> PTerm -> StateT (ElabState EState) TC PTerm
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t
      where
        mkDelay :: [(Name, b, c)] -> PTerm -> PTerm
mkDelay [(Name, b, c)]
env (PAlternative [(Name, Name)]
ms PAltType
b [PTerm]
xs) = [(Name, Name)] -> PAltType -> [PTerm] -> PTerm
PAlternative [(Name, Name)]
ms PAltType
b ((PTerm -> PTerm) -> [PTerm] -> [PTerm]
forall a b. (a -> b) -> [a] -> [b]
map ([(Name, b, c)] -> PTerm -> PTerm
mkDelay [(Name, b, c)]
env) [PTerm]
xs)
        mkDelay [(Name, b, c)]
env PTerm
t
            = let fc :: FC
fc = String -> FC
fileFC String
"Delay" in
                  IState -> [Name] -> PTerm -> PTerm
addImplBound IState
ist (((Name, b, c) -> Name) -> [(Name, b, c)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, b, c) -> Name
forall {a} {b} {c}. (a, b, c) -> a
fstEnv [(Name, b, c)]
env) (FC -> PTerm -> [PArg] -> PTerm
PApp FC
fc (FC -> [FC] -> Name -> PTerm
PRef FC
fc [] (String -> Name
sUN String
"Delay"))
                                                    [PTerm -> PArg
forall {t}. t -> PArg' t
pexp PTerm
t])


    -- Don't put implicit coercions around applications which are marked
    -- as '%noImplicit', or around case blocks, otherwise we get exponential
    -- blowup especially where there are errors deep in large expressions.
    notImplicitable :: PTerm -> Bool
notImplicitable (PApp FC
_ PTerm
f [PArg]
_) = PTerm -> Bool
notImplicitable PTerm
f
    -- TMP HACK no coercing on bind (make this configurable)
    notImplicitable (PRef FC
_ [FC]
_ Name
n)
        | [FnOpts
opts] <- Name -> Ctxt FnOpts -> [FnOpts]
forall a. Name -> Ctxt a -> [a]
lookupCtxt Name
n (IState -> Ctxt FnOpts
idris_flags IState
ist)
            = FnOpt
NoImplicit FnOpt -> FnOpts -> Bool
forall a. Eq a => a -> [a] -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` FnOpts
opts
    notImplicitable (PAlternative [(Name, Name)]
_ PAltType
_ [PTerm]
as) = (PTerm -> Bool) -> [PTerm] -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
any PTerm -> Bool
notImplicitable [PTerm]
as
    -- case is tricky enough without implicit coercions! If they are needed,
    -- they can go in the branches separately.
    notImplicitable (PCase FC
_ PTerm
_ [(PTerm, PTerm)]
_) = Bool
True
    notImplicitable PTerm
_ = Bool
False

    -- Elaboration works more smoothly if we expand function applications
    -- to their full arity and elaborate it all at once (better error messages
    -- in particular)
    expandToArity :: PTerm -> StateT (ElabState aux) TC PTerm
expandToArity tm :: PTerm
tm@(PApp FC
fc PTerm
f [PArg]
a) = do
       env <- Elab' aux Env
forall aux. Elab' aux Env
get_env
       case fullApp tm of
            -- if f is global, leave it alone because we've already
            -- expanded it to the right arity
            PApp FC
fc ftm :: PTerm
ftm@(PRef FC
_ [FC]
_ Name
f) [PArg]
args | Just Binder Term
aty <- Name -> Env -> Maybe (Binder Term)
forall n. Eq n => n -> EnvTT n -> Maybe (Binder (TT n))
lookupBinder Name
f Env
env ->
               do let a :: Int
a = [(Name, Term)] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length (Term -> [(Name, Term)]
forall n. TT n -> [(n, TT n)]
getArgTys (Context -> Env -> Term -> Term
normalise (IState -> Context
tt_ctxt IState
ist) Env
env (Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
aty)))
                  PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (FC -> Int -> PTerm -> [PArg] -> PTerm
mkPApp FC
fc Int
a PTerm
ftm [PArg]
args)
            PTerm
_ -> PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
tm
    expandToArity PTerm
t = PTerm -> StateT (ElabState aux) TC PTerm
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return PTerm
t

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

    -- See if the name is listed as an implicit. If it is, return it, and
    -- drop it from the rest of the list
    findImplicit :: Name -> [PArg] -> (Maybe PArg, [PArg])
    findImplicit :: Name -> [PArg] -> (Maybe PArg, [PArg])
findImplicit Name
n [] = (Maybe PArg
forall a. Maybe a
Nothing, [])
    findImplicit Name
n (i :: PArg
i@(PImp Int
_ Bool
_ [ArgOpt]
_ Name
n' PTerm
_) : [PArg]
args)
        | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' = (PArg -> Maybe PArg
forall a. a -> Maybe a
Just PArg
i, [PArg]
args)
    findImplicit Name
n (i :: PArg
i@(PTacImplicit Int
_ [ArgOpt]
_ Name
n' PTerm
_ PTerm
_) : [PArg]
args)
        | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
n' = (PArg -> Maybe PArg
forall a. a -> Maybe a
Just PArg
i, [PArg]
args)
    findImplicit Name
n (PArg
x : [PArg]
xs) = let (Maybe PArg
arg, [PArg]
rest) = Name -> [PArg] -> (Maybe PArg, [PArg])
findImplicit Name
n [PArg]
xs in
                                  (Maybe PArg
arg, PArg
x PArg -> [PArg] -> [PArg]
forall a. a -> [a] -> [a]
: [PArg]
rest)

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

        -- Any implicit in the application needs to have the name of a
        -- scoped implicit or a top level implicit, otherwise report an error
        checkKnownImplicit :: t Name -> PArg' t -> t TC ()
checkKnownImplicit t Name
ns imp :: PArg' t
imp@(PImp{})
             | PArg' t -> Name
forall t. PArg' t -> Name
pname PArg' t
imp Name -> t Name -> Bool
forall a. Eq a => a -> t a -> Bool
forall (t :: * -> *) a. (Foldable t, Eq a) => a -> t a -> Bool
`elem` t Name
ns = () -> t TC ()
forall a. a -> t TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
             | Bool
otherwise = TC () -> t TC ()
forall (m :: * -> *) a. Monad m => m a -> t m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC () -> t TC ()) -> TC () -> t TC ()
forall a b. (a -> b) -> a -> b
$ Err -> TC ()
forall a. Err -> TC a
tfail (Err -> TC ()) -> Err -> TC ()
forall a b. (a -> b) -> a -> b
$ FC -> Err -> Err
forall t. FC -> Err' t -> Err' t
At FC
fc (Err -> Err) -> Err -> Err
forall a b. (a -> b) -> a -> b
$ Name -> Name -> Err
forall t. Name -> Name -> Err' t
UnknownImplicit (PArg' t -> Name
forall t. PArg' t -> Name
pname PArg' t
imp) Name
f
        checkKnownImplicit t Name
ns PArg' t
_ = () -> t TC ()
forall a. a -> t TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

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

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

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

    -- | Elaborate the arguments to a function
    elabArgs :: IState -- ^ The current Idris state
             -> ElabCtxt -- ^ (in an argument, guarded, in a type, in a qquote)
             -> [Bool]
             -> FC -- ^ Source location
             -> Bool
             -> Name -- ^ Name of the function being applied
             -> [((Name, Name), Bool)] -- ^ (Argument Name, Hole Name, unmatchable)
             -> Bool -- ^ under a 'force'
             -> [PTerm] -- ^ argument
             -> ElabD ()
    elabArgs :: IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
retry Name
f [] Bool
force [PTerm]
_ = () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f (((Name
argName, Name
holeName), Bool
unm):[((Name, Name), Bool)]
ns) Bool
force (PTerm
t : [PTerm]
args)
        = do hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
             if holeName `elem` hs then
                do focus holeName
                   case t of
                      PTerm
Placeholder -> do Name -> ElabD ()
forall aux. Name -> Elab' aux ()
movelast Name
holeName
                                        IState
-> ElabCtxt
-> [Bool]
-> FC
-> Bool
-> Name
-> [((Name, Name), Bool)]
-> Bool
-> [PTerm]
-> ElabD ()
elabArgs IState
ist ElabCtxt
ina [Bool]
failed FC
fc Bool
r Name
f [((Name, Name), Bool)]
ns Bool
force [PTerm]
args
                      PTerm
_ -> PTerm -> ElabD ()
elabArg PTerm
t
                else elabArgs ist ina failed fc r f ns force args
      where elabArg :: PTerm -> ElabD ()
elabArg PTerm
t =
              do -- solveAutos ist fn False
                 FC -> Name -> Name -> ElabD ()
forall aux. FC -> Name -> Name -> Elab' aux ()
now_elaborating FC
fc Name
f Name
argName
                 Name -> Name -> ElabD () -> ElabD ()
forall {aux} {b}.
Name
-> Name
-> StateT (ElabState aux) TC b
-> StateT (ElabState aux) TC b
wrapErr Name
f Name
argName (ElabD () -> ElabD ()) -> ElabD () -> ElabD ()
forall a b. (a -> b) -> a -> b
$ do
                   hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
                   tm <- get_term
                   -- No coercing under an explicit Force (or it can Force/Delay
                   -- recursively!)
                   let elab = if Bool
force then ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elab' else ElabCtxt -> Maybe FC -> PTerm -> ElabD ()
elabE
                   failed' <- -- trace (show (n, t, hs, tm)) $
                              -- traceWhen (not (null cs)) (show ty ++ "\n" ++ showImp True t) $
                              do focus holeName;
                                 g <- goal
                                 -- Can't pattern match on polymorphic goals
                                 poly <- goal_polymorphic
                                 ulog <- getUnifyLog
                                 traceWhen ulog ("Elaborating argument " ++ show (argName, holeName, g)) $
                                  elab (ina { e_nomatching = unm && poly }) (Just fc) t
                                 return failed
                   done_elaborating_arg f argName
                   elabArgs ist ina failed fc r f ns force 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 <- StateT (ElabState aux) TC (ElabState aux)
forall s (m :: * -> *). MonadState s m => m s
get
                 while <- elaborating_app
                 let while' = ((FC, Name, Name) -> (Name, Name))
-> [(FC, Name, Name)] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FC
x, Name
y, Name
z)-> (Name
y, Name
z)) [(FC, Name, Name)]
while
                 (result, newState) <- case runStateT action elabState of
                                         OK (b
res, ElabState aux
newState) -> (b, ElabState aux) -> StateT (ElabState aux) TC (b, ElabState aux)
forall a. a -> StateT (ElabState aux) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (b
res, ElabState aux
newState)
                                         Error Err
e -> do Name -> Name -> Elab' aux ()
forall aux. Name -> Name -> Elab' aux ()
done_elaborating_arg Name
f Name
argName
                                                       TC (b, ElabState aux)
-> StateT (ElabState aux) TC (b, ElabState aux)
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState aux) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Err -> TC (b, ElabState aux)
forall a. Err -> TC a
tfail ([(Name, Name)] -> Err -> Err
elaboratingArgErr [(Name, Name)]
while' Err
e))
                 put newState
                 return result
    elabArgs IState
_ ElabCtxt
_ [Bool]
_ FC
_ Bool
_ Name
_ (((Name
arg, Name
hole), Bool
_) : [((Name, Name), Bool)]
_) Bool
_ [] =
      String -> ElabD ()
forall a. String -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. MonadFail m => String -> m a
fail (String -> ElabD ()) -> String -> ElabD ()
forall a b. (a -> b) -> a -> b
$ String
"Can't elaborate these args: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
arg String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
hole

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

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

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

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

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

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

    headIs :: Name -> PTerm -> Bool
headIs Name
f (PApp FC
_ (PRef FC
_ [FC]
_ Name
f') [PArg]
_) = Name
f Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== Name
f'
    headIs Name
f (PApp FC
_ PTerm
f' [PArg]
_) = Name -> PTerm -> Bool
headIs Name
f PTerm
f'
    headIs Name
f PTerm
_ = Bool
True -- keep if it's not an application

-- | Use the local elab context to work out the highlighting for a name
findHighlight :: Name -> ElabD OutputAnnotation
findHighlight :: Name -> ElabD OutputAnnotation
findHighlight Name
n = do ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
                     env <- get_env
                     case lookupBinder n env of
                       Just Binder Term
_ -> OutputAnnotation -> ElabD OutputAnnotation
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputAnnotation -> ElabD OutputAnnotation)
-> OutputAnnotation -> ElabD OutputAnnotation
forall a b. (a -> b) -> a -> b
$ Name -> Bool -> OutputAnnotation
AnnBoundName Name
n Bool
False
                       Maybe (Binder Term)
Nothing -> case Name -> Context -> Maybe Term
lookupTyExact Name
n Context
ctxt of
                                    Just Term
_ -> OutputAnnotation -> ElabD OutputAnnotation
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return (OutputAnnotation -> ElabD OutputAnnotation)
-> OutputAnnotation -> ElabD OutputAnnotation
forall a b. (a -> b) -> a -> b
$ Name
-> Maybe NameOutput
-> Maybe String
-> Maybe String
-> OutputAnnotation
AnnName Name
n Maybe NameOutput
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing Maybe String
forall a. Maybe a
Nothing
                                    Maybe Term
Nothing -> TC OutputAnnotation -> ElabD OutputAnnotation
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC OutputAnnotation -> ElabD OutputAnnotation)
-> (String -> TC OutputAnnotation)
-> String
-> ElabD OutputAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC OutputAnnotation
forall a. Err -> TC a
tfail (Err -> TC OutputAnnotation)
-> (String -> Err) -> String -> TC OutputAnnotation
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
InternalMsg (String -> ElabD OutputAnnotation)
-> String -> ElabD OutputAnnotation
forall a b. (a -> b) -> a -> b
$
                                                 String
"Can't find name " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n

-- Try again to solve auto implicits
solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
solveAuto :: IState -> Name -> Bool -> (Name, [FailContext]) -> ElabD ()
solveAuto IState
ist Name
fn Bool
ambigok (Name
n, [FailContext]
failc)
  = do hs <- Elab' EState [Name]
forall aux. Elab' aux [Name]
get_holes
       when (not (null hs)) $ do
        env <- get_env
        g <- goal
        handleError cantsolve (when (n `elem` hs) $ do
                        focus n
                        isg <- is_guess -- if it's a guess, we're working on it recursively, so stop
                        when (not isg) $
                          proofSearch' ist True ambigok 100 True Nothing fn [] [])
             (lift $ Error (addLoc failc
                   (CantSolveGoal g (map (\(Name
n, RigCount
_, Binder Term
b) -> (Name
n, Binder Term -> Term
forall b. Binder b -> b
binderTy Binder Term
b)) env))))
        return ()
  where addLoc :: [FailContext] -> Err' t -> Err' t
addLoc (FailContext FC
fc Name
f Name
x : [FailContext]
prev) Err' t
err
           = FC -> Err' t -> Err' t
forall t. FC -> Err' t -> Err' t
At FC
fc (Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
forall t. Name -> Name -> [(Name, Name)] -> Err' t -> Err' t
ElaboratingArg Name
f Name
x
                   ((FailContext -> (Name, Name)) -> [FailContext] -> [(Name, Name)]
forall a b. (a -> b) -> [a] -> [b]
map (\(FailContext FC
_ Name
f' Name
x') -> (Name
f', Name
x')) [FailContext]
prev) Err' t
err)
        addLoc [FailContext]
_ Err' t
err = Err' t
err

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

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

-- Return true if the given error suggests an interface failure is
-- recoverable
tcRecoverable :: ElabMode -> Err -> Bool
tcRecoverable :: ElabMode -> Err -> Bool
tcRecoverable ElabMode
ERHS (CantResolve Bool
f Term
g Err
_) = Bool
f
tcRecoverable ElabMode
ETyDecl (CantResolve Bool
f Term
g Err
_) = Bool
f
tcRecoverable ElabMode
e (ElaboratingArg Name
_ Name
_ [(Name, Name)]
_ Err
err) = ElabMode -> Err -> Bool
tcRecoverable ElabMode
e Err
err
tcRecoverable ElabMode
e (At FC
_ Err
err) = ElabMode -> Err -> Bool
tcRecoverable ElabMode
e Err
err
tcRecoverable ElabMode
_ Err
_ = Bool
True

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

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

-- | Compute the appropriate name for a top-level metavariable
metavarName :: [String] -> Name -> Name
metavarName :: [String] -> Name -> Name
metavarName [String]
_          n :: Name
n@(NS Name
_ [Text]
_) = Name
n
metavarName (ns :: [String]
ns@(String
_:[String]
_)) Name
n          = Name -> [String] -> Name
sNS Name
n [String]
ns
metavarName [String]
_          Name
n          = Name
n

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

  where
    eval :: Term -> StateT (ElabState aux) TC Term
eval Term
tm = do ctxt <- Elab' aux Context
forall aux. Elab' aux Context
get_context
                 return $ normaliseAll ctxt env (finalise tm)

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

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

    pullVars :: (Term, Term) -> ([(Name, Term)], Term, Term)
    pullVars :: (Term, Term) -> ([(Name, Term)], Term, Term)
pullVars (Term
lhs, Term
rhs) = (([(Name, Term)], Term) -> [(Name, Term)]
forall a b. (a, b) -> a
fst ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs), ([(Name, Term)], Term) -> Term
forall a b. (a, b) -> b
snd ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
lhs), ([(Name, Term)], Term) -> Term
forall a b. (a, b) -> b
snd ([(Name, Term)] -> Term -> ([(Name, Term)], Term)
patvars [] Term
rhs)) -- TODO alpha-convert rhs

    requireError :: Err -> ElabD a -> ElabD ()
    requireError :: forall a. Err -> ElabD a -> ElabD ()
requireError Err
orErr ElabD a
elab =
      do state <- StateT (ElabState EState) TC (ElabState EState)
forall s (m :: * -> *). MonadState s m => m s
get
         case runStateT elab state of
           OK (a
_, ElabState EState
state') -> TC () -> ElabD ()
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (Err -> TC ()
forall a. Err -> TC a
tfail Err
orErr)
           Error Err
e -> () -> ElabD ()
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

    -- create a fake TT term for the LHS of an impossible case
    fakeTT :: Raw -> Term
    fakeTT :: Raw -> Term
fakeTT (Var Name
n) =
      case Name -> Context -> [(Name, Def)]
lookupNameDef Name
n (IState -> Context
tt_ctxt IState
ist) of
        [(Name
n', TyDecl NameType
nt Term
_)] -> NameType -> Name -> Term -> Term
forall n. NameType -> n -> TT n -> TT n
P NameType
nt Name
n' Term
forall n. TT n
Erased
        [(Name, Def)]
_ -> NameType -> Name -> Term -> Term
forall n. NameType -> n -> TT n -> TT n
P NameType
Ref Name
n Term
forall n. TT n
Erased
    fakeTT (RBind Name
n Binder Raw
b Raw
body) = Name -> Binder Term -> Term -> Term
forall n. n -> Binder (TT n) -> TT n -> TT n
Bind Name
n ((Raw -> Term) -> Binder Raw -> Binder Term
forall a b. (a -> b) -> Binder a -> Binder b
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
fmap Raw -> Term
fakeTT Binder Raw
b) (Raw -> Term
fakeTT Raw
body)
    fakeTT (RApp Raw
f Raw
a) = AppStatus Name -> Term -> Term -> Term
forall n. AppStatus n -> TT n -> TT n -> TT n
App AppStatus Name
forall n. AppStatus n
Complete (Raw -> Term
fakeTT Raw
f) (Raw -> Term
fakeTT Raw
a)
    fakeTT Raw
RType = UExp -> Term
forall n. UExp -> TT n
TType (String -> Int -> UExp
UVar [] (-Int
1))
    fakeTT (RUType Universe
u) = Universe -> Term
forall n. Universe -> TT n
UType Universe
u
    fakeTT (RConstant Const
c) = Const -> Term
forall n. Const -> TT n
Constant Const
c

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


    checkClosed :: Raw -> Elab' aux (Term, Type)
    checkClosed :: forall aux. Raw -> Elab' aux (Term, Term)
checkClosed Raw
tm = do ctxt <- Elab' aux Context
forall aux. Elab' aux Context
get_context
                        (val, ty) <- lift $ check ctxt [] tm
                        return $! (finalise val, finalise ty)

    -- | Add another argument to a Pi
    mkPi :: RFunArg -> Raw -> Raw
    mkPi :: RFunArg -> Raw -> Raw
mkPi RFunArg
arg Raw
rTy = Name -> Binder Raw -> Raw -> Raw
RBind (RFunArg -> Name
argName RFunArg
arg) (RigCount -> Maybe ImplicitInfo -> Raw -> Raw -> Binder Raw
forall b. RigCount -> Maybe ImplicitInfo -> b -> b -> Binder b
Pi RigCount
RigW Maybe ImplicitInfo
forall a. Maybe a
Nothing (RFunArg -> Raw
argTy RFunArg
arg) (Universe -> Raw
RUType Universe
AllTypes)) Raw
rTy

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

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

    -- | Prepare a constructor to be added to a datatype being defined here
    prepareConstructor :: Name -> RConstructorDefn -> ElabD (Name, [PArg], Type)
    prepareConstructor :: Name -> RConstructorDefn -> ElabD (Name, [PArg], Term)
prepareConstructor Name
tyn (RConstructor Name
cn [RFunArg]
args Raw
resTy) =
      do ctxt <- Elab' EState Context
forall aux. Elab' aux Context
get_context
         -- ensure the constructor name is not qualified, and
         -- construct a qualified one
         notQualified cn
         let qcn = Name -> Name
qualify Name
cn

         -- ensure that the constructor name is not defined already
         mustNotBeDefined ctxt qcn

         -- construct the actual type for the constructor
         let cty = (RFunArg -> Raw -> Raw) -> Raw -> [RFunArg] -> Raw
forall a b. (a -> b -> b) -> b -> [a] -> b
forall (t :: * -> *) a b.
Foldable t =>
(a -> b -> b) -> b -> t a -> b
foldr RFunArg -> Raw -> Raw
mkPi Raw
resTy [RFunArg]
args
         (checkedTy, ctyTy) <- lift $ check ctxt [] cty
         mustBeType ctxt checkedTy ctyTy

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

         -- add temporary type declaration for constructor (so it can
         -- occur in later constructor types)
         set_context (addTyDecl qcn (DCon 0 0 False) checkedTy ctxt)

         -- Save the implicits for high-level Idris
         let impls = (RFunArg -> PArg) -> [RFunArg] -> [PArg]
forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> PArg
rFunArgToPArg [RFunArg]
args

         return (qcn, impls, checkedTy)

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

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

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

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


    -- Should be dependent
    tacTmArgs :: Int -> Term -> [Term] -> ElabD [Term]
    tacTmArgs :: Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
l Term
t [Term]
args | [Term] -> Int
forall a. [a] -> Int
forall (t :: * -> *) a. Foldable t => t a -> Int
length [Term]
args Int -> Int -> Bool
forall a. Eq a => a -> a -> Bool
== Int
l = [Term] -> ElabD [Term]
forall a. a -> StateT (ElabState EState) TC a
forall (m :: * -> *) a. Monad m => a -> m a
return [Term]
args
                       | Bool
otherwise        = Term -> ElabD [Term]
forall a. Term -> ElabD a
elabScriptStuck Term
t -- Probably should be an argument size mismatch internal error


    -- | Do a step in the reflected elaborator monad. The input is the
    -- step, the output is the (reflected) term returned.
    runTacTm :: Term -> ElabD Term
    runTacTm :: Term -> Elab' EState Term
runTacTm tac :: Term
tac@(Term -> (Term, [Term])
forall n. TT n -> (TT n, [TT n])
unApply -> (P NameType
_ Name
n Term
_, [Term]
args))
      | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Solve"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args -- patterns are irrefutable because `tacTmArgs` returns lists of exactly the size given to it as first argument
           solve
           returnUnit
      | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Goal"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           hs <- get_holes
           case hs of
             (Name
h : [Name]
_) -> do t <- Elab' EState Term
forall aux. Elab' aux Term
goal
                           fmap fst . checkClosed $
                             rawPair (Var (reflm "TTName"), Var (reflm "TT"))
                                     (reflectName h,        reflect t)
             [] -> TC Term -> Elab' EState Term
forall (m :: * -> *) a.
Monad m =>
m a -> StateT (ElabState EState) m a
forall (t :: (* -> *) -> * -> *) (m :: * -> *) a.
(MonadTrans t, Monad m) =>
m a -> t m a
lift (TC Term -> Elab' EState Term)
-> (String -> TC Term) -> String -> Elab' EState Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Err -> TC Term
forall a. Err -> TC a
tfail (Err -> TC Term) -> (String -> Err) -> String -> TC Term
forall b c a. (b -> c) -> (a -> b) -> a -> c
. String -> Err
forall t. String -> Err' t
Msg (String -> Elab' EState Term) -> String -> Elab' EState Term
forall a b. (a -> b) -> a -> b
$
                     String
"Elaboration is complete. There are no goals."

      | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Holes"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           hs <- get_holes
           fmap fst . checkClosed $
             mkList (Var $ reflm "TTName") (map reflectName hs)
      | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__Guess"
      = do ~[] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
0 Term
tac [Term]
args
           g <- get_guess
           fmap fst . checkClosed $ reflect g
      | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupTy"
      = do ~[name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           n' <- reifyTTName name
           ctxt <- get_context
           let 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
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, 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 ]
           fmap fst . checkClosed $
             rawList (raw_apply (Var pairTy) [ Var (reflm "TTName")
                                             , raw_apply (Var pairTy) [ Var (reflm "NameType")
                                                                       , Var (reflm "TT")]])
                     defs
      | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupDatatype"
      = do ~[name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           n' <- reifyTTName name
           datatypes <- get_datatypes
           ctxt <- get_context
           fmap fst . checkClosed $
             rawList (Var (tacN "Datatype"))
                     (map reflectDatatype (buildDatatypes ist n'))
      | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupFunDefn"
      = do ~[name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           n' <- reifyTTName name
           fmap fst . checkClosed $
             rawList (RApp (Var $ tacN "FunDefn") (Var $ reflm "TT"))
               (map reflectFunDefn (buildFunDefns ist n'))
      | Name
n Name -> Name -> Bool
forall a. Eq a => a -> a -> Bool
== String -> Name
tacN String
"Prim__LookupArgs"
      = do ~[name] <- Int -> Term -> [Term] -> ElabD [Term]
tacTmArgs Int
1 Term
tac [Term]
args
           n' <- reifyTTName name
           let listTy = Name -> Raw
Var (Name -> [String] -> Name
sNS (String -> Name
sUN String
"List") [String
"List", String
"Prelude"])
               listFunArg = Raw -> Raw -> Raw
RApp Raw
listTy (Name -> Raw
Var (String -> Name
tacN String
"FunArg"))
            -- Idris tuples nest to the right
           let 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, Raw, Raw) -> Raw
reflectTriple (Name -> Raw
reflectName Name
fn, Raw -> [Raw] -> Raw
reflectList (Name -> Raw
Var (String -> Name
tacN String
"FunArg")) ((RFunArg -> Raw) -> [RFunArg] -> [Raw]
forall a b. (a -> b) -> [a] -> [b]
map RFunArg -> Raw
reflectArg [RFunArg]
args), Raw -> Raw
reflectRaw Raw
res)
                 | (Name
fn, [PArg]
pargs) <- Name -> Ctxt [PArg] -> [(Name, [PArg])]
forall a. Name -> Ctxt a -> [(Name, a)]
lookupCtxtName Name
n' (IState -> Ctxt [PArg]
idris_implicits IState
ist)
                 , ([RFunArg]
args, Raw
res) <- [PArg] -> Raw -> ([RFunArg], Raw)
getArgs [PArg]
pargs (Raw -> ([RFunArg], Raw))
-> (Term -> Raw) -> Term -> ([RFunArg], Raw)
forall b c a. (b -> c) -> (a -> b) -> a -> c
. Term -> Raw
forget (Term -> ([RFunArg], Raw)) -> [Term] -> [([RFunArg], Raw)]
forall (f :: * -> *) a b. Functor f => (a -> b) -> f a -> f b
<$>
                                   Maybe Term -> [Term]
forall a. Maybe a -> [a]
maybeToList (Name -> Context -> Maybe Term
lookupTyExact Name
fn (IState -> Context
tt_ctxt IState
ist))
                 ]

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

           (ctxt', ES (p, aux') _ _) <-
              do (ES (current_p, _) _ _) <- get
                 lift $ runElab aux
                             (do runElabAction info ist fc [] script ns
                                 ctxt' <- get_context
                                 return ctxt')
                             ((newProof recH (constraintNS info) ctxt datatypes g_next goalTT)
                              { nextname = nextname current_p })
           set_context ctxt'

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

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

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

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

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

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


withErrorReflection :: Idris a -> Idris a
withErrorReflection :: forall a. Idris a -> Idris a
withErrorReflection Idris a
x = Idris a -> (Err -> Idris a) -> Idris a
forall a. Idris a -> (Err -> Idris a) -> Idris a
idrisCatch Idris a
x (\ Err
e -> Err -> Idris Err
handle Err
e Idris Err -> (Err -> Idris a) -> Idris a
forall a b.
StateT IState (ExceptT Err IO) a
-> (a -> StateT IState (ExceptT Err IO) b)
-> StateT IState (ExceptT Err IO) b
forall (m :: * -> *) a b. Monad m => m a -> (a -> m b) -> m b
>>= Err -> Idris a
forall a. Err -> Idris a
ierror)
    where handle :: Err -> Idris Err
          handle :: Err -> Idris Err
handle e :: Err
e@(ReflectionError [[ErrorReportPart]]
_ Err
_)  = do Int -> String -> Idris ()
logElab Int
3 String
"Skipping reflection of error reflection result"
                                               Err -> Idris Err
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Err
e -- Don't do meta-reflection of errors
          handle e :: Err
e@(ReflectionFailed String
_ Err
_) = do Int -> String -> Idris ()
logElab Int
3 String
"Skipping reflection of reflection failure"
                                               Err -> Idris Err
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Err
e
          -- At and Elaborating are just plumbing - error reflection shouldn't rewrite them
          handle e :: Err
e@(At FC
fc Err
err) = do Int -> String -> Idris ()
logElab Int
3 String
"Reflecting body of At"
                                    err' <- Err -> Idris Err
handle Err
err
                                    return (At fc 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 -> Idris Err
handle Err
err
                                                    return (Elaborating what n ty 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"
                                                      hs <- Name -> Name -> Idris [Name]
getFnHandlers Name
f Name
a
                                                      err' <- if null hs
                                                                 then handle err
                                                                 else applyHandlers err hs
                                                      return (ElaboratingArg f a prev 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 ist <- Idris IState
getIState
                        logElab 2 "Starting error reflection"
                        logElab 5 (show e)
                        let handlers = IState -> [Name]
idris_errorhandlers IState
ist
                        applyHandlers e handlers
          getFnHandlers :: Name -> Name -> Idris [Name]
          getFnHandlers :: Name -> Name -> Idris [Name]
getFnHandlers Name
f Name
arg = do ist <- Idris IState
getIState
                                   let funHandlers = Map Name (Set Name)
-> (Map Name (Set Name) -> Map Name (Set Name))
-> Maybe (Map Name (Set Name))
-> Map Name (Set Name)
forall b a. b -> (a -> b) -> Maybe a -> b
maybe Map Name (Set Name)
forall k a. Map k a
M.empty Map Name (Set Name) -> Map Name (Set Name)
forall a. a -> a
id (Maybe (Map Name (Set Name)) -> Map Name (Set Name))
-> (IState -> Maybe (Map Name (Set Name)))
-> IState
-> Map Name (Set Name)
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                                     Name -> Ctxt (Map Name (Set Name)) -> Maybe (Map Name (Set Name))
forall a. Name -> Ctxt a -> Maybe a
lookupCtxtExact Name
f (Ctxt (Map Name (Set Name)) -> Maybe (Map Name (Set Name)))
-> (IState -> Ctxt (Map Name (Set Name)))
-> IState
-> Maybe (Map Name (Set Name))
forall b c a. (b -> c) -> (a -> b) -> a -> c
.
                                                     IState -> Ctxt (Map Name (Set Name))
idris_function_errorhandlers (IState -> Map Name (Set Name)) -> IState -> Map Name (Set Name)
forall a b. (a -> b) -> a -> b
$ IState
ist
                                   return . maybe [] S.toList . M.lookup arg $ funHandlers


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

                         -- Typecheck error handlers - if this fails, most
                         -- likely something which is needed by it has not
                         -- been imported, so keep the original error.
                         handlers <- case mapM (check (tt_ctxt ist) []) reports of
                                       Error Err
_ -> [(Term, Term)] -> StateT IState (ExceptT Err IO) [(Term, Term)]
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [] -- ierror $ ReflectionFailed "Type error while constructing reflected error" e
                                       OK [(Term, Term)]
hs   -> [(Term, Term)] -> StateT IState (ExceptT Err IO) [(Term, Term)]
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return [(Term, Term)]
hs

                         -- Normalize error handler terms to produce the new messages
                         -- Need to use 'normaliseAll' since we have to reduce private
                         -- names in error handlers too
                         ctxt <- getContext
                         let results = (Term -> Term) -> [Term] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Context -> Env -> Term -> Term
normaliseAll Context
ctxt []) (((Term, Term) -> Term) -> [(Term, Term)] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map (Term, Term) -> Term
forall a b. (a, b) -> a
fst [(Term, Term)]
handlers)
                         logElab 3 $ "New error message info: " ++ concat (intersperse " and " (map show results))

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

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

-- | Do the left-over work after creating declarations in reflected
-- elaborator scripts
processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()
processTacticDecls :: ElabInfo -> [RDeclInstructions] -> Idris ()
processTacticDecls ElabInfo
info [RDeclInstructions]
steps =
  -- The order of steps is important: type declarations might
  -- establish metavars that later function bodies resolve.
  [RDeclInstructions] -> (RDeclInstructions -> Idris ()) -> Idris ()
forall (t :: * -> *) (m :: * -> *) a b.
(Foldable t, Monad m) =>
t a -> (a -> m b) -> m ()
forM_ ([RDeclInstructions] -> [RDeclInstructions]
forall a. [a] -> [a]
reverse [RDeclInstructions]
steps) ((RDeclInstructions -> Idris ()) -> Idris ())
-> (RDeclInstructions -> Idris ()) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \case
    RTyDeclInstrs Name
n FC
fc [PArg]
impls Term
ty ->
      do Int -> String -> Idris ()
logElab Int
3 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"Declaration from tactics: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n String -> String -> String
forall a. [a] -> [a] -> [a]
++ String
" : " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Term -> String
forall a. Show a => a -> String
show Term
ty
         Int -> String -> Idris ()
logElab Int
3 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"  It has impls " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [PArg] -> String
forall a. Show a => a -> String
show [PArg]
impls
         (IState -> IState) -> Idris ()
updateIState ((IState -> IState) -> Idris ()) -> (IState -> IState) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits =
                                    addDef n impls (idris_implicits i) }
         IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCImp Name
n)
         ds <- ElabInfo
-> FC
-> (Name -> Err -> Err)
-> Bool
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> Idris [(Name, (Int, Maybe Name, Term, [Name]))]
checkDef ElabInfo
info FC
fc (\Name
_ Err
e -> Err
e) Bool
True [(Name
n, (-Int
1, Maybe Name
forall a. Maybe a
Nothing, Term
ty, []))]
         addIBC (IBCDef n)
         ctxt <- getContext
         case lookupDef n ctxt of
           (TyDecl NameType
_ Term
_ : [Def]
_) ->
             -- If the function isn't defined at the end of the elab script,
             -- then it must be added as a metavariable. This needs guarding
             -- to prevent overwriting case defs with a metavar, if the case
             -- defs come after the type decl in the same script!
             let ds' :: [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))]
ds' = ((Name, (Int, Maybe Name, Term, [Name]))
 -> (Name, (Int, Maybe Name, Term, [Name], Bool, Bool)))
-> [(Name, (Int, Maybe Name, Term, [Name]))]
-> [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))]
forall a b. (a -> b) -> [a] -> [b]
map (\(Name
n, (Int
i, Maybe Name
top, Term
t, [Name]
ns)) -> (Name
n, (Int
i, Maybe Name
top, Term
t, [Name]
ns, Bool
True, Bool
True))) [(Name, (Int, Maybe Name, Term, [Name]))]
ds
             in [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))] -> Idris ()
addDeferred [(Name, (Int, Maybe Name, Term, [Name], Bool, Bool))]
ds'
           [Def]
_ -> () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()
    RDatatypeDeclInstrs Name
n [PArg]
impls ->
      do IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCDef Name
n)
         (IState -> IState) -> Idris ()
updateIState ((IState -> IState) -> Idris ()) -> (IState -> IState) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_implicits = addDef n impls (idris_implicits i) }
         IBCWrite -> Idris ()
addIBC (Name -> IBCWrite
IBCImp Name
n)

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


         ttag <- getName -- from AbsSyntax.hs, really returns a disambiguating Int

         let metainf = [Int] -> MetaInformation
DataMI [Int]
params
         addIBC (IBCMetaInformation tyn metainf)
         updateContext (setMetaInformation tyn metainf)

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

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

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

    RAddImplementation Name
interfaceName Name
implName ->
      do -- The interface resolution machinery relies on a special
         Int -> String -> Idris ()
logElab Int
2 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"Adding elab script implementation " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
implName String -> String -> String
forall a. [a] -> [a] -> [a]
++
                     String
" for " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
interfaceName
         Bool -> Bool -> Name -> Name -> Idris ()
addImplementation Bool
False Bool
True Name
interfaceName Name
implName
         IBCWrite -> Idris ()
addIBC (Bool -> Bool -> Name -> Name -> IBCWrite
IBCImplementation Bool
False Bool
True Name
interfaceName Name
implName)
    RClausesInstrs Name
n [([(Name, Term)], Term, Term)]
cs ->
      do Int -> String -> Idris ()
logElab Int
3 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"Pattern-matching definition from tactics: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ Name -> String
forall a. Show a => a -> String
show Name
n
         FC -> Name -> Idris ()
solveDeferred FC
emptyFC Name
n
         let lhss :: [([Name], Term)]
lhss = (([(Name, Term)], Term, Term) -> ([Name], Term))
-> [([(Name, Term)], Term, Term)] -> [([Name], Term)]
forall a b. (a -> b) -> [a] -> [b]
map (\([(Name, Term)]
ns, Term
lhs, Term
_) -> (((Name, Term) -> Name) -> [(Name, Term)] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, Term) -> Name
forall a b. (a, b) -> a
fst [(Name, Term)]
ns, Term
lhs)) [([(Name, Term)], Term, Term)]
cs
         let fc :: FC
fc = String -> FC
fileFC String
"elab_reflected"
         pmissing <-
           do ist <- Idris IState
getIState
              possible <- genClauses fc n lhss
                                     (map (\ ([Name]
ns, Term
lhs) ->
                                        IState -> Term -> Bool -> Bool -> PTerm
delab' IState
ist Term
lhs Bool
True Bool
True) lhss)
              missing <- filterM (checkPossible n) possible
              let undef = (PTerm -> Bool) -> [PTerm] -> [PTerm]
forall a. (a -> Bool) -> [a] -> [a]
filter (IState -> [Term] -> PTerm -> Bool
forall {t :: * -> *}.
Foldable t =>
IState -> t Term -> PTerm -> Bool
noMatch IState
ist ((([Name], Term) -> Term) -> [([Name], Term)] -> [Term]
forall a b. (a -> b) -> [a] -> [b]
map ([Name], Term) -> Term
forall a b. (a, b) -> b
snd [([Name], Term)]
lhss)) [PTerm]
missing
              return undef
         let tot = if [PTerm] -> Bool
forall a. [a] -> Bool
forall (t :: * -> *) a. Foldable t => t a -> Bool
null [PTerm]
pmissing
                      then Totality
Unchecked -- still need to check recursive calls
                      else PReason -> Totality
Partial PReason
NotCovering -- missing cases implies not total
         setTotality n tot
         updateIState $ \IState
i -> IState
i { idris_patdefs =
                                    addDef n (cs, pmissing) $ idris_patdefs i }
         addIBC (IBCDef n)

         ctxt <- getContext
         case lookupDefExact n ctxt of
           Just (CaseOp CaseInfo
_ Term
_ [(Term, Bool)]
_ [Either Term (Term, Term)]
_ [([Name], Term, Term)]
_ CaseDefs
cd) ->
             -- Here, we populate the call graph with a list of things
             -- we refer to, so that if they aren't total, the whole
             -- thing won't be.
             let ([Name]
scargs, SC
sc) = CaseDefs -> ([Name], SC)
cases_compiletime CaseDefs
cd
                 calls :: [Name]
calls = ((Name, [[Name]]) -> Name) -> [(Name, [[Name]])] -> [Name]
forall a b. (a -> b) -> [a] -> [b]
map (Name, [[Name]]) -> Name
forall a b. (a, b) -> a
fst ([(Name, [[Name]])] -> [Name]) -> [(Name, [[Name]])] -> [Name]
forall a b. (a -> b) -> a -> b
$ SC -> [Name] -> [(Name, [[Name]])]
findCalls SC
sc [Name]
scargs
             in do Int -> String -> Idris ()
logElab Int
2 (String -> Idris ()) -> String -> Idris ()
forall a b. (a -> b) -> a -> b
$ String
"Called names in reflected elab: " String -> String -> String
forall a. [a] -> [a] -> [a]
++ [Name] -> String
forall a. Show a => a -> String
show [Name]
calls
                   Name -> [Name] -> Idris ()
addCalls Name
n [Name]
calls
                   IBCWrite -> Idris ()
addIBC (IBCWrite -> Idris ()) -> IBCWrite -> Idris ()
forall a b. (a -> b) -> a -> b
$ Name -> IBCWrite
IBCCG Name
n
           Just Def
_ -> () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return () -- TODO throw internal error
           Maybe Def
Nothing -> () -> Idris ()
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return ()

         -- checkDeclTotality requires that the call graph be present
         -- before calling it.
         -- TODO: reduce code duplication with Idris.Elab.Clause
         buildSCG (fc, 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.
         tot' <- checkDeclTotality (fc, n)
         setTotality n tot'
         when (tot' /= Unchecked) $ addIBC (IBCTotal n tot')
  where
    -- TODO: see if the code duplication with Idris.Elab.Clause can be
    -- reduced or eliminated.
    -- These are always cases generated by genClauses
    checkPossible :: Name -> PTerm -> Idris Bool
    checkPossible :: Name -> PTerm -> StateT IState (ExceptT Err IO) Bool
checkPossible Name
fname PTerm
lhs_in =
       do ctxt <- Idris Context
getContext
          ist <- getIState
          let lhs = IState -> PTerm -> PTerm
addImplPat IState
ist PTerm
lhs_in
          let fc = String -> FC
fileFC String
"elab_reflected_totality"
          case elaborate (constraintNS info) ctxt (idris_datatypes ist) (idris_name ist) (sMN 0 "refPatLHS") infP initEState
                (erun fc (buildTC ist info EImpossible [] fname (allNamesIn lhs_in)
                                                                (infTerm lhs))) of
            OK (ElabResult Term
lhs' [(Name, (Int, Maybe Name, Term, [Name]))]
_ [PDecl]
_ Context
_ [RDeclInstructions]
_ Set (FC', OutputAnnotation)
_ Int
name', String
_) ->
              do -- not recursively calling here, because we don't
                 -- want to run infinitely many times
                 let lhs_tm :: Term
lhs_tm = Term -> Term
orderPats (Term -> Term
getInferTerm Term
lhs')
                 (IState -> IState) -> Idris ()
updateIState ((IState -> IState) -> Idris ()) -> (IState -> IState) -> Idris ()
forall a b. (a -> b) -> a -> b
$ \IState
i -> IState
i { idris_name = name' }
                 case String -> Context -> Env -> Raw -> Term -> TC (Term, Term, UCs)
recheck (ElabInfo -> String
constraintNS ElabInfo
info) Context
ctxt [] (Term -> Raw
forget Term
lhs_tm) Term
lhs_tm of
                      OK (Term, Term, UCs)
_ -> Bool -> StateT IState (ExceptT Err IO) Bool
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
True
                      TC (Term, Term, UCs)
err -> Bool -> StateT IState (ExceptT Err IO) Bool
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return Bool
False
            -- if it's a recoverable error, the case may become possible
            Error Err
err -> Bool -> StateT IState (ExceptT Err IO) Bool
forall a. a -> StateT IState (ExceptT Err IO) a
forall (m :: * -> *) a. Monad m => a -> m a
return (Context -> Err -> Bool
recoverableCoverage Context
ctxt Err
err)


    -- TODO: Attempt to reduce/eliminate code duplication with Idris.Elab.Clause
    noMatch :: IState -> t Term -> PTerm -> Bool
noMatch IState
i t Term
cs PTerm
tm = (Term -> Bool) -> t Term -> Bool
forall (t :: * -> *) a. Foldable t => (a -> Bool) -> t a -> Bool
all (\Term
x -> case IState -> PTerm -> PTerm -> Either (PTerm, PTerm) [(Name, PTerm)]
matchClause IState
i (IState -> Term -> Bool -> Bool -> PTerm
delab' IState
i Term
x Bool
True Bool
True) PTerm
tm of
                                   Right [(Name, PTerm)]
_ -> Bool
False
                                   Left  (PTerm, PTerm)
_ -> Bool
True) t Term
cs