rachel
/
pi
1
0
Fork 0
Code Issues Pull Requests Projects Releases Wiki Activity

definition system, repl

master
Rachel Lambda Samuelsson 2022-07-26 23:07:13 +02:00
parent 79ad67ffec
commit c7fb1d5cd3
14 changed files with 384 additions and 500 deletions
Show Stats Download Patch File Download Diff File Expand all files Collapse all files

6
README.md
View File

@ -22,12 +22,12 @@ A dependently typed system
# TODO
* Repl
* Defs
* Performence optimisation
* Parsing !!! (this is like 90% of the time currently lmao)
* Memoize normalisation and conversion somehow?
* Repl
* Universes
* Implicit arguments

2
makefile
View File

@ -1,6 +1,8 @@
.PHONY: all run
all:
idris2 --build pi.ipkg
clean:
idris2 --clean pi.ipkg
run:
./build/exec/pi
test:

1
pi.ipkg
View File

@ -5,7 +5,6 @@ modules = Core.Check
, Core.Misc
, Core.Normalize
, Core.Term
, Core.Tests
, Core.Value
, Parser.Parse

32
src/Core/Check.idr
View File

@ -5,6 +5,8 @@ import Control.Monad.Either
import Control.Monad.Identity
import Data.Vect
import Data.Fin
import Data.IOArray
import Data.IORef
import Core.Term
import Core.Value
@ -12,21 +14,27 @@ import Core.Normalize
import Core.Misc
import Core.Convert
%default total
-- extend environment, used to ensure environment is always in normal form
extV : Ctx n -> Value -> PI (Ctx (S n))
extV : {auto deftrs : RefA DTR Value}
-> {auto frst : Ref NST Nat}
-> Ctx n -> Value -> PI (Ctx (S n))
extV ctx val = whnf val >>= pure . (`Data.Vect.(::)` ctx)
-- to extend, closure env, term
extT : Ctx m -> Ctx n -> Term n -> PI (Ctx (S m))
extT : {auto deftrs : RefA DTR Value}
-> {auto frst : Ref NST Nat}
-> Ctx m -> Ctx n -> Term n -> PI (Ctx (S m))
extT ctx env = extV ctx . VClos env
mutual
public export
-- terms types expected term
check : Ctx n -> Ctx n -> Value -> Term n -> PI Bool
check : {auto deftrs : RefA DTR Value}
-> {auto deftys : RefA DTY Value}
-> {auto frst : Ref NST Nat}
-> Ctx n -> Ctx n -> Value -> Term n -> PI Bool
check trs tys xpt' tr = do
xpt <- whnf xpt'
case tr of
@ -49,7 +57,11 @@ mutual
_ => convert xpt =<< infer trs tys tr
-- terms types term
infer : Ctx n -> Ctx n -> Term n -> PI Value
public export
infer : {auto deftrs : RefA DTR Value}
-> {auto deftys : RefA DTY Value}
-> {auto frst : Ref NST Nat}
-> Ctx n -> Ctx n -> Term n -> PI Value
infer trs tys TType = pure VType
infer trs tys TTop = pure VType
infer trs tys TBot = pure VType
@ -57,6 +69,11 @@ mutual
infer trs tys TStar = pure VTop
infer trs tys TZero = pure VNat
infer trs tys (TVar i) = pure (index i tys)
infer trs tys (TDef i) = do
res <- getArr DTY i
case res of
Just x => pure x
Nothing => oops "TDef type lookup"
infer trs tys (TApp f x) = infer trs tys f >>= whnf >>=
\case
VClos env (TPi a b) => do
@ -141,6 +158,9 @@ mutual
infer trs tys x = oops ("cannot infer type " ++ show x)
public export
typecheck : Term 0 -> Term 0 -> Either String (Bool, List String)
typecheck : {auto deftrs : RefA DTR Value}
-> {auto deftys : RefA DTY Value}
-> {auto frst : Ref NST Nat}
-> Term 0 -> Term 0 -> IO (Either String Bool)
typecheck tr ty = resolve $ (&&) <$> check [] [] VType ty
<*> delay <$> check [] [] (VClos [] ty) tr

24
src/Core/Convert.idr
View File

