dunham/newt
1
0
Fork 0
Code Issues Pull Requests Actions 1 Packages Projects Releases Wiki Activity

Lib/TT.idr is well scoped

Browse Source
This commit is contained in:
Steve Dunham
2023-07-13 20:06:03 -07:00
parent ed3ee96df9
commit 59f726ab96
6 changed files with 203 additions and 90 deletions
Download Patch File Download Diff File Expand all files Collapse all files

17
README.md
View File

@@ -1,14 +1,23 @@
Parser is in place.
I think we almost have enough of a parser to take another step.
Currently trying to make TT well-scoped, considering well-named..
Need to update todos below.
Should I use well-scoped indices or well-scoped names...
Parser:
- [x] import statement
- [x] def
- [x] simple decl
- [ ] type definition
- [ ] read files
- [ ] write tests
- [x] read files
- [ ] type checking / elab
- [ ]
- [ ]
- [ ]
- [ ] symbolic execution
- [ ] compilation
- [ ] write tests

BIN
papers/prettier.pdf Normal file
View File

Binary file not shown.

9
src/Lib/Parser.idr
View File

@@ -112,7 +112,8 @@ letExpr = do
alts <- startBlock $ someSame $ letAssign
keyword' "in"
scope <- term
pure $ RLet alts scope
pure $ foldl (\ acc, (n,v) => RLet n RHole v acc) scope alts
where
letAssign : Parser (Name,Raw)
letAssign = do
@@ -178,7 +179,7 @@ expBinder = do
sym ")"
sym "->"
scope <- typeExpr
pure $ RPi name Explicit ty scope
pure $ RPi (Just name) Explicit ty scope
impBinder : Parser Raw
impBinder = do
@@ -189,7 +190,7 @@ impBinder = do
sym "}"
sym "->"
scope <- typeExpr
pure $ RPi name Implicit ty scope
pure $ RPi (Just name) Implicit ty scope
-- something binder looking
-- todo sepby space or whatever
@@ -205,7 +206,7 @@ typeExpr = binder
case scope of
Nothing => pure exp
-- consider Maybe String to represent missing
(Just scope) => pure $ RPi "_" Explicit exp scope
(Just scope) => pure $ RPi Nothing Explicit exp scope
-- And top level stuff

185
src/Lib/TT.idr
View File

