diff --git a/README.md b/README.md index 5ba4826..0530c98 100644 --- a/README.md +++ b/README.md @@ -2,6 +2,8 @@ Parser is in place. Ditched well-scoped for now. +Fixed more issues, started processing stuff, we need real example code. + Parser: - [x] import statement - [x] def @@ -9,10 +11,10 @@ Parser: - [ ] fix / test parsing and pretty printing - [ ] inductive types - [x] read files +- [ ] process a file - [ ] figure out context representation - Global context? - [ ] type checking / elab -- [ ] process a file -- [ ] +- [ ] error printing - [ ] - [ ] - [ ] symbolic execution diff --git a/eg/ex.newt b/eg/ex.newt index d905683..22e3b93 100644 --- a/eg/ex.newt +++ b/eg/ex.newt @@ -1,24 +1,7 @@ --- comment with double hyphen, takes precedence over operators -module Ex --- imports not implemented yet -import Foo --- inductive data type declaration (not supported in language yet) -data Bool : Type where - True : Bool - False : Bool +-- foo +module Foo --- claim -id : a -> a --- declaration -id = \ a => a * a + 2 * (3 + x) - -blah : Either a a -> a -blah = \ x => let x = 1 in x * x - -bar = foo {x} 1 -blah = \ _ => 1 - - -next : (A : Type) -> (x : A) -> A - -next : {A : Type} -> (x : A) -> A +id : (a : U) -> a -> a +id = \ a => \ x => x +-- if I put foo here, it fails with 'extra toks' +-- errors aren't cutting to the top diff --git a/src/Lib/Check.idr b/src/Lib/Check.idr index 4ee4ddf..31a265f 100644 --- a/src/Lib/Check.idr +++ b/src/Lib/Check.idr @@ -8,31 +8,27 @@ import Data.String import Lib.TT import Syntax - - -- cribbed this, it avoids MonadError String m => everywhere parameters {0 m : Type -> Type} {auto _ : MonadError String m} + export + infer : Context -> Raw -> m (Tm, Val) - infer : {f : Nat} -> Context -> Raw -> m (Tm, Val) - check : {f : Nat} -> Context -> Raw -> Val -> m Tm + export + check : Context -> Raw -> Val -> m Tm check ctx (RLam _ _ _) ty = ?ch_rhs check ctx tm ty = do (tm', ty') <- infer ctx tm - if quote _ ty /= quote _ ty' then + if quote 0 ty /= quote 0 ty' then throwError "type mismatch" else pure tm' - infer ctx (RVar nm) = go 0 ctx.types where go : Nat -> List (String, Val) -> m (Tm, Val) - go i [] = throwError "\{show nm} not in scope" - -- REVIEW Local or Bnd (ezoo does not have both) + go i [] = throwError "\{show nm} not in scope \{show $ map fst ctx.types}" go i ((x, ty) :: xs) = if x == nm then pure $ (Bnd i, ty) else go (i + 1) xs - - -- need environment of name -> type.. infer ctx (RApp t u icit) = do -- icit will be used for insertion, lets get this working first... @@ -40,31 +36,14 @@ parameters {0 m : Type -> Type} {auto _ : MonadError String m} case tty of (VPi str icit' a b) => do u <- check ctx u a - - -- is zero right here? - -- I have ctx.env here and TypeTheory has [] - -- maybe because I'm not substing? - pure (App t u, b 0 (eval ctx.env t)) - _ => throwError "Expected Pi type" - - -- FIXME ctx.env? - -- vtya <- nf ctx.env tma - + pure (App t u, b (eval ctx.env t)) + _ => throwError "Expected Pi type" infer ctx RU = pure (U, VU) -- YOLO infer ctx (RPi nm icit ty ty2) = do ty' <- check ctx ty VU let vty' := eval ctx.env ty' - -- gallais and the source paper have subst here. They're using Tm rather - -- than raw. Lets look at the zoo. - -- maybe run through zoo2 well typed... - -- it just binds vty' into the environment and evaluates - -- Kovacs is sticking the type vty' and the value Var l into the context - -- and letting the Ix pick up the Var l from the context - -- gallais/paper are subst the Var l into the Tm. - -- yaffle just pushes to the environment, but it's a list of binders - -- so types, names, no values - ty2' <- check (extend ctx vty') ty2 VU let nm := fromMaybe "_" nm + ty2' <- check (extend ctx nm vty') ty2 VU pure (Pi nm icit ty' ty2', VU) infer ctx (RLet str tm tm1 tm2) = ?rhs_5 infer ctx (RSrcPos x tm) = infer ({pos := x} ctx) tm @@ -76,11 +55,13 @@ parameters {0 m : Type -> Type} {auto _ : MonadError String m} infer ctx (RLam str icit tm) = throwError "can't infer lambda" - infer ctx _ = ?later + infer ctx _ = throwError "TODO" + -- I don't have types for these yet... -- infer ctx (RLit (LString str)) = ?rhs_10 -- infer ctx (RLit (LInt i)) = ?rhs_11 -- infer ctx (RLit (LBool x)) = ?rhs_12 - -- infer ctx RHole = ?todo_meta2 - -- infer ctx (RParseError str) = ?todo_insert_meta -- infer ctx (RCase tm xs) = ?rhs_9 + -- infer ctx RHole = ?todo_meta2 + -- The idea here is to insert a hole for a parse error + -- infer ctx (RParseError str) = ?todo_insert_meta diff --git a/src/Lib/Parser.idr b/src/Lib/Parser.idr index 608b4ba..eba762d 100644 --- a/src/Lib/Parser.idr +++ b/src/Lib/Parser.idr @@ -60,9 +60,9 @@ withPos p = RSrcPos <$> getPos <*> p -- the inside of Raw atom : Parser Raw -atom = withPos ( RVar <$> ident +atom = withPos (RU <$ keyword "U" + <|> RVar <$> ident <|> lit - <|> RU <$ keyword "U" <|> RHole <$ keyword "_") <|> parens term diff --git a/src/Lib/Parser/Impl.idr b/src/Lib/Parser/Impl.idr index f37b29e..346fa39 100644 --- a/src/Lib/Parser/Impl.idr +++ b/src/Lib/Parser/Impl.idr @@ -1,6 +1,8 @@ module Lib.Parser.Impl import Lib.Token +import Data.String +import Data.Nat public export TokenList : Type @@ -16,9 +18,21 @@ emptyPos = (0,0) -- Error of a parse public export -data Error = E String +data Error = E SourcePos String %name Error err +public export +showError : String -> Error -> String +showError src (E (line, col) msg) = "Err at \{show (line,col)} \{msg}\n" ++ go 0 (lines src) + where + go : Int -> List String -> String + go l [] = "" + go l (x :: xs) = + if l == line then + "\{x}\n\{replicate (cast col) ' '}^\n" + else if line - 3 < l then x ++ "\n" ++ go (l + 1) xs + else "" + -- Result of a parse public export data Result : Type -> Type where @@ -45,22 +59,26 @@ export runP : Parser a -> TokenList -> Bool -> SourcePos -> Result a runP (P f) = f +error : TokenList -> String -> Error +error [] msg = E emptyPos msg +error ((MkBounded val isIrrelevant (MkBounds line col _ _)) :: _) msg = E (line, col) msg + export -parse : Parser a -> TokenList -> Either String a +parse : Parser a -> TokenList -> Either Error a parse pa toks = case runP pa toks False emptyPos of - Fail fatal (E msg) toks com => Left "error: \{msg} next at: \{show toks}" + Fail fatal err toks com => Left err OK a [] _ => Right a - OK a ts _ => Left "Extra toks \{show ts}" + OK a ts _ => Left (error toks "Extra toks") -- I think I want to drop the typeclasses for v1 export fail : String -> Parser a -fail msg = P $ \toks,com,col => Fail False (E msg) toks com +fail msg = P $ \toks,com,col => Fail False (error toks msg) toks com export fatal : String -> Parser a -fatal msg = P $ \toks,com,col => Fail False (E msg) toks com +fatal msg = P $ \toks,com,col => Fail False (error toks msg) toks com -- mustWork / commit copied from Idris, but I may switch to the parsec consumption thing. export @@ -106,8 +124,8 @@ Monad Parser where pred : (BTok -> Bool) -> String -> Parser String pred f msg = P $ \toks,com,col => case toks of - (t :: ts) => if f t then OK (value t) ts com else Fail False (E "\{msg} vt:\{value t}") toks com - [] => Fail False (E "eof") toks com + (t :: ts) => if f t then OK (value t) ts com else Fail False (error toks "\{msg} vt:\{value t}") toks com + [] => Fail False (error toks "eof") toks com export commit : Parser () @@ -133,7 +151,7 @@ mutual export getPos : Parser SourcePos getPos = P $ \toks,com, (l,c) => case toks of - [] => Fail False (E "End of file") toks com -- OK emptyPos toks com + [] => Fail False (error toks "End of file") toks com -- OK emptyPos toks com (t :: ts) => OK (start t) toks com ||| Start an indented block and run parser in it @@ -154,8 +172,8 @@ sameLevel (P p) = P $ \toks,com,(l,c) => case toks of (t :: _) => let (tl,tc) = start t in if tc == c then p toks com (tl, c) - else if c < tc then Fail False (E "unexpected indent") toks com - else Fail False (E "unexpected indent") toks com + else if c < tc then Fail False (error toks "unexpected indent") toks com + else Fail False (error toks "unexpected indent") toks com export someSame : Parser a -> Parser (List a) @@ -169,7 +187,7 @@ indented (P p) = P $ \toks,com,(l,c) => case toks of (t::_) => let (tl,tc) = start t in if tc > c || tl == l then p toks com (l,c) - else Fail False (E "unexpected outdent") toks com + else Fail False (error toks "unexpected outdent") toks com export token' : Kind -> Parser String diff --git a/src/Lib/Prettier.idr b/src/Lib/Prettier.idr index 592d0bc..8f8ca1e 100644 --- a/src/Lib/Prettier.idr +++ b/src/Lib/Prettier.idr @@ -1,11 +1,10 @@ +||| A prettier printer, Philip Wadler +||| https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf module Lib.Prettier import Data.String import Data.Nat --- A prettier printer, Philip Wadler --- https://homepages.inf.ed.ac.uk/wadler/papers/prettier/prettier.pdf - ||| `Doc` is a pretty printing document. Constructors are private, use ||| methods below. `Alt` in particular has some invariants on it, see paper ||| for details. (Something along the lines of "the first line of left is not @@ -13,9 +12,9 @@ import Data.Nat export data Doc = Empty | Line | Text String | Nest Nat Doc | Seq Doc Doc | Alt Doc Doc +||| `DOC` is an intermediate form used during layout/rendering data DOC = EMPTY | TEXT String DOC | LINE Nat DOC - flatten : Doc -> Doc flatten Empty = Empty flatten (Seq x y) = Seq (flatten x) (flatten y) @@ -60,7 +59,7 @@ best w k x = be w k [(0,x)] -- Public interface export -pretty : Nat -> Doc-> String +pretty : Nat -> Doc -> String pretty w x = layout (best w 0 x) public export diff --git a/src/Lib/TT.idr b/src/Lib/TT.idr index 498d3d2..8a93c30 100644 --- a/src/Lib/TT.idr +++ b/src/Lib/TT.idr @@ -7,6 +7,7 @@ module Lib.TT -- For SourcePos import Lib.Parser.Impl +import Control.Monad.Error.Interface import Data.Fin import Data.List @@ -81,17 +82,12 @@ data Val : Type where VPi : Name -> Icit -> Lazy Val -> Closure -> Val VU : Val -||| LocalEnv free vars -public export -LocalEnv : Type -LocalEnv = List Val - public export Env : Type Env = List Val export -eval : LocalEnv -> Env -> Tm -> Val +eval : Env -> Tm -> Val export vapp : Val -> Val -> Val @@ -103,15 +99,16 @@ bind v env = v :: env -- so here we have LocalEnv free vars in Yaffle -eval locs env (Ref x) = VRef x -eval locs env (App t u) = vapp (eval locs env t) (eval locs env u) -eval locs env U = VU +eval env (Ref x) = VRef x +eval env (App t u) = vapp (eval env t) (eval env u) +eval env U = VU -- yaffle breaks out binder -eval locs env (Lam x icit t) = VLam x icit (\u => eval (u :: locs) env t) -eval locs env (Pi x icit a b) = VPi x icit (eval locs env a) (\u => eval (u :: locs) env b) +eval env (Lam x icit t) = VLam x icit (\u => eval (u :: env) t) +eval env (Pi x icit a b) = VPi x icit (eval env a) (\u => eval (u :: env) b) -- This one we need to make -eval locs env (Let x icit ty t u) = eval (eval locs env t :: locs) env u -eval locs env (Bnd i) = let Just rval = getAt i env | _ => ?out_of_index in rval +eval env (Let x icit ty t u) = eval (eval env t :: env) u +eval env (Bnd i) = let Just rval = getAt i env | _ => ?out_of_index + in rval vfresh : Nat -> Val vfresh l = VVar l @@ -129,7 +126,7 @@ quote _ (VRef n) = Ref n -- vars -> vars -> vars in yaffle export nf : {n : Nat} -> Env -> Tm -> Tm -nf env t = quote n (eval [] env t) +nf env t = quote n (eval env t) public export conv : (lvl : Nat) -> Val -> Val -> Bool @@ -150,62 +147,29 @@ record Context where -- lvl = length types pos : SourcePos -- the last SourcePos that we saw + + +export +empty : Context +empty = MkCtx [] [] (0,0) + +export partial +Show Context where + show ctx = "Context \{show $ map fst $ ctx.types}" + -- Kovacs Small-TT has locals and globals, lets do that. ||| add a binding to environment -extend : { n : Nat} -> Context -> String -> Val -> Context +export +extend : Context -> String -> Val -> Context extend (MkCtx env types pos) name ty = MkCtx (VVar (length env) :: env) ((name, ty) :: types) pos - --- weirich has 'hints' to store the claims before the def is seen/checked --- saying it is unsafe. afterwards they are mixed into the context. --- idris essentially leaves holes, filled in later, for undefined claims --- Is it ok to leaving them in there (if they pass checkType) as long as --- we don't register the def if it fails checking? - --- shoot, I have another context in Check.idr - - --- -- public export --- record Ctx (n : Nat) where --- constructor MkCtx --- env : Env k n -- for eval --- types : Types n -- name lookup, prettyprint --- bds : Vect n BD -- meta creation --- lvl : Nat -- This is n, do we need it? --- -- Kovacs and Weirich use a position node, Idris has FC --- pos : SourcePos - --- %name Ctx ctx - --- public export --- emptyCtx : Ctx Z --- emptyCtx = MkCtx {k=0} [] [] [] 0 (0,0) - --- find out how pi-forall treats binders --- Vars are unbound TName - --- ezoo --- Tm has Ix --- Val has Lvl - --- by the time we hit ezoo 5/6, there is a Map string -> (Lvl, Type) for name lookup. - --- smalltt - - --- idris - - - --- public export --- bindCtx : Name -> Lazy (Val (zz + n)) -> Ctx n -> Ctx (S n) --- bindCtx x a (MkCtx env types bds l pos) = --- MkCtx (VVar l :: env) ((x,a) :: map (map thinVal) types) (Bound :: bds) (l+1) pos - --- public export --- define : Name -> Val -> Lazy (Val) -> Ctx n -> Ctx (S n) --- define x v ty (MkCtx env types bds l pos) = --- MkCtx (v :: env) ((x,ty) :: map (map thinVal) types) (Defined :: bds) (l + 1) pos +lookup : {0 m : Type -> Type} -> {auto _ : MonadError String m} -> + Context -> String -> m Val +lookup ctx nm = go ctx.types + where + go : List (String,Val) -> m Val + go [] = throwError "Name \{nm} not in scope" + go ((n, ty) :: xs) = if n == nm then pure ty else go xs diff --git a/src/Lib/Token.idr b/src/Lib/Token.idr index 4687d9c..c853652 100644 --- a/src/Lib/Token.idr +++ b/src/Lib/Token.idr @@ -1,5 +1,7 @@ module Lib.Token +-- TODO replace this with own lexer + import public Text.Lexer public export diff --git a/src/Main.idr b/src/Main.idr index 015c25f..2098bf7 100644 --- a/src/Main.idr +++ b/src/Main.idr @@ -1,98 +1,70 @@ module Main +import Control.App import Data.String -import Lib.Tokenizer --- import Lib.Layout -import Lib.Token -import Lib.Parser.Impl +import Control.Monad.Error.Interface +import Control.Monad.Error.Either +import Control.Monad.State +import Lib.Check import Lib.Parser +import Lib.Parser.Impl +import Lib.Prettier +import Lib.Token +import Lib.Tokenizer +import Lib.TT +import Syntax import Syntax import System -import System.File import System.Directory -import Control.App -import Syntax -import Lib.Prettier +import System.File {- -Ok, dropped indexes. +Currently working through checking of decl / def -- The "sample" file I wrote looks like nonsense to test the parser. I'll need something that typechecks to get this going. -- I want end to end before adding implicits, so something explicit. -- maybe some #check / #eval pragmas? +Running check is awkward. I need a monad stack. +Main2.idr has an older App attempt without the code below. Retrofit. +-} -But checking that claims and functions are correct is a very good start. Maybe spent too much time on making a full parser -rather than piecing together end to end. (And way too much time on those indices.) +M = MonadError (String) (StateT Context IO) +processDecl : Context -> Decl -> IO Context +processDecl ctx (TypeSig nm tm)= do + putStrLn "TypeSig \{nm} \{show tm}" + Right ty <- pure $ the (Either String Tm) (check ctx tm VU) + | Left err => printLn err >> pure ctx + let vty = eval ctx.env ty + pure $ extend ctx nm vty +processDecl ctx (Def nm raw) = do + putStrLn "def \{show nm}" + let Just ty = lookup nm ctx.types + | Nothing => printLn "skip def \{nm} without Decl" >> pure ctx + putStrLn "check \{nm} \{show raw} at [no printer for Tm/Val]" + Right ty <- pure $ the (Either String Tm) (check ctx raw ty) + | Left err => printLn err >> pure ctx + pure ctx +processDecl ctx decl = putStrLn "skip \{show decl}" >> pure ctx - - -} - - --- [ ] Put stuff in attic --- [ ] Error printing --- [ ] Review surface syntax --- [x] Prettier printer --- [ ] First pass at typecheck (test cases are just parsing) --- Just do it in zoo order - - --- showPError : String -> - -test : Show a => Parser a -> String -> IO () -test pa src = do - _ <- putStrLn "--" - _ <- putStrLn $ src - let toks = tokenise src - putStrLn "- Toks" - printLn $ toks - putStrLn "- Parse" - let Right res = parse pa toks - | Left y => putStrLn "Error: \{y}" - printLn $ res - - -- let toks2 = layout toks - -- printLn $ map value toks2 - --- gotta fix up error messages. Show it with some source - -testFile : String -> IO () -testFile fn = do - putStrLn ("***" ++ fn) +processFile : String -> IO () +processFile fn = do + putStrLn "*** Process \{fn}" Right src <- readFile $ "eg/" ++ fn | Left err => printLn err let toks = tokenise src let Right res = parse parseMod toks - | Left y => putStrLn "Error: \{y}" - + | Left y => putStrLn (showError src y) putStrLn $ pretty 80 $ pretty res - -olderTests : IO () -olderTests = do - test letExpr "let x = 1\n y = 2\n in x + y" - test term "let x = 1 in x + 2" - printLn "BREAK" - test term "case x of\n True => something\n False => let\n x = 1\n y = 2\n in x + y" - test term "x + y * z + w" - test term "y * z + w" - test term "x -> y -> z" - test term "x y z" - test parseMod "module Foo\nfoo : Int -> Int\nfoo = \\ x . x" - test lamExpr "\\ x . x" - test parseMod "module Foo\nimport Foo.Bar\nfoo = 1\n" - test parseDef "foo = 1" - test parseSig "foo : Bar -> Int" - test parseMod "module Test\nid : a -> a\nid = \\ x => x\n" - -foo : Maybe Int -> Int -foo Nothing = ?foo_rhs_0 -foo (Just x) = ?foo_rhs_1 + printLn "process Decls" + ctx <- foldlM processDecl empty res.decls + putStrLn "done \{show ctx}" main : IO () main = do + args <- getArgs + putStrLn "Args: \{show args}" Right files <- listDir "eg" | Left err => printLn err - traverse_ testFile (filter (".newt" `isSuffixOf`) files) + -- TODO use args + traverse_ processFile (filter (".newt" `isSuffixOf`) files) diff --git a/src/Syntax.idr b/src/Syntax.idr index 22eff33..8101df1 100644 --- a/src/Syntax.idr +++ b/src/Syntax.idr @@ -6,6 +6,7 @@ import Lib.Parser.Impl import Lib.Prettier import Lib.TT +public export data Raw : Type where public export @@ -28,7 +29,6 @@ data CaseAlt = MkAlt Pattern Raw -- TODO redo this with names for documentation -public export data Raw = RVar Name | RLam String Icit Raw @@ -48,6 +48,7 @@ data Raw -- derive some stuff - I'd like json, eq, show, ... +public export data Decl : Type where Telescope: Type @@ -55,7 +56,6 @@ Telescope = List Decl -- pi-forall, always typeSig? data ConstrDef = MkCDef Name Telescope -public export data Decl = TypeSig Name Raw | Def Name Raw