diff --git a/src/Lib/Check.idr b/src/Lib/Check.idr index 81a9f94..1dd1f6e 100644 --- a/src/Lib/Check.idr +++ b/src/Lib/Check.idr @@ -4,14 +4,16 @@ import Control.Monad.Error.Interface import Control.Monad.Identity import Lib.Parser.Impl import Lib.Prettier +import Data.List import Data.Vect import Data.String import Lib.TT import Lib.TopContext import Syntax - - +-- renaming +-- dom gamma ren +data PRen = PR Nat Nat (List Nat) -- IORef for metas needs IO parameters {0 m : Type -> Type} {auto _ : HasIO m} {auto _ : MonadError Error m} (top : TopContext) @@ -26,6 +28,80 @@ parameters {0 m : Type -> Type} {auto _ : HasIO m} {auto _ : MonadError Error m} -- unify l (VPi str icit x y) u = ?unify_rhs_5 -- unify l VU u = ?unify_rhs_6 + forceMeta : Val -> Val + -- TODO - need to look up metas + forceMeta x = x + + -- return renaming, the position is the new VVar + invert : Nat -> List Val -> m (List Nat) + invert lvl sp = go sp [] + where + go : List Val -> List Nat -> m (List Nat) + go [] acc = pure acc + go ((VVar k []) :: xs) acc = do + if elem k acc + then throwError $ E (0,0) "non-linear pattern" + else go xs (k :: acc) + go _ _ = throwError $ E (0,0) "non-variable in pattern" + + -- we have to "lift" the renaming when we go under a lambda + -- I think that essentially means our domain ix are one bigger, since we're looking at lvl + -- in the codomain, so maybe we can just keep that value + rename : Nat -> List Nat -> Nat -> Val -> m Tm + rename meta ren lvl v = go ren lvl v + where + go : List Nat -> Nat -> Val -> m Tm + goSpine : List Nat -> Nat -> Tm -> List Val -> m Tm + goSpine ren lvl tm [] = pure tm + goSpine ren lvl tm (x :: xs) = do + xtm <- go ren lvl x + goSpine ren lvl (App tm xtm) xs + + go ren lvl (VVar k sp) = case findIndex (== k) ren of + Nothing => throwError $ E (0,0) "scope/skolem thinger" + Just x => goSpine ren lvl (Bnd $ cast x) sp + go ren lvl (VRef nm sp) = goSpine ren lvl (Ref nm Nothing) sp + go ren lvl (VMeta ix sp) = if ix == meta + then throwError $ E (0,0) "meta occurs check" + else goSpine ren lvl (Meta ix) sp + go ren lvl (VLam n icit t) = pure (Lam n icit !(go (lvl :: ren) (S lvl) (t $$ VVar lvl []))) + go ren lvl (VPi n icit ty tm) = pure (Pi n icit !(go ren lvl ty) !(go (lvl :: ren) (S lvl) (tm $$ VVar lvl []))) + go ren lvl VU = pure U + + -- lams : Nat -> Tm -> Tm + -- lams 0 tm = tm + -- lams (S k) tm = Lam + + solve : Nat -> Nat -> List Val -> Val -> m () + solve l m sp t = do + ren <- invert l sp + tm <- rename m ren l t + printLn "solution to \{show m} is \{show tm}" + + pure () + + unify : (l : Nat) -> Val -> Val -> m () + + unifySpine : Nat -> Bool -> List Val -> List Val -> m () + unifySpine l False _ _ = throwError $ E (0,0) "unify failed" + unifySpine l True [] [] = pure () + unifySpine l True (x :: xs) (y :: ys) = unify l x y >> unifySpine l True xs ys + unifySpine l True _ _ = throwError $ E (0,0) "meta spine length mismatch" + + unify l t u = case (forceMeta t, forceMeta u) of + (VLam _ _ t, VLam _ _ t' ) => unify (l + 1) (t $$ VVar l []) (t' $$ VVar l []) + (t, VLam _ _ t' ) => unify (l + 1) (t `vapp` VVar l []) (t' $$ VVar l []) + (VLam _ _ t, t' ) => unify (l + 1) (t $$ VVar l []) (t' `vapp` VVar l []) + (VPi _ _ a b, VPi _ _ a' b') => unify l a a' >> unify (S l) (b $$ VVar l []) (b' $$ VVar l []) + (VVar k sp, VVar k' sp' ) => unifySpine l (k == k') sp sp' + (VRef n sp, VRef n' sp' ) => unifySpine l (n == n') sp sp' + (VMeta i sp, VMeta i' sp' ) => unifySpine l (i == i') sp sp' + + (t, VMeta i' sp') => solve l i' sp' t + (VMeta i sp, t' ) => solve l i sp t' + (VU, VU) => pure () + _ => throwError $ E (0,0) "unify failed" + export infer : Context -> Raw -> m (Tm, Val) @@ -40,20 +116,15 @@ parameters {0 m : Type -> Type} {auto _ : HasIO m} {auto _ : MonadError Error m} let ctx' = extend ctx nm a tm' <- check ctx' tm (b $$ var) pure $ Lam nm icit tm' - - -- So it gets stuck for `List a`, not a pi type, and we want the - -- (This is not a data constructor, but a church encoding) - -- List reduces now and we're stuck for `Nat`. - other => error [(DS "Expected pi type, got \{show $ quote 0 ty}")] check ctx tm ty = do (tm', ty') <- infer ctx tm -- This is where the conversion check / pattern unification go - -- unify ctx.lvl ty' ty - if quote 0 ty /= quote 0 ty' then - error [DS "type mismatch got", DD (quote 0 ty'), DS "expected", DD (quote 0 ty)] - else pure tm' - + unify ctx.lvl ty' ty + -- if quote 0 ty /= quote 0 ty' then + -- error [DS "type mismatch got", DD (quote 0 ty'), DS "expected", DD (quote 0 ty)] + -- else pure tm' + pure tm' infer ctx (RVar nm) = go 0 ctx.types where go : Nat -> Vect n (String, Val) -> m (Tm, Val) diff --git a/src/Lib/TT.idr b/src/Lib/TT.idr index 239974d..94349f3 100644 --- a/src/Lib/TT.idr +++ b/src/Lib/TT.idr @@ -7,7 +7,6 @@ module Lib.TT -- For SourcePos import Lib.Parser.Impl import Lib.Prettier -import Lib.Metas import Control.Monad.Error.Interface @@ -189,9 +188,6 @@ export nf : Env -> Tm -> Tm nf env t = quote (length env) (eval env CBN t) -public export -conv : (lvl : Nat) -> Val -> Val -> Bool - {- smalltt @@ -221,9 +217,9 @@ Can I get val back? Do we need to quote? What happens if we don't? -} - +-- FIXME remove List BD public export -data MetaEntry = Unsolved Nat (List BD) | Solved Nat Tm (List BD) +data MetaEntry = Unsolved Nat (List BD) | Solved Nat Val public export record MetaContext where @@ -298,6 +294,11 @@ freshMeta ctx = do applyBDs k t (Bound :: xs) = applyBDs (S k) (App t (Bnd k)) xs applyBDs k t (Defined :: xs) = applyBDs (S k) t xs +-- solveMeta : HasIO m => Context -> m Tm +-- solveMeta ctx = do +-- mc <- readIORef ctx.metas + + -- we need more of topcontext later - Maybe switch it up so we're not passing -- around top export