@@ -1,111 +1,150 @@
module Lib.TT
-- For SourcePos
import Lib.Parser.Impl
import Data.Fin
import Data.Vect
public export
Name : Type
Name = String
-- Trying to do well-scoped here, so the indices are proven.
export
data Icit = Implicit | Explicit
-- Sorta cribbed from Kovacs
Ty : Type
-- Idris and Kovacs have Icit at this level.
public export
data Tm
= Local Nat -- IsVar
| Ref String
| Lam Name Icit Tm
| App Tm Tm
| U
| Pi Name Ty Ty
| Let Name Ty Tm Tm
Ty = Tm
%name Icit icit
public export
data Closure : Type
VTy : Type
data Tm : Nat -> Nat -> Type where
Local : Fin k -> Tm k n
Bnd : Fin n -> Tm k n
Ref : String -> Tm k n
Lam : Name -> Icit -> Tm k (S n) -> Tm k n
App : Tm k n -> Tm k n -> Tm k n
U : Tm k n
Pi : Name -> Icit -> Tm k n -> Tm k (S n) -> Tm k n
Let : Name -> Icit -> Tm k n -> Tm k n -> Tm k (S n) -> Tm k n
-- Closure unpacked in the original
public export
data Val
= VVar Nat -- level
| VApp Val (Lazy Val)
| VLam Name Icit Closure
| VPi Name (Lazy VTy) Closure
| VU
%name Tm t, u, v
VTy = Val
-- public export
-- data Closure : Nat -> Type
data Val : Nat -> Type
0 Closure : Nat -> Type
-- IS/TypeTheory.idr is calling this a Kripke function space
-- Yaffle, IS/TypeTheory use a function here.
-- Kovacs, Idris use Env and Tm
Closure n = (l : Nat) -> Val (l + n) -> Val (l + n)
public export
Env : Type
Env = List Val
data Val : Nat -> Type where
-- This will be local / flex with spine.
VVar : Fin n -> Val n
VRef : String -> Val n
VApp : Val n -> Lazy (Val n) -> Val n
VLam : Name -> Icit -> Closure n -> Val n
VPi : Name -> Icit -> Lazy (Val n) -> Closure n -> Val n
VU : Val n
--
||| Env k n holds the evaluation environment.
||| k is the number of levels and n is the size
||| of the environment.
public export
Env : Nat -> Nat -> Type
Env k n = Vect n (Val k)
lvl2Ix : Nat -> Nat -> Nat
export
eval : Env k n -> Tm k n -> Val k
data Closure : Type where
MkClosure : Env -> Tm -> Closure
vapp : Val k -> Val k -> Val k
vapp (VLam _ icit t) u = t 0 u
vapp t u = VApp t u
infixl 8 $$
-- weakenEnv : (l : Nat) -> Env k n -> Env (l + k) n
eval : Env -> Tm -> Val
weakenVal : {e : Nat} -> Val k -> Val (e + k)
weakenVal (VVar x) = VVar (shift _ x)
weakenVal (VRef str) = VRef str
weakenVal (VApp x y) = VApp (weakenVal x) (weakenVal y)
weakenVal (VLam str icit f) = VLam str icit
(\g, v => rewrite plusAssociative g e k in f (g + e) (rewrite sym $ plusAssociative g e k in v))
weakenVal (VPi str icit x f) = VPi str icit (weakenVal {e} x)
(\g, v => rewrite plusAssociative g e k in f (g + e) (rewrite sym $ plusAssociative g e k in v))
weakenVal VU = VU
($$) : Closure -> Lazy Val -> Val
(MkClosure env t) $$ u = eval (u :: env) t
bind : (e : Nat) -> Val (plus e k) -> Env k n -> Env (e + k) (S n)
bind e v env = v :: map weakenVal env
eval env (Local k) = ?hole
eval env (Ref x) = ?hole_1
eval env (Lam x _ t) = ?hole_2
eval env (App t u) = case (eval env t, eval env u) of
(VLam _ icit t, u) => t $$ u
(t, u) => VApp t u
-- is this weaken or thin?
weaken : {e : Nat} -> Tm k (S n) -> Tm (plus e k) (S n)
weaken (Local x) = Local (shift _ x)
weaken (Bnd x) = Bnd x
weaken (Ref str) = Ref str
weaken (Lam str x t) = Lam str x (weaken t)
weaken (App t u) = App (weaken t) (weaken u)
weaken U = U
weaken (Pi str x t u) = Pi str x (weaken t) (weaken u)
weaken (Let str x t u v) = Let str x (weaken t) (weaken u) (weaken v)
eval env (Local x) = VVar x -- this is a hole in intrinsic, vfree x in the other
eval env (Ref x) = VRef x
eval env (Bnd n) = index n env
eval env (Lam x icit t) = VLam x icit (\e, u => eval (bind e u env) (weaken t))-- (MkClosure env t)
eval env (App t u) = vapp (eval env t) (eval env u)
eval env U = VU
eval env (Pi x a b) = VPi x (eval env a) (MkClosure env b)
eval env (Let x _ t u) = eval (eval env t :: env) u
eval env (Pi x icit a b) = VPi x icit (eval env a) (\e, u => eval (bind e u env) (weaken b))
-- This one we need to make
eval env (Let x icit ty t u) = eval (eval env t :: env) u
quote : Nat -> Val -> Tm
quote l (VVar k) = Local (lvl2Ix l k)
vfresh : (l : Nat) -> Val (S l)
vfresh l = VVar last
quote : (k : Nat) -> Val k -> Tm 0 k
quote l (VVar k) = Bnd (complement k) -- level to index
quote l (VApp t u) = App (quote l t) (quote l u)
quote l (VLam x icit t) = Lam x icit (quote (l + 1) (t $$ VVar l))
quote l (VPi x a b) = Pi x (quote l a) (quote (l+1) (b $$ VVar l))
quote l VU = ?rhs_4
-- so this one is calling the kripke on [x] and a fresh var
quote l (VLam x icit t) = Lam x icit (quote (S l) (t 1 (vfresh l)))
quote l (VPi x icit a b) = Pi x icit (quote l a) (quote (S l) (b 1 $ vfresh l))
quote l VU = U
quote _ (VRef n) = Ref n
nf : Env -> Tm -> Tm
nf env t = quote (length env) (eval env t)
---
public export
conv : (lvl : Nat) -> Val -> Val -> Bool
--
public export
Types : Type
Types = List (Name, Lazy VTy)
nf : {n : Nat} -> Env 0 n -> Tm 0 n -> Tm 0 0
nf env t = quote 0 (eval env t)
public export
record Ctx where
conv : (lvl : Nat) -> Val n -> Val n -> Bool
data BD = Bound | Defined
public export
Types : Nat -> Type
Types n = Vect n (Name, Lazy (Val n))
public export
record Ctx (n : Nat) where
constructor MkCtx
env : Env
types : Types
lvl : Nat
-- For now, we're following Kovacs and using a node for
-- source position. Might switch to FC at some point?
env : Env k n -- for eval
types : Types n -- name lookup, pp
bds : Vect n BD -- meta creation
lvl : Nat -- This is n, do we need it?
-- Kovacs and Weirich use a position node
pos : SourcePos
public export
emptyCtx : Ctx
emptyCtx = MkCtx [] [] 0 (0,0)
%name Ctx ctx
public export
bind : Name -> Lazy VTy -> Ctx -> Ctx
bind x a (MkCtx env types l pos) =
MkCtx (VVar l :: env) ((x,a) :: types) (l+1) pos
emptyCtx : Ctx Z
emptyCtx = MkCtx {k=0} [] [] [] 0 (0,0)
-- public export
-- bind : Name -> Lazy (Val (k + n)) -> Ctx n -> Ctx (S n)
-- bind x a (MkCtx env types bds l pos) =
-- MkCtx (VVar l :: env) ((x,a) :: types) (Bound :: bds) (l+1) pos
-- public export
-- define : Name -> Val n -> Lazy (Val n) -> Ctx n -> Ctx (S n)
-- define x v ty (MkCtx env types bds l pos) =
-- MkCtx (v :: env) ((x,ty) :: types) (Defined :: bds) (l + 1) pos