@ -11,18 +11,19 @@ import Control.Monad.Either
import Data.Nat
import Data.Vect
import Data.IOArray
import Data.IORef
%default total
public export
convert : Value -> Value -> PI Bool
convert : {auto deftrs : RefA DTR Value}
-> {auto frst : Ref NST Nat}
-> Value -> Value -> PI Bool
convert u1 u2 = do
u1' <- whnf u1
u2' <- whnf u2
logS ("checking equality of terms '" ++ show u1 ++ "' and '" ++ show u2 ++ "'.")
logS ("with value representations '" ++ show u1' ++ "' and '" ++ show u2' ++ "'.")
assert_total $ -- :(
case (u1', u2') of
assert_total $ case (u1', u2') of
(VType, VType) => pure True
(VTop, VTop) => pure True
(VStar, VStar) => pure True
@ -39,8 +40,8 @@ convert u1 u2 = do
(VClos env1 (TPi a1 b1), VClos env2 (TPi a2 b2)) => do
v <- VGen <$> fresh
guardS (show a1 ++ " | " ++ show a2) =<< convert (VClos env1 a1) (VClos env2 a2)
convert (VClos (v :: env1) b1) (VClos (v :: env2) b2)
(&&) <$> convert (VClos env1 a1) (VClos env2 a2)
<*> delay <$> convert (VClos (v :: env1) b1) (VClos (v :: env2) b2)
(VClos env1 (TSigma a1 b1), VClos env2 (TSigma a2 b2)) => do
termGuard env1 env2 a1 a2
@ -97,16 +98,13 @@ convert u1 u2 = do
v <- VGen <$> fresh
convert vsc (VClos (v :: env) sc)
-- VApp
-- (VApp v1 v2 , VClos env (TApp t1 t2)) => (&&) <$> convert v1 (VClos env t1) <*> delay <$> convert v1 (VClos env t1)
-- (VClos env (TApp t1 t2), VApp v1 v2) => (&&) <$> convert v1 (VClos env t1) <*> delay <$> convert v1 (VClos env t1)
(v1, v2) => oops ("cannot convert \n" ++ show v1 ++ "\n\n" ++ show v2)
where
where
termConv : Ctx n -> Ctx m -> Term n -> Term m -> PI Bool
termConv env1 env2 a1 a2 = do
a1' <- eval env1 a1
a2' <- eval env2 a2
convert a1' a2'
termGuard : Ctx n -> Ctx m -> Term n -> Term m -> PI ()
termGuard env1 env2 a1 a2 = guardS "termGuard" =<< termConv env1 env2 a1 a2
termGuard env1 env2 a1 a2 = termConv env1 env2 a1 a2 >>=
guardS ("cannot convert \n" ++ show a1 ++ "\n\n" ++ show a2)

61
src/Core/Misc.idr
View File

@ -6,6 +6,8 @@ import Control.Monad.Either
import Data.Nat
import Data.Vect
import Data.IORef
import Data.IOArray
%default total
@ -19,13 +21,46 @@ Name = String
public export
PI : Type -> Type
PI = EitherT String (RWS () (List String) Nat)
PI = EitherT String IO
public export
resolve : PI a -> Either String (a, List String)
resolve a = case runRWS (runEitherT a) () 0 of
(Left e, _) => Left e
(Right r, _, s) => Right (r, s)
data NST : Type where
public export
data DTY : Type where
public export
data DTR : Type where
public export
data RefP : Type -> Type -> Type where
MkRefP : (label : Type) -> a -> RefP label a
public export
RefA : Type -> Type -> Type
RefA label a = RefP label (IOArray a)
public export
Ref : Type -> Type -> Type
Ref label a = RefP label (IORef a)
public export
getRef : HasIO io => (label : Type) -> {auto ref : Ref label a} -> io a
getRef _ {ref = MkRefP _ ref} = readIORef ref
public export
putRef : HasIO io => (label : Type) -> {auto ref : Ref label a} -> a -> io ()
putRef _ {ref = MkRefP _ ref} = writeIORef ref
public export
getArr : HasIO io => (label : Type) -> {auto ref : RefA label a} -> Int -> io (Maybe a)
getArr _ {ref = MkRefP _ ref} = readArray ref
public export
putArr : HasIO io => (label : Type) -> {auto ref : RefA label a} -> Int -> a -> io Bool
putArr _ {ref = MkRefP _ ref} = writeArray ref
public export
resolve : PI a -> IO (Either String a)
resolve a = runEitherT a
public export
oops : String -> PI a
@ -36,19 +71,9 @@ guardS : String -> Bool -> PI ()
guardS str True = pure ()
guardS str False = oops str
public export
fresh : PI Nat
fresh : {auto frst : Ref NST Nat} -> PI Nat
fresh = do
i <- get
put (S i)
i <- getRef NST
putRef NST (S i)
pure i
public export
logS : String -> PI ()
logS = tell . (`Prelude.(::)` [])
public export
headM : Vect n a -> Maybe a
headM [] = Nothing
headM (x :: _) = Just x

19
src/Core/Normalize.idr
View File

@ -10,12 +10,16 @@ import Control.Monad.Either
import Data.Nat
import Data.Vect
import Data.IOArray
import Data.IORef
%default total
mutual
public export
app : Value -> Value -> PI Value
app : {auto deftrs : RefA DTR Value}
-> {auto frst : Ref NST Nat}
-> Value -> Value -> PI Value
app (VClos env (TLam sc)) x = eval (x :: env) sc
app (VClos env (TTopInd c st)) VTop = eval env st
@ -36,8 +40,15 @@ mutual
app f x = pure (VApp f x)
public export
eval : Ctx n -> Term n -> PI Value
eval : {auto deftrs : RefA DTR Value}
-> {auto frst : Ref NST Nat}
-> Ctx n -> Term n -> PI Value
eval env (TVar i) = pure (index i env)
eval env (TDef i) = do
res <- getArr DTR i
case res of
Just x => pure x
Nothing => oops "TDef term lookup"
eval env TType = pure VType
eval env TTop = pure VTop
eval env TStar = pure VStar
@ -55,7 +66,9 @@ mutual
eval env tr = pure (VClos env tr)
public export
whnf : Value -> PI Value
whnf : {auto deftrs : RefA DTR Value}
-> {auto frst : Ref NST Nat}
-> Value -> PI Value
whnf (VClos env tr) = eval env tr
whnf (VApp f x) = do
f' <- whnf f

8
src/Core/Term.idr
View File

@ -9,6 +9,9 @@ import Core.Misc
{-
The type of terms is indexed by the size of the environment in which
they are valid, that is, it is impossible to construct an ill-scoped term.
Defs are used for performance reasons and are not implemented in a type safe manner.
if a def is not in scope the checker will scream at you.
-}
public export
data Term : (_ : Index) -> Type where
@ -40,8 +43,11 @@ data Term : (_ : Index) -> Type where
TPi : Term n -> Term (S n) -> Term n -- Pi type (∏ _ : A . B _ )
TApp : Term n -> Term n -> Term n -- Appliction
TVar : Fin n -> Term n -- Variable
TDef : Int -> Term n -- Def Variable
infixl 3 `TApp`
public export
@ -76,6 +82,7 @@ Show (Term n) where
show (TApp f x) = "(" ++ show f ++ ") TApp (" ++ show x ++ ")"
show (TVar i) = "Var " ++ show i
show (TDef i) = "Def " ++ show i
public export
weakTr : Term n -> Term (S n)
@ -105,6 +112,7 @@ weakTr = go 0
go n (TVar i) = if weaken i < n
then TVar (weaken i)
else TVar (FS i)
go n (TDef i) = TDef i
public export
weakTr2 : Term n -> Term (2+n)

155
src/Core/Tests.idr
View File

@ -1,155 +0,0 @@
module Core.Tests
import Core.Term
import Core.Check
import Core.Convert
import Core.Misc
import Core.Normalize
import Core.Value
import Control.Monad.RWS
import Control.Monad.Identity
import Control.Monad.Either
import Data.Fin
%default total
{- λA. λx. x : ∏ (A : Type) → A → A -}
test_id : Either String (Bool, List String)
test_id = typecheck (TLam (TLam (TVar 0)))
(TPi TType (TPi (TVar 0) (TVar 1)))
{- λA. λB. λf. λx. f x : ∏ (A : Type) ∏ (B : A → Type) ∏ (f : ∏ (x : A) B x) ∏ (x : A) B x -}
test_app : Either String (Bool, List String)
test_app = typecheck (TLam (TLam (TLam (TLam (TVar 1 `TApp` TVar 0)))))
(TPi TType
(TPi (TPi (TVar 0) TType)
(TPi (TPi (TVar 1) (TVar 1 `TApp` TVar 0))
(TPi (TVar 2) (TVar 2 `TApp` TVar 0)))))
{- λf. λx. f x ≃ λf. λx. (λy. f y) x -}
eta_test : Either String (Bool, List String)
eta_test = resolve action
where
action : PI Bool
action = do
x <- eval ctx0 (TLam (TLam (TVar 1 `TApp` TVar 0)))
y <- eval ctx0 (TLam (TLam (TLam (TVar 2 `TApp` TVar 0) `TApp` TVar 0)))
convert x y
addition : Term 0
addition = TNatInd (TLam (TPi TNat TNat))
(TLam (TVar 0))
(TLam {-n-} (TLam {-n+-} (TLam {-m-} (TSuc (TVar 1 `TApp` TVar 0)))))
additionty : Term 0
additionty = TPi TNat (TPi TNat TNat)
additionty_test : Either String (Bool, List String)
additionty_test = typecheck additionty TType
addition_test : Either String (Bool, List String)
addition_test = typecheck addition additionty
{- 2 + 1 = 3 -}
addition_compute_test : Either String (Bool, List String)
addition_compute_test = resolve action
where
action : PI Bool
action = do
x <- eval ctx0 (addition `TApp` TSuc (TSuc TZero) `TApp` TSuc TZero)
y <- eval ctx0 (TSuc (TSuc (TSuc TZero)))
convert x y
multi : Term 0
multi = TNatInd (TLam (TPi TNat TNat))
(TLam TZero)
(TLam {-n-} (TLam {-n*-} (TLam {-m-} (weakTr3 addition `TApp` TVar 0 `TApp` (TVar 1 `TApp` TVar 0)))))
multity : Term 0
multity = TPi TNat (TPi TNat TNat)
multity_test : Either String (Bool, List String)
multity_test = typecheck multity TType
multi_test : Either String (Bool, List String)
multi_test = typecheck multi multity
{- 2 * 3 = 6 -}
multi_compute_test : Either String (Bool, List String)
multi_compute_test = resolve action
where
action : PI Bool
action = do
x <- eval ctx0 (multi `TApp` TSuc (TSuc TZero) `TApp` TSuc (TSuc (TSuc TZero)))
y <- eval ctx0 (TSuc (TSuc (TSuc (TSuc (TSuc (TSuc TZero))))))
convert x y
-- no, not that kind
unit_test : Either String (Bool, List String)
unit_test = typecheck TStar TTop
absurd_test : Either String (Bool, List String)
absurd_test = typecheck (TLam (TBotInd (TLam (TVar 1)))) (TPi TType (TPi TBot (TVar 1)))
pr1ty : Term 0
pr1ty = TPi TType {- A : Type -}
(TPi (TPi (TVar 0) TType) {- B : A → Type -}
(TPi (TSigma (TVar 1) (TVar 0)) {- Σ A B -}
(TVar 2)))
pr1 : Term 0
pr1 = TLam {- A : Type -}
(TLam {- B : A → Type -}
(TSigInd (TVar 1) (TVar 0) (TLam {-ΣAB-} (TVar 2)) (TLam (TLam (TVar 1)))))
pr1ty_test : Either String (Bool, List String)
pr1ty_test = typecheck pr1ty TType
pr1_test : Either String (Bool, List String)
pr1_test = typecheck pr1 pr1ty
pr2ty : Term 0
pr2ty = TPi TType {- A : Type -}
(TPi (TPi (TVar 0) TType) {- B : A → Type -}
(TPi (TSigma (TVar 1) (TVar 0)) {- Σ A B -}
(TVar 1 `TApp` (TSigInd (TVar 2) (TVar 1) (TLam (TVar 3)) (TLam (TLam (TVar 1))) `TApp` TVar 0))))
pr2 : Term 0
pr2 = TLam {- A : Type -}
(TLam {- B : A → Type -}
(TSigInd (TVar 1)
(TVar 0)
(TLam {-ΣAB-}
(TVar 1 `TApp` (TSigInd (TVar 2) (TVar 1) (TLam (TVar 3)) (TLam (TLam (TVar 1))) `TApp` TVar 0)))
(TLam (TLam (TVar 0)))))
pr2ty_test : Either String (Bool, List String)
pr2ty_test = typecheck pr2ty TType
pr2_test : Either String (Bool, List String)
pr2_test = typecheck pr2 pr2ty
pr2ty_let : Term 0
pr2ty_let = TLet pr1ty pr1 {- pr1 : pr1ty -}
(TPi TType {- A : Type -}
(TPi (TPi (TVar 0) TType) {- B : A → Type -}
(TPi (TSigma (TVar 1) (TVar 0)) {- Σ A B -}
(TVar 1 `TApp` (TVar 3 `TApp` TVar 2 `TApp` TVar 1 `TApp` TVar 0)))))
pr2_let : Term 0
pr2_let = TLet pr1ty pr1 {- pr1 : pr1ty -}
(TLam {- A : Type -}
(TLam {- B : A → Type -}
(TSigInd (TVar 1)
(TVar 0)
(TLam {-ΣAB-}
(TVar 1 `TApp` (TVar 3 `TApp` TVar 2 `TApp` TVar 1 `TApp` TVar 0)))
(TLam (TLam (TVar 0))))))
pr2ty_let_test : Either String (Bool, List String)
pr2ty_let_test = typecheck pr2ty_let TType
pr2_let_test : Either String (Bool, List String)
pr2_let_test = typecheck pr2_let pr2ty_let

94
src/Main.idr
View File

@ -2,22 +2,59 @@ module Main
import Core.Check
import Core.Term
import Core.Value
import Core.Normalize
import Core.Misc
import Parser.Parse
import Control.Monad.Either
import Data.Vect
import Data.String
import Data.IORef
import Data.IOArray
import System
import System.File
unwrap : {a : Type} -> Show a => Either a b -> IO b
unwrap {a = a} = \case
smartPrint : {a : Type} -> Show a => a -> IO ()
smartPrint {a = String} = putStrLn
smartPrint {a = _} = printLn
isTrue : String -> Bool -> IO ()
isTrue _ True = pure ()
isTrue str False = putStrLn str >> exitFailure
unwrapCC : {a : Type} -> Show a => IO b -> Either a b -> IO b
unwrapCC {a = a} iob = \case
Left e => do
case a of
String => putStrLn e
_ => printLn e
exitFailure
smartPrint e
iob
Right s => pure s
unwrap : {a : Type} -> Show a => Either a b -> IO b
unwrap = unwrapCC exitFailure
createNST : IO (Ref NST Nat)
createNST = do
nstIoRef <- newIORef 0
pure (MkRefP NST nstIoRef)
createDTX : (label : Type) -> Int -> IO (RefA label Value)
createDTX label n = do
arr <- newArray n
pure (MkRefP label arr)
typeCheck : {auto deftrs : RefA DTR Value}
-> {auto deftys : RefA DTY Value}
-> {auto frst : Ref NST Nat}
-> Int -> List (Term 0, Term 0) -> IO ()
typeCheck i [] = pure ()
typeCheck i ((ty, tr) :: defs) = do
vty <- unwrap =<< resolve (eval [] ty)
vtr <- unwrap =<< resolve (eval [] tr)
isTrue "putArr DTY" =<< putArr DTY i vty
isTrue "putArr DTR" =<< putArr DTR i vtr
typeCheck (i+1) defs
replRead : IO String
replRead = do
line <- getLine
@ -27,19 +64,40 @@ replRead = do
":exit" => exitSuccess
_ => pure line
repl : (n : Nat) -> Vect n String -> IO ()
repl n env = do
repl : {auto deftrs : RefA DTR Value}
-> {auto deftys : RefA DTY Value}
-> {auto frst : Ref NST Nat}
-> List String -> IO a
repl strs = do
line <- replRead
printLn =<< unwrap (parseEnv n env line)
repl n env
term <- unwrapCC (repl strs) (parseEnv strs line)
type <- unwrapCC (repl strs) =<< resolve (whnf =<< infer [] [] term)
val <- unwrapCC (repl strs) =<< resolve (whnf =<< eval [] term)
putStr "inferred type: "
printLn type
putStr "weak head normal form: "
printLn val
repl strs
main : IO ()
main = getArgs >>= \case
(_ :: x :: _) => do
putStr (x ++ ": ")
res <- readFile x >>= unwrap >>= unwrap . parsetoplevel
>>= unwrap . (`typecheck` TTop)
if fst res
then putStrLn ("Success !")
else unwrap (Left res)
_ => repl 0 []
(_ :: x :: xs) => do
putStrLn (x ++ ": ")
putStr "Parsing: "
(strs, res) <- readFile x >>= unwrap >>= unwrap . toplevel
putStrLn " OK!"
let rlen = cast (length res)
nst <- createNST
dtr <- createDTX DTR rlen
dty <- createDTX DTY rlen
putStr "Typechecking: "
typeCheck 0 res
putStrLn "OK!"
case xs of
("repl" :: _) => repl strs
_ => exitSuccess
_ => do
nst <- createNST
dtr <- createDTX DTR 0
dty <- createDTX DTY 0
repl []

231
src/Parser/Parse.idr
View File

@ -211,40 +211,40 @@ lexPi str =
{- Basic idea, parsing has a list of the identifiers to convert to -}
{- de bruijn indecies, and a Nat to keep track of context size -}
mutual
expr : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
expr n env = tpi n env
<|> tsigma n env
<|> tarr n env
expr : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
expr defs n env = tpi defs n env
<|> tsigma defs n env
<|> tarr defs n env
<|> (do
e <- expr1 n env
tapp n env e <|> pure e)
e <- expr1 defs n env
tapp defs n env e <|> pure e)
expr1 : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
expr1 n env = ttopind n env
<|> tbotind n env
<|> tsuc n env
<|> tnatind n env
<|> tsigind n env
<|> tid n env
<|> trefl n env
<|> tj n env
expr1 : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
expr1 defs n env = ttopind defs n env
<|> tbotind defs n env
<|> tsuc defs n env
<|> tnatind defs n env
<|> tsigind defs n env
<|> tid defs n env
<|> trefl defs n env
<|> tj defs n env
<|> (do
t <- term n env
tapp n env t <|> pure t)
t <- term defs n env
tapp defs n env t <|> pure t)
term : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
term n env = ttype
term : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
term defs n env = ttype
<|> ttop
<|> tstar
<|> tbot
<|> tnat
<|> tnum
<|> tpair n env
<|> tlet n env
<|> tlam n env
<|> tvar n env
<|> paren n env
<|> tpair defs n env
<|> tlet defs n env
<|> tlam defs n env
<|> tvar defs n env
<|> paren defs n env
ttype : Grammar () PiToken True (Term n)
ttype = match PTType >> pure TType
@ -255,22 +255,22 @@ mutual
tstar : Grammar () PiToken True (Term n)
tstar = match PTStar >> pure TStar
ttopind : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
ttopind n env = do
ttopind : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
ttopind defs n env = do
match PTTopInd
commit
c <- term n env
st <- term n env
c <- term defs n env
st <- term defs n env
pure (TTopInd c st)
tbot : Grammar () PiToken True (Term n)
tbot = match PTBot >> pure TBot
tbotind : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tbotind n env = do
tbotind : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tbotind defs n env = do
match PTBotInd
commit
c <- term n env
c <- term defs n env
pure (TBotInd c)
tnat : Grammar () PiToken True (Term n)
@ -285,162 +285,161 @@ mutual
conv 0 = TZero
conv (S n) = TSuc (conv n)
tsuc : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tsuc n env = do
tsuc : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tsuc defs n env = do
match PTSuc
commit
TSuc <$> term n env
TSuc <$> term defs n env
tnatind : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tnatind n env = do
tnatind : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tnatind defs n env = do
match PTNatInd
commit
c <- term n env
z <- term n env
s <- term n env
c <- term defs n env
z <- term defs n env
s <- term defs n env
pure (TNatInd c z s)
tsigma : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tsigma n env = do
tsigma : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tsigma defs n env = do
match PTSigma
commit
match PTLParen
arg <- match PTIdentifier
match PTColon
a <- expr n env
a <- expr defs n env
match PTRParen
b <- expr (S n) (arg :: env)
b <- expr defs (S n) (arg :: env)
pure (TSigma a (TLam b))
tpair : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tpair n env = do
tpair : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tpair defs n env = do
match PTLParen
x <- expr n env
x <- expr defs n env
match PTComma
commit
y <- expr n env
y <- expr defs n env
match PTRParen
pure (TPair x y)
tsigind : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tsigind n env = do
tsigind : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tsigind defs n env = do
match PTSigInd
commit
a <- term n env
b <- term n env
c <- term n env
f <- term n env
a <- term defs n env
b <- term defs n env
c <- term defs n env
f <- term defs n env
pure (TSigInd a b c f)
tid : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tid n env = do
tid : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tid defs n env = do
match PTId
commit
ty <- term n env
a <- term n env
b <- term n env
ty <- term defs n env
a <- term defs n env
b <- term defs n env
pure (TId ty a b)
trefl : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
trefl n env = do
trefl : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
trefl defs n env = do
match PTRefl
commit
ty <- term n env
tr <- term n env
ty <- term defs n env
tr <- term defs n env
pure (TRefl ty tr)
tj : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tj n env = do
tj : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tj defs n env = do
match PTJ
commit
ty <- term n env
a <- term n env
b <- term n env
c <- term n env
d <- term n env
ty <- term defs n env
a <- term defs n env
b <- term defs n env
c <- term defs n env
d <- term defs n env
pure (TJ ty a b c d)
tlet : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tlet n env = do
tlet : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tlet defs n env = do
match PTLet
commit
arg <- match PTIdentifier
match PTColon
ty <- expr n env
ty <- expr defs n env
match PTDefEq
tr <- expr n env
tr <- expr defs n env
match PTIn
tri <- expr (S n) (arg :: env)
tri <- expr defs (S n) (arg :: env)
pure (TLet ty tr tri)
tlam : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tlam n env = do
tlam : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tlam defs n env = do
match PTLambda
commit
arg <- match PTIdentifier
match PTDot
e <- expr (S n) (arg :: env)
e <- expr defs (S n) (arg :: env)
pure (TLam e)
tpi : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tpi n env = do
tpi : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tpi defs n env = do
match PTPi
commit
match PTLParen
arg <- match PTIdentifier
match PTColon
a <- expr n env
a <- expr defs n env
match PTRParen
b <- expr (S n) (arg :: env)
b <- expr defs (S n) (arg :: env)
pure (TPi a b)
tarr : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tarr n env = do
l <- expr1 n env
tarr : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tarr defs n env = do
l <- expr1 defs n env
match PTArrow
commit
r <- expr (S n) ("" :: env)
r <- expr defs (S n) ("" :: env)
pure (TPi l r)
tapp : (n : Nat) -> Vect n String -> Term n -> Grammar () PiToken True (Term n)
tapp n env e1 = do
e2 <- term n env
tapp1 n env (TApp e1 e2)
tapp : List String -> (n : Nat) -> Vect n String -> Term n -> Grammar () PiToken True (Term n)
tapp defs n env e1 = do
e2 <- term defs n env
tapp1 defs n env (TApp e1 e2)
tapp1 : (n : Nat) -> Vect n String -> Term n -> Grammar () PiToken False (Term n)
tapp1 n env e = tapp n env e <|> pure e
tapp1 : List String -> (n : Nat) -> Vect n String -> Term n -> Grammar () PiToken False (Term n)
tapp1 defs n env e = tapp defs n env e <|> pure e
tvar : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tvar n env = do
tvar : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
tvar defs n env = do
str <- match PTIdentifier
commit
fromMaybe (fail ("'" ++ str ++ "' not in env")) (pure . TVar <$> findIndex (== str) env)
fromMaybe (fromMaybe (fail ("'" ++ str ++ "' not idefs n env"))
(pure . TDef . cast . finToInteger <$> findIndex (== str) defs))
(pure . TVar <$> findIndex (== str) env)
paren : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
paren n env = do
paren : List String -> (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
paren defs n env = do
match PTLParen
commit
e <- expr n env
e <- expr defs n env
match PTRParen
pure e
definitions : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n)
definitions n env = do
definitions : List String -> Grammar () PiToken True (List String, List (Term 0, Term 0))
definitions defs = do
match PTLet
commit
arg <- match PTIdentifier
match PTColon
ty <- expr n env
ty <- expr defs 0 []
match PTDefEq
tr <- expr n env
next <- definitions (S n) (arg :: env) <|> pure TStar
pure (TLet ty tr next)
tr <- expr defs 0 []
next <- definitions (arg :: defs) <|> pure ([], [])
pure (arg :: fst next, (ty, tr) :: snd next)
toplevel : Grammar () PiToken True (Term 0)
toplevel = definitions 0 []
parsePi : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n) -> List (WithBounds PiToken) -> Either String (Term n)
parsePi n env parseEntry toks =
parsePi : List String -> Grammar () PiToken True a -> List (WithBounds PiToken) -> Either String a
parsePi defs parseEntry toks =
case parse parseEntry $ filter (not . ignored) toks of
Right (l, []) => Right l
Right (_, l) => Left ("contains tokens that were not consumed: " ++ show l)
@ -452,20 +451,20 @@ parsePi n env parseEntry toks =
public export
parse : (n : Nat) -> Vect n String -> Grammar () PiToken True (Term n) -> String -> Either String (Term n)
parse n env parseEntry x =
parse : List String -> Grammar () PiToken True a -> String -> Either String a
parse defs parseEntry x =
case lexPi x of
Just toks => parsePi n env parseEntry toks
Just toks => parsePi defs parseEntry toks
Nothing => Left "Failed to lex."
public export
parse0 : String -> Either String (Term 0)
parse0 = parse 0 [] (expr 0 [])
parse0 = parse [] (expr [] 0 [])
public export
parseEnv : (n : Nat) -> Vect n String -> String -> Either String (Term n)
parseEnv n env = parse n env (expr n env)
parseEnv : List String -> String -> Either String (Term 0)
parseEnv defs = parse defs (expr defs 0 [])
public export
parsetoplevel : String -> Either String (Term 0)
parsetoplevel = parse 0 [] (toplevel)
toplevel : String -> Either String (List String, List (Term 0, Term 0))
toplevel = parse [] (definitions [])

