diff --git a/src/Lib/Elab.newt b/src/Lib/Elab.newt index b809023..a6e5d47 100644 --- a/src/Lib/Elab.newt +++ b/src/Lib/Elab.newt @@ -283,7 +283,7 @@ addConstraint env ix sp tm = do let (CheckAll) = mc.mcmode | _ => pure MkUnit updateMeta ix $ \case (Unsolved pos k a b c cons) => do - debug $ \ _ => "Add constraint m\{show ix} \{show sp} =?= \{show tm}" + debug $ \ _ => "Add constraint \{show ix} \{show sp} =?= \{show tm}" pure (Unsolved pos k a b c (MkMc (getFC tm) env sp tm :: cons)) (Solved fc k tm) => error fc "Meta \{show k} already solved [addConstraint]" (OutOfScope) => error' "Meta \{show ix} out of scope" @@ -391,7 +391,7 @@ solve env m sp t = do | _ => do let l = length' env debug $ \ _ => "meta \{show m} (\{show ix}) applied to \{show $ snoclen sp} args instead of \{show size}" - debug $ \ _ => "CONSTRAINT m\{show ix} \{show sp} =?= \{show t}" + debug $ \ _ => "CONSTRAINT \{show ix} \{show sp} =?= \{show t}" addConstraint env m sp t let l = length' env debug $ \ _ => "meta \{show meta}" @@ -435,12 +435,10 @@ solve env m sp t = do (\case Postpone fc ix msg => do -- let someone else solve this and then check again. - debug $ \ _ => "CONSTRAINT2 m\{show ix} \{show sp} =?= \{show t}" + debug $ \ _ => "CONSTRAINT2 \{show ix} \{show sp} =?= \{show t}" addConstraint env m sp t - -- I get legit errors after stuffing in solution - -- report for now, tests aren't hitting this branch - err => throwError err - -- debug $ \ _ => "CONSTRAINT3 m\{show ix} \{show sp} =?= \{show t}" + E fc msg => throwError (E fc "\{msg} for \{show ix} \{show sp} =?= \{show t}") + -- debug $ \ _ => "CONSTRAINT3 \{show ix} \{show sp} =?= \{show t}" -- debug $ \ _ => "because \{showError "" err}" -- addConstraint env m sp t ) @@ -628,7 +626,7 @@ freshMeta ctx fc ty kind = do debug $ \ _ => "fresh meta \{show mc.next} : \{show ty} (\{show kind})" -- need the ns here -- we were fudging this for v1 - let qn = QN top.ns "$m\{show mc.next}" + let qn = QN top.ns "\{show mc.next}" let newmeta = Unsolved fc qn ctx ty kind Nil let autos = case kind of AutoSolve => qn :: mc.autos @@ -775,6 +773,9 @@ substVal k v tm = go tm updateContext : Context -> List (Int × Val) -> M Context updateContext ctx Nil = pure ctx updateContext ctx ((k, val) :: cs) = + -- We were turning Bound into Defined + if isSelf k val then updateContext ctx cs + else let ix = cast $ lvl2ix (length' ctx.env) k in case getAt ix ctx.env of (Just (VVar _ k' Lin)) => @@ -789,6 +790,10 @@ updateContext ctx ((k, val) :: cs) = updateContext ctx cs Nothing => error (getFC val) "INTERNAL ERROR: bad index in updateContext" where + isSelf : Int → Val → Bool + isSelf ix (VVar _ k Lin) = ix == k + isSelf ix _ = False + replaceV : ∀ a. Nat -> a -> List a -> List a replaceV k x Nil = Nil replaceV Z x (y :: xs) = x :: xs diff --git a/src/Main.newt b/src/Main.newt index 48810d7..d724f8b 100644 --- a/src/Main.newt +++ b/src/Main.newt @@ -179,9 +179,9 @@ processModule importFC base stk qn@(QN ns nm) = do let modules = updateMap modns mod top.modules modifyTop [modules := modules] + logMetas $ reverse $ listValues top.metaCtx.metas let (Nil) = top.errors | errors => exitFailure "Compile failed" - logMetas $ reverse $ listValues top.metaCtx.metas pure src where tryProcessDecl : String -> List String → Decl -> M Unit diff --git a/tests/Data b/tests/Data new file mode 120000 index 0000000..e57d8b9 --- /dev/null +++ b/tests/Data @@ -0,0 +1 @@ +../src/Data \ No newline at end of file diff --git a/tests/Data/SortedMap.newt b/tests/Data/SortedMap.newt deleted file mode 120000 index ce2a870..0000000 --- a/tests/Data/SortedMap.newt +++ /dev/null @@ -1 +0,0 @@ -../../src/Data/SortedMap.newt \ No newline at end of file diff --git a/tests/WellTyped.newt b/tests/WellTyped.newt new file mode 100644 index 0000000..51f1718 --- /dev/null +++ b/tests/WellTyped.newt @@ -0,0 +1,75 @@ +module WellTyped + +-- Idris2's "Well Typed Interpreter" example +-- This is a little painful for lack of overloading. +-- I can add idris/haskell style sections. +-- This is revealing some issues. :/ + +-- I had to put {0 ctxt : Vect n Ty} → in manually, the `∀ ctxt` wasn't inferring the type. +-- This may be because we have `n`, which becomes a parameter when do it manually. +-- That would explain why Idris adds those... + +-- This also revealed an issue in case tree building where a bound name was accidentally made into a defined one. + +import Prelude +import Data.Vect +import Data.Fin + +data Ty = TyInt | TyBool | TyFun Ty Ty + +interpTy : Ty → U +interpTy TyInt = Int +interpTy TyBool = Bool +interpTy (TyFun x y) = interpTy x → interpTy y + +data HasType : ∀ n. (i : Fin n) → Vect n Ty → Ty → U where + Stop : ∀ t n. {0 ctxt : Vect n Ty} → HasType FZ (t :- ctxt) t + Pop : ∀ n t u. {0 ctxt : Vect n Ty} {0 k : Fin n} → HasType k ctxt t → HasType (FS k) (u :- ctxt) t + +data Expr : ∀ n. Vect n Ty → Ty → U where + Var : ∀ t n. {0 ctxt : Vect n Ty} {0 i : Fin n} → HasType i ctxt t → Expr ctxt t + Val : ∀ n. {0 ctxt : Vect n Ty} → (x : Int) → Expr ctxt TyInt + Lam : ∀ a n t. {0 ctxt : Vect n Ty} → Expr (a :- ctxt) t → Expr ctxt (TyFun a t) + App : ∀ n a t. {0 ctxt : Vect n Ty} → Expr ctxt (TyFun a t) → Expr ctxt a → Expr ctxt t + Op : ∀ a b c n. {0 ctxt : Vect n Ty} → (interpTy a → interpTy b → interpTy c) → + Expr ctxt a → Expr ctxt b → Expr ctxt c + -- TODO Idris has Lazy on the arms, should work if we explicitly force + If : ∀ n a. {0 ctxt : Vect n Ty} → Expr ctxt TyBool → + (Expr ctxt a) → + (Expr ctxt a) → Expr ctxt a + +infixr 4 _:::_ +data Env : ∀ n. Vect n Ty → U where + Empty : Env VNil + _:::_ : ∀ a n. {0 ctxt : Vect n Ty} → interpTy a → Env ctxt → Env (a :- ctxt) + +lookup : ∀ n t. {0 ctxt : Vect n Ty} {0 i : Fin n} → HasType i ctxt t → Env ctxt → interpTy t +lookup Stop (x ::: xs) = x +lookup () Empty +lookup (Pop k) (x ::: xs) = lookup k xs + +interp : ∀ n t. {0 ctxt : Vect n Ty} → Env ctxt → Expr ctxt t → interpTy t +interp env (Var i) = lookup i env +interp env (Val x) = x +interp env (Lam x) = \y => interp (y ::: env) x +interp env (App x y) = interp env x $ interp env y +interp env (Op f x y) = f (interp env x) (interp env y) +interp env (If x y z) = if interp env x then interp env y + else interp env z + +add : ∀ n. {0 ctxt : Vect n Ty} → Expr ctxt (TyFun TyInt (TyFun TyInt TyInt)) +add = Lam (Lam (Op _+_ (Var Stop) (Var (Pop Stop)))) + +fact : ∀ n. {0 ctxt : Vect n Ty} → Expr ctxt (TyFun TyInt TyInt) +-- TODO the `Bool =?= interpTy ...` is stuck on ?m14 +-- I think we may need to need to delay the constraint until m14 is solved? +-- But I think I have code to do that already +fact = Lam (If (Op {_} {_} {TyBool} _==_ (Var Stop) (Val 0)) + (Val 1) + (Op _*_ (App fact (Op _-_ (Var Stop) (Val 1))) + (Var Stop))) + +-- main : IO Unit +-- main = do putStr "Enter a number: " +-- Right x <- readLine | _ => putStrLn "EOF" +-- printLn (interp Empty fact (stringToInt x))