16
src/Main.idr
View File

@@ -11,6 +11,8 @@ import System
import System.File
import System.Directory
import Control.App
import Syntax
import Lib.Prettier
-- Put stuff in attic
-- Error printing
@@ -30,8 +32,10 @@ test pa src = do
putStrLn "- Toks"
printLn $ toks
putStrLn "- Parse"
let res = parse pa toks
printLn res
let Right res = parse pa toks
| Left y => putStrLn "Error: \{y}"
printLn $ res
-- let toks2 = layout toks
-- printLn $ map value toks2
@@ -40,9 +44,13 @@ test pa src = do
testFile : String -> IO ()
testFile fn = do
putStrLn ("***" ++ fn)
Right text <- readFile $ "eg/" ++ fn
Right src <- readFile $ "eg/" ++ fn
| Left err => printLn err
test parseMod text
let toks = tokenise src
let Right res = parse parseMod toks
| Left y => putStrLn "Error: \{y}"
putStrLn $ pretty 80 $ pretty res
olderTests : IO ()
olderTests = do

66
src/Syntax.idr
View File

@@ -1,7 +1,9 @@
module Syntax
import Data.String
import Data.Maybe
import Lib.Parser.Impl
import Lib.Prettier
Name = String
@@ -14,7 +16,9 @@ public export
data RigCount = Rig0 | RigW
-- I think I got Eq from pi-forall, it uses it for equality args (which are kinda like Prop/Rig0?)
public export
data Plicity = Implicit | Explicit | Eq
data Plicity = Implicit | Explicit -- | Eq
%name Plicity icit
public export
data Pattern
@@ -29,14 +33,16 @@ data Pattern
public export
data CaseAlt = MkAlt Pattern Raw
-- TODO redo this with names for documentation
public export
data Raw
= RVar Name
| RLam String Plicity Raw
| RApp Raw Raw Plicity
| RU
| RPi Name Plicity Raw Raw
| RLet (List (Name, Raw)) Raw
| RPi (Maybe Name) Plicity Raw Raw
| RLet Name Raw Raw Raw
| RSrcPos SourcePos Raw
| RAnn Raw Raw
@@ -45,6 +51,8 @@ data Raw
| RHole
| RParseError String
%name Raw tm
-- derive some stuff - I'd like json, eq, show, ...
data Decl : Type where
@@ -118,7 +126,7 @@ Show CaseAlt where
Show Plicity where
show Implicit = "Implicit"
show Explicit = "Explicit"
show Eq = "Eq"
-- show Eq = "Eq"
covering
Show Raw where
@@ -126,7 +134,7 @@ Show Raw where
show (RVar name) = foo ["RVar", show name]
show (RAnn t ty) = foo [ "RAnn", show t, show ty]
show (RLit x) = foo [ "RLit", show x]
show (RLet alts y) = foo [ "Let", show alts, show y]
show (RLet x ty v scope) = foo [ "Let", show x, " : ", show ty, " = ", show v, " in ", show scope]
show (RPi str x y z) = foo [ "Pi", show str, show x, show y, show z]
show (RApp x y z) = foo [ "App", show x, show y, show z]
show (RLam x i y) = foo [ "Lam", show x, show i, show y]
@@ -135,4 +143,52 @@ Show Raw where
show RU = "U"
show (RSrcPos pos tm) = show tm
export
interface Pretty a where
pretty : a -> Doc
export
Pretty Raw where
pretty = asDoc 0
where
wrap : Plicity -> Doc -> Doc
wrap Implicit x = x
wrap Explicit x = text "{" ++ x ++ text "}"
par : Nat -> Nat -> Doc -> Doc
par p p' d = if p' < p then text "(" ++ d ++ text ")" else d
asDoc : Nat -> Raw -> Doc
asDoc p (RVar str) = text str
asDoc p (RLam str icit x) = par p 0 $ text "\\" ++ wrap icit (text str) <+> text "=>" <+> asDoc 0 x
-- This needs precedence and operators...
asDoc p (RApp x y Explicit) = par p 2 $ asDoc 2 x <+> asDoc 3 y
asDoc p (RApp x y Implicit) = par p 2 $ asDoc 2 x <+> text "{" ++ asDoc 0 y ++ text "}"
asDoc p RU = text "U"
asDoc p (RPi Nothing Implicit ty scope) = par p 1 $ asDoc p ty <+> text "->" <+/> asDoc p scope
asDoc p (RPi (Just x) Implicit ty scope) =
par p 1 $ text "(" <+> text x <+> text ":" <+> asDoc p ty <+> text ")" <+> text "->" <+/> asDoc p scope
asDoc p (RPi nm Explicit ty scope) =
par p 1 $ text "{" <+> text (fromMaybe "_" nm) <+> text ":" <+> asDoc p ty <+> text "}" <+> text "->" <+/> asDoc 1 scope
asDoc p (RLet x v ty scope) =
par p 0 $ text "let" <+> text x <+> text ":" <+> asDoc p ty
<+> text "=" <+> asDoc p v
<+/> text "in" <+> asDoc p scope
asDoc p (RSrcPos x y) = asDoc p y
-- does this exist?
asDoc p (RAnn x y) = text "TODO - RAnn"
asDoc p (RLit x) = text (show x)
asDoc p (RCase x xs) = text "TODO - RCase" --?asDoc p_rhs_9
asDoc p RHole = text "_"
asDoc p (RParseError str) = text "PraseError \{str}"
export
Pretty Module where
pretty (MkModule name imports decls) =
text "module" <+> text name </> stack (map doDecl decls)
where
doDecl : Decl -> Doc
doDecl (TypeSig nm ty) = text nm <+> text ":" <+> nest 2 (pretty ty)
doDecl (Def nm tm) = text nm <+> text "=" <+> nest 2 (pretty tm)
doDecl (DImport nm) = text "import" <+> text nm ++ line
doDecl (Data str x xs) = text "TODO data"