Finding simple autos after elab
This commit is contained in:
@@ -97,7 +97,7 @@ parameters (ctx: Context)
|
||||
if elem k acc
|
||||
then do
|
||||
debug "\{show k} \{show acc}"
|
||||
|
||||
-- when does this happen?
|
||||
error fc "non-linear pattern: \{show sp}"
|
||||
else go xs (k :: acc)
|
||||
go (xs :< v) _ = error emptyFC "non-variable in pattern \{show v}"
|
||||
@@ -137,8 +137,8 @@ parameters (ctx: Context)
|
||||
-- REVIEW can I get better names in here?
|
||||
lams (S k) tm = Lam emptyFC "arg_\{show k}" (lams k tm)
|
||||
|
||||
|
||||
solve : Nat -> Nat -> SnocList Val -> Val -> M ()
|
||||
export
|
||||
solve : (lvl : Nat) -> (k : Nat) -> SnocList Val -> Val -> M ()
|
||||
solve l m sp t = do
|
||||
debug "solve \{show m} lvl \{show l} sp \{show sp} is \{show t}"
|
||||
meta@(Unsolved metaFC ix ctx ty _) <- lookupMeta m
|
||||
|
||||
@@ -2,6 +2,7 @@ module Lib.ProcessDecl
|
||||
|
||||
import Data.IORef
|
||||
import Data.String
|
||||
import Data.Vect
|
||||
|
||||
import Lib.Elab
|
||||
import Lib.Parser
|
||||
@@ -11,6 +12,29 @@ import Lib.Eval
|
||||
import Lib.Types
|
||||
import Lib.Util
|
||||
|
||||
|
||||
-- This is a crude first pass
|
||||
-- TODO consider ctx
|
||||
findMatches : Val -> List TopEntry -> M (List Tm)
|
||||
findMatches ty [] = pure []
|
||||
findMatches ty ((MkEntry name type def@(Fn t)) :: xs) = do
|
||||
top <- get
|
||||
let ctx = mkCtx top.metas (getFC ty)
|
||||
-- FIXME we're restoring state, but the INFO logs have already been emitted
|
||||
-- Also redo this whole thing to run during elab, recheck constraints, etc.
|
||||
mc <- readIORef top.metas
|
||||
catchError {e=Error} (do
|
||||
-- TODO sort out the FC here
|
||||
let fc = getFC ty
|
||||
tm <- check (mkCtx top.metas fc) (RVar fc name) ty
|
||||
debug "Found \{pprint [] tm} for \{show ty}"
|
||||
(tm ::) <$> findMatches ty xs)
|
||||
(\ _ => do
|
||||
writeIORef top.metas mc
|
||||
debug "No match \{show ty} \{pprint [] type}"
|
||||
findMatches ty xs)
|
||||
findMatches ty (y :: xs) = findMatches ty xs
|
||||
|
||||
getArity : Tm -> Nat
|
||||
getArity (Pi x str icit t u) = S (getArity u)
|
||||
-- Ref or App (of type constructor) are valid
|
||||
@@ -28,6 +52,13 @@ collectDecl ((Def fc nm cl) :: rest@(Def _ nm' cl' :: xs)) =
|
||||
else (Def fc nm cl :: collectDecl rest)
|
||||
collectDecl (x :: xs) = x :: collectDecl xs
|
||||
|
||||
-- Makes the arg for `solve` when we solve an auto
|
||||
makeSpine : Nat -> Vect k BD -> SnocList Val
|
||||
makeSpine k [] = [<]
|
||||
makeSpine (S k) (Defined :: xs) = makeSpine k xs
|
||||
makeSpine (S k) (Bound :: xs) = makeSpine k xs :< VVar emptyFC k [<]
|
||||
makeSpine 0 xs = ?fixme
|
||||
|
||||
export
|
||||
processDecl : Decl -> M ()
|
||||
|
||||
@@ -80,21 +111,35 @@ processDecl (Def fc nm clauses) = do
|
||||
clauses' <- traverse (makeClause top) clauses
|
||||
tm <- buildTree (mkCtx top.metas fc) (MkProb clauses' vty)
|
||||
putStrLn "Ok \{pprint [] tm}"
|
||||
|
||||
mc <- readIORef top.metas
|
||||
let mlen = length mc.metas `minus` mstart
|
||||
for_ (take mlen mc.metas) $ \case
|
||||
(Unsolved fc k ctx ty AutoSolve) => do
|
||||
debug "auto solving \{show k} : \{show ty}"
|
||||
-- we want the context here too.
|
||||
[tm] <- findMatches ty top.defs
|
||||
| res => error fc "Failed to solve \{show ty}, matches: \{show $ map (pprint []) res}"
|
||||
val <- eval ctx.env CBN tm
|
||||
let sp = makeSpine ctx.lvl ctx.bds
|
||||
solve ctx ctx.lvl k sp val
|
||||
pure ()
|
||||
_ => pure ()
|
||||
|
||||
tm' <- zonk top 0 [] tm
|
||||
putStrLn "NF \{pprint[] tm'}"
|
||||
|
||||
mc <- readIORef top.metas
|
||||
|
||||
-- Maybe here we try search?
|
||||
|
||||
for_ (drop mstart mc.metas) $ \case
|
||||
-- for_ (take mlen mc.metas) $ \case
|
||||
for_ (mc.metas) $ \case
|
||||
(Solved k x) => pure ()
|
||||
(Unsolved (l,c) k ctx ty User) => do
|
||||
-- TODO print here
|
||||
-- TODO print here instead of during Elab
|
||||
pure ()
|
||||
(Unsolved (l,c) k ctx ty kind) => do
|
||||
tm <- quote ctx.lvl !(forceMeta ty)
|
||||
-- Now that we're collecting errors, maybe we simply check at the end
|
||||
addError $ E (l,c) "Unsolved meta \{show k} type \{pprint (names ctx) tm}"
|
||||
addError $ E (l,c) "Unsolved meta \{show k} \{show kind} type \{pprint (names ctx) tm}"
|
||||
debug "Add def \{nm} \{pprint [] tm'} : \{pprint [] ty}"
|
||||
modify $ setDef nm ty (Fn tm')
|
||||
|
||||
|
||||
Reference in New Issue
Block a user