89
src/Parser/Tests.idr
View File

@ -1,89 +0,0 @@
module Parser.Tests
import Core.Term
import Core.Check
import Core.Convert
import Core.Misc
import Core.Normalize
import Core.Value
import Control.Monad.RWS
import Control.Monad.Identity
import Control.Monad.Either
import Data.Fin
import Parser.Parse
%default total
convCheck : Term 0 -> Term 0 -> Either String (Bool, List String)
convCheck a b = resolve action
where
action : PI Bool
action = do
x <- eval ctx0 a
y <- eval ctx0 b
convert x y
{- λA. λx. x : ∏ (A : Type) → A → A -}
test_id : Either String (Bool, List String)
test_id = do
ty <- parse0 "Π ( A : Type ) A → A"
tr <- parse0 "λA.λx.x"
typecheck tr ty
{- λA. λB. λf. λx. f x : ∏ (A : Type) ∏ (B : A → Type) ∏ (f : ∏ (x : A) B x) ∏ (x : A) B x -}
test_app : Either String (Bool, List String)
test_app = do
ty <- parse0 "Π (A : Type) Π (B : A → Type) Π (f : Π (x : A) B x) Π (x : A) B x"
tr <- parse0 "λA. λB. λf. λx. f x"
typecheck tr ty
{- λf. f ≃ λf. λx. f x -}
eta_test : Either String (Bool, List String)
eta_test = do
a <- parse0 "λf. f"
b <- parse0 "λf. λx. f x"
convCheck a b
additionty_test : Either String (Bool, List String)
additionty_test = do
ty <- parse0 "ℕ → ℕ → ℕ"
typecheck ty TType
addition_test : Either String (Bool, List String)
addition_test = do
ty <- parse0 "ℕ → ℕ → ℕ"
tr <- parse0 "ℕ-ind (λ_. ℕ → ℕ) (λx.x) (λn.λnp.λm. suc (np m))"
typecheck tr ty
-- no, not that kind
unit_test : Either String (Bool, List String)
unit_test = do
ty <- parse0 "⊤"
tr <- parse0 "★"
typecheck tr ty
absurd_test : Either String (Bool, List String)
absurd_test = do
ty <- parse0 "Π(A : Type) ⊥ → A"
tr <- parse0 "λA. ⊥-ind (λ_. A)"
typecheck tr ty
pr1_test : Either String (Bool, List String)
pr1_test = do
tr <- parse0 $ "let pr1 : Π (A : Type) Π (B : A → Type) (Σ (a : A) B a) → A"
++ "≔ λA.λB. Σ-ind A B (λ_. A) (λa.λBa. a)"
++ "in ★"
typecheck tr TTop
pr1_pr2_test : Either String (Bool, List String)
pr1_pr2_test = do
tr <- parse0 $ "let pr1 : Π (A : Type) Π (B : A → Type) (Σ (a : A) B a) → A"
++ "≔ λA.λB. Σ-ind A B (λ_. A) (λa.λBa. a)"
++ "in let pr2 : Π (A : Type) Π (B : A → Type) Π (s : Σ (a : A) B a) B (pr1 A B s)"
++ "≔ λA.λB. Σ-ind A B (λs. B (pr1 A B s)) (λa.λBa. Ba)"
++ "in ★"
typecheck tr TTop

3
tests/id1.pi 100644
View File

@ -0,0 +1,3 @@
let transport : Π (A : Type) Π (f : A → Type) Π (x : A) Π (y : A)
Id A x y → f x → f y
≔ λA.λf.λx.λy. J A x y (λa.λb.λ_. f a → f b) (λa.a)

3
tests/id2.pi 100644
View File

@ -0,0 +1,3 @@
let ap : Π (A : Type) Π (B : Type) Π (f : A → B)
Π (x : A) Π (y : A) Id A x y → Id B (f x) (f y)
≔ λA.λB.λf.λx.λy. J A x y (λa.λb.λ_. Id B (f a) (f b)) (refl B (f x))