wball/perga
1
0
Fork 0
Code Issues 15 Pull requests Projects Releases Packages Wiki Activity Actions

working on parser

Browse source
This commit is contained in:
William Ball 2025-01-24 14:59:06 -08:00
parent 2c1f193d77
commit 1544a33644
Signed by: wball
GPG key ID: B8682D8137B70765
2 changed files with 74 additions and 63 deletions
Show stats Download patch file Download diff file Expand all files Collapse all files

82
examples/logic.pg
View file

@ -11,7 +11,7 @@ def false_elim (A : ★) (contra : false) : A := contra A;
-- True -- True
def true : ★ := forall (A : ★), A → A; def true : ★ := forall (A : ★), A -> A;
def true_intro : true := [A : ★][x : A] x; def true_intro : true := [A : ★][x : A] x;
@ -19,10 +19,10 @@ def true_intro : true := [A : ★][x : A] x;
-- Negation -- Negation
def not (A : ★) : ★ := A → false; def not (A : ★) : ★ := A -> false;
-- introduction rule (kinda just the definition) -- introduction rule (kinda just the definition)
def not_intro (A : ★) (h : A → false) : not A := h; def not_intro (A : ★) (h : A -> false) : not A := h;
-- elimination rule -- elimination rule
def not_elim (A B : ★) (a : A) (na : not A) : B := na a B; def not_elim (A B : ★) (a : A) (na : not A) : B := na a B;
@ -35,11 +35,11 @@ def double_neg_intro (A : ★) (a : A) : not (not A) :=
-- Conjunction -- Conjunction
def ∧ (A B : ★) : ★ := {A × B}; def ∧ (A B : ★) : ★ := A × B;
infixl 10 ∧; infixl 10 ∧;
-- introduction rule -- introduction rule
def and_intro (A B : ★) (a : A) (b : B) : A ∧ B := <a, b>; def and_intro (A B : ★) (a : A) (b : B) : A ∧ B := (a, b);
-- left elimination rule -- left elimination rule
def and_elim_l (A B : ★) (ab : A ∧ B) : A := π₁ ab; def and_elim_l (A B : ★) (ab : A ∧ B) : A := π₁ ab;
@ -52,19 +52,19 @@ def and_elim_r (A B : ★) (ab : A ∧ B) : B := π₂ ab;
-- Disjunction -- Disjunction
-- 2nd order disjunction -- 2nd order disjunction
def ∨ (A B : ★) : ★ := forall (C : ★), (A → C) → (B → C) → C; def ∨ (A B : ★) : ★ := forall (C : ★), (A -> C) -> (B -> C) -> C;
infixl 5 ∨; infixl 5 ∨;
-- left introduction rule -- left introduction rule
def or_intro_l (A B : ★) (a : A) : A ∨ B := def or_intro_l (A B : ★) (a : A) : A ∨ B :=
fun (C : ★) (ha : A → C) (hb : B → C) => ha a; fun (C : ★) (ha : A -> C) (hb : B -> C) => ha a;
-- right introduction rule -- right introduction rule
def or_intro_r (A B : ★) (b : B) : A ∨ B := def or_intro_r (A B : ★) (b : B) : A ∨ B :=
fun (C : ★) (ha : A → C) (hb : B → C) => hb b; fun (C : ★) (ha : A -> C) (hb : B -> C) => hb b;
-- elimination rule (kinda just the definition) -- elimination rule (kinda just the definition)
def or_elim (A B C : ★) (ab : A ∨ B) (ha : A → C) (hb : B → C) : C := def or_elim (A B C : ★) (ab : A ∨ B) (ha : A -> C) (hb : B -> C) : C :=
ab C ha hb; ab C ha hb;
-- -------------------------------------------------------------------------------------------------------------- -- --------------------------------------------------------------------------------------------------------------
@ -72,14 +72,14 @@ def or_elim (A B C : ★) (ab : A ∨ B) (ha : A → C) (hb : B → C) : C :=
-- Existential -- Existential
-- 2nd order existential -- 2nd order existential
def exists (A : ★) (P : A → ★) : ★ := forall (C : ★), (forall (x : A), P x → C) → C; def exists (A : ★) (P : A -> ★) : ★ := forall (C : ★), (forall (x : A), P x -> C) -> C;
-- introduction rule -- introduction rule
def exists_intro (A : ★) (P : A → ★) (a : A) (h : P a) : exists A P := def exists_intro (A : ★) (P : A -> ★) (a : A) (h : P a) : exists A P :=
fun (C : ★) (g : forall (x : A), P x → C) => g a h; fun (C : ★) (g : forall (x : A), P x -> C) => g a h;
-- elimination rule (kinda just the definition) -- elimination rule (kinda just the definition)
def exists_elim (A B : ★) (P : A → ★) (ex_a : exists A P) (h : forall (a : A), P a → B) : B := def exists_elim (A B : ★) (P : A -> ★) (ex_a : exists A P) (h : forall (a : A), P a -> B) : B :=
ex_a B h; ex_a B h;
-- -------------------------------------------------------------------------------------------------------------- -- --------------------------------------------------------------------------------------------------------------
@ -87,53 +87,53 @@ def exists_elim (A B : ★) (P : A → ★) (ex_a : exists A P) (h : forall (a :
-- Universal -- Universal
-- 2nd order universal (just ∏, including it for completeness) -- 2nd order universal (just ∏, including it for completeness)
def all (A : ★) (P : A → ★) : ★ := forall (a : A), P a; def all (A : ★) (P : A -> ★) : ★ := forall (a : A), P a;
-- introduction rule -- introduction rule
def all_intro (A : ★) (P : A → ★) (h : forall (a : A), P a) : all A P := h; def all_intro (A : ★) (P : A -> ★) (h : forall (a : A), P a) : all A P := h;
-- elimination rule -- elimination rule
def all_elim (A : ★) (P : A → ★) (h_all : all A P) (a : A) : P a := h_all a; def all_elim (A : ★) (P : A -> ★) (h_all : all A P) (a : A) : P a := h_all a;
-- -------------------------------------------------------------------------------------------------------------- -- --------------------------------------------------------------------------------------------------------------
-- Equality -- Equality
-- 2nd order Leibniz equality -- 2nd order Leibniz equality
def eq (A : ★) (x y : A) := forall (P : A → ★), P x → P y; def eq (A : ★) (x y : A) := forall (P : A -> ★), P x -> P y;
-- equality is reflexive -- equality is reflexive
def eq_refl (A : ★) (x : A) : eq A x x := fun (P : A → ★) (Hx : P x) => Hx; def eq_refl (A : ★) (x : A) : eq A x x := fun (P : A -> ★) (Hx : P x) => Hx;
-- equality is symmetric -- equality is symmetric
def eq_sym (A : ★) (x y : A) (Hxy : eq A x y) : eq A y x := fun (P : A → ★) (Hy : P y) => def eq_sym (A : ★) (x y : A) (Hxy : eq A x y) : eq A y x := fun (P : A -> ★) (Hy : P y) =>
Hxy (fun (z : A) => P z → P x) (fun (Hx : P x) => Hx) Hy; Hxy (fun (z : A) => P z -> P x) (fun (Hx : P x) => Hx) Hy;
-- equality is transitive -- equality is transitive
def eq_trans (A : ★) (x y z : A) (Hxy : eq A x y) (Hyz : eq A y z) : eq A x z := fun (P : A → ★) (Hx : P x) => def eq_trans (A : ★) (x y z : A) (Hxy : eq A x y) (Hyz : eq A y z) : eq A x z := fun (P : A -> ★) (Hx : P x) =>
Hyz P (Hxy P Hx); Hyz P (Hxy P Hx);
-- equality is a universal congruence -- equality is a universal congruence
def eq_cong (A B : ★) (x y : A) (f : A → B) (H : eq A x y) : eq B (f x) (f y) := def eq_cong (A B : ★) (x y : A) (f : A -> B) (H : eq A x y) : eq B (f x) (f y) :=
fun (P : B → ★) (Hfx : P (f x)) => fun (P : B -> ★) (Hfx : P (f x)) =>
H (fun (a : A) => P (f a)) Hfx; H (fun (a : A) => P (f a)) Hfx;
-- -------------------------------------------------------------------------------------------------------------- -- --------------------------------------------------------------------------------------------------------------
-- unique existence -- unique existence
def exists_uniq (A : ★) (P : A → ★) : ★ := def exists_uniq (A : ★) (P : A -> ★) : ★ :=
exists A (fun (x : A) => P x ∧ (forall (y : A), P y → eq A x y)); exists A (fun (x : A) => P x ∧ (forall (y : A), P y -> eq A x y));
def exists_uniq_elim (A B : ★) (P : A → ★) (ex_a : exists_uniq A P) (h : forall (a : A), P a → (forall (y : A), P y → eq A a y) → B) : B := def exists_uniq_elim (A B : ★) (P : A -> ★) (ex_a : exists_uniq A P) (h : forall (a : A), P a -> (forall (y : A), P y -> eq A a y) -> B) : B :=
exists_elim A B (fun (x : A) => P x ∧ (forall (y : A), P y → eq A x y)) ex_a exists_elim A B (fun (x : A) => P x ∧ (forall (y : A), P y -> eq A x y)) ex_a
(fun (a : A) (h2 : P a ∧ (forall (y : A), P y → eq A a y)) => (fun (a : A) (h2 : P a ∧ (forall (y : A), P y -> eq A a y)) =>
h a (and_elim_l (P a) (forall (y : A), P y → eq A a y) h2) h a (and_elim_l (P a) (forall (y : A), P y -> eq A a y) h2)
(and_elim_r (P a) (forall (y : A), P y → eq A a y) h2)); (and_elim_r (P a) (forall (y : A), P y -> eq A a y) h2));
def exists_uniq_t (A : ★) : ★ := def exists_uniq_t (A : ★) : ★ :=
exists A (fun (x : A) => forall (y : A), eq A x y); exists A (fun (x : A) => forall (y : A), eq A x y);
def exists_uniq_t_elim (A B : ★) (ex_a : exists_uniq_t A) (h : forall (a : A), (forall (y : A), eq A a y) → B) : B := def exists_uniq_t_elim (A B : ★) (ex_a : exists_uniq_t A) (h : forall (a : A), (forall (y : A), eq A a y) -> B) : B :=
exists_elim A B (fun (x : A) => forall (y : A), eq A x y) ex_a (fun (a : A) (h2 : forall (y : A), eq A a y) => h a h2); exists_elim A B (fun (x : A) => forall (y : A), eq A x y) ex_a (fun (a : A) (h2 : forall (y : A), eq A a y) => h a h2);
-- -------------------------------------------------------------------------------------------------------------- -- --------------------------------------------------------------------------------------------------------------
@ -146,8 +146,8 @@ section Theorems
-- ~(A ∨ B) => ~A ∧ ~B -- ~(A ∨ B) => ~A ∧ ~B
def de_morgan1 (h : not (A ∨ B)) : not A ∧ not B := def de_morgan1 (h : not (A ∨ B)) : not A ∧ not B :=
<[a : A] h (or_intro_l A B a) ( [a : A] h (or_intro_l A B a)
,[b : B] h (or_intro_r A B b)>; , [b : B] h (or_intro_r A B b));
-- ~A ∧ ~B => ~(A ∨ B) -- ~A ∧ ~B => ~(A ∨ B)
def de_morgan2 (h : not A ∧ not B) : not (A ∨ B) := def de_morgan2 (h : not A ∧ not B) : not (A ∨ B) :=
@ -164,7 +164,7 @@ section Theorems
-- the last one (~(A ∧ B) => ~A ∨ ~B) is not possible constructively -- the last one (~(A ∧ B) => ~A ∨ ~B) is not possible constructively
-- A ∧ B => B ∧ A -- A ∧ B => B ∧ A
def and_comm (h : A ∧ B) : B ∧ A := <π₂ h, π₁ h>; def and_comm (h : A ∧ B) : B ∧ A := (π₂ h, π₁ h);
-- A ∨ B => B ∨ A -- A ∨ B => B ∨ A
def or_comm (h : A ∨ B) : B ∨ A := def or_comm (h : A ∨ B) : B ∨ A :=
@ -174,11 +174,11 @@ section Theorems
-- A ∧ (B ∧ C) => (A ∧ B) ∧ C -- A ∧ (B ∧ C) => (A ∧ B) ∧ C
def and_assoc_l (h : A ∧ (B ∧ C)) : (A ∧ B) ∧ C := def and_assoc_l (h : A ∧ (B ∧ C)) : (A ∧ B) ∧ C :=
<<π₁ h, π₁ (π₂ h)>, π₂ (π₂ h)>; ((π₁ h, π₁ (π₂ h)), π₂ (π₂ h));
-- (A ∧ B) ∧ C => A ∧ (B ∧ C) -- (A ∧ B) ∧ C => A ∧ (B ∧ C)
def and_assoc_r (h : (A ∧ B) ∧ C) : A ∧ (B ∧ C) := def and_assoc_r (h : (A ∧ B) ∧ C) : A ∧ (B ∧ C) :=
<π₁ (π₁ h), <π₂ (π₁ h), π₂ h>>; (π₁ (π₁ h), (π₂ (π₁ h), π₂ h));
-- A ∨ (B ∨ C) => (A ∨ B) ∨ C -- A ∨ (B ∨ C) => (A ∨ B) ∨ C
def or_assoc_l (h : A ∨ (B ∨ C)) : (A ∨ B) ∨ C := def or_assoc_l (h : A ∨ (B ∨ C)) : (A ∨ B) ∨ C :=
@ -201,14 +201,14 @@ section Theorems
-- A ∧ (B ∨ C) => A ∧ B ∨ A ∧ C -- A ∧ (B ∨ C) => A ∧ B ∨ A ∧ C
def and_distrib_l_or (h : A ∧ (B ∨ C)) : A ∧ B ∨ A ∧ C := def and_distrib_l_or (h : A ∧ (B ∨ C)) : A ∧ B ∨ A ∧ C :=
or_elim B C (A ∧ B ∨ A ∧ C) (π₂ h) or_elim B C (A ∧ B ∨ A ∧ C) (π₂ h)
(fun (b : B) => or_intro_l (A ∧ B) (A ∧ C) <π₁ h, b>) (fun (b : B) => or_intro_l (A ∧ B) (A ∧ C) (π₁ h, b))
(fun (c : C) => or_intro_r (A ∧ B) (A ∧ C) <π₁ h, c>); (fun (c : C) => or_intro_r (A ∧ B) (A ∧ C) (π₁ h, c));
-- A ∧ B ∨ A ∧ C => A ∧ (B ∨ C) -- A ∧ B ∨ A ∧ C => A ∧ (B ∨ C)
def and_factor_l_or (h : A ∧ B ∨ A ∧ C) : A ∧ (B ∨ C) := def and_factor_l_or (h : A ∧ B ∨ A ∧ C) : A ∧ (B ∨ C) :=
or_elim (A ∧ B) (A ∧ C) (A ∧ (B ∨ C)) h or_elim (A ∧ B) (A ∧ C) (A ∧ (B ∨ C)) h
(fun (ab : A ∧ B) => <π₁ ab, or_intro_l B C (π₂ ab)>) (fun (ab : A ∧ B) => (π₁ ab, or_intro_l B C (π₂ ab)))
(fun (ac : A ∧ C) => <π₁ ac, or_intro_r B C (π₂ ac)>); (fun (ac : A ∧ C) => (π₁ ac, or_intro_r B C (π₂ ac)));
-- Thanks Quinn! -- Thanks Quinn!
-- A ∨ B => ~B => A -- A ∨ B => ~B => A
@ -216,7 +216,7 @@ section Theorems
or_elim A B A hor ([a : A] a) ([b : B] nb b A); or_elim A B A hor ([a : A] a) ([b : B] nb b A);
-- (A => B) => ~B => ~A -- (A => B) => ~B => ~A
def contrapositive (f : A → B) (nb : not B) : not A := def contrapositive (f : A -> B) (nb : not B) : not A :=
fun (a : A) => nb (f a); fun (a : A) => nb (f a);
end Theorems end Theorems

55
lib/Parser.hs
View file

@ -17,12 +17,25 @@ import qualified Text.Megaparsec.Char.Lexer as L
newtype TypeError = TE Error newtype TypeError = TE Error
deriving (Eq, Ord) deriving (Eq, Ord)
data InfixDef = InfixDef
{ infixFixity :: Fixity
, infixOp :: Text -> IRExpr -> IRExpr -> IRExpr
}
data Fixity data Fixity
= InfixL Int = InfixL Int
| InfixR Int | InfixR Int
deriving (Eq, Show) deriving (Eq, Show)
type Operators = Map Text Fixity type Operators = Map Text InfixDef
initialOps :: Operators
initialOps =
M.fromAscList
[ ("→", InfixDef (InfixR 2) (const $ Pi ""))
, ("->", InfixDef (InfixR 2) (const $ Pi ""))
, ("×", InfixDef (InfixL 10) (const Prod))
]
type Parser = ParsecT TypeError Text (State Operators) type Parser = ParsecT TypeError Text (State Operators)
@ -46,7 +59,7 @@ symbol :: Text -> Parser ()
symbol = void . L.symbol skipSpace symbol = void . L.symbol skipSpace
symbols :: String symbols :: String
symbols = "!@#$%^&*-+=<>,./?[]{}\\|`~'\"∧∨⊙×≅" symbols = "→!@#$%^&*-+=<>,./?[]{}\\|`~'\"∧∨⊙×≅"
pKeyword :: Text -> Parser () pKeyword :: Text -> Parser ()
pKeyword keyword = void $ lexeme (string keyword <* notFollowedBy alphaNumChar) pKeyword keyword = void $ lexeme (string keyword <* notFollowedBy alphaNumChar)
@ -174,16 +187,11 @@ pSort = lexeme $ pStar <|> pSquare
pOpSection :: Parser IRExpr pOpSection :: Parser IRExpr
pOpSection = lexeme $ parens $ Var <$> pSymbol pOpSection = lexeme $ parens $ Var <$> pSymbol
pProd :: Parser IRExpr
pProd = lexeme $ between (char '{') (char '}') $ do
left <- pIRExpr
_ <- symbol "×"
Prod left <$> pIRExpr
pPair :: Parser IRExpr pPair :: Parser IRExpr
pPair = lexeme $ between (char '<') (char '>') $ do pPair = lexeme $ between (char '(') (char ')') $ do
skipSpace
left <- pIRExpr left <- pIRExpr
_ <- symbol "," _ <- lexeme $ symbol ","
Pair left <$> pIRExpr Pair left <$> pIRExpr
pPi1 :: Parser IRExpr pPi1 :: Parser IRExpr
@ -193,7 +201,7 @@ pPi2 :: Parser IRExpr
pPi2 = lexeme $ symbol "π₂" >> Pi2 <$> pIRExpr pPi2 = lexeme $ symbol "π₂" >> Pi2 <$> pIRExpr
pTerm :: Parser IRExpr pTerm :: Parser IRExpr
pTerm = lexeme $ label "term" $ choice [pSort, pPi1, pPi2, pPureVar, pVar, pProd, pPair, try pOpSection, parens pIRExpr] pTerm = lexeme $ label "term" $ choice [pSort, pPi1, pPi2, pPureVar, pVar, try pPair, try pOpSection, parens pIRExpr]
pInfix :: Parser IRExpr pInfix :: Parser IRExpr
pInfix = parseWithPrec 0 pInfix = parseWithPrec 0
@ -206,7 +214,7 @@ pInfix = parseWithPrec 0
op <- lookAhead pSymbol op <- lookAhead pSymbol
operators <- get operators <- get
case M.lookup op operators of case M.lookup op operators of
Just fixity -> do Just (InfixDef fixity opFun) -> do
let (opPrec, nextPrec) = case fixity of let (opPrec, nextPrec) = case fixity of
InfixL p -> (p, p) InfixL p -> (p, p)
InfixR p -> (p, p + 1) InfixR p -> (p, p + 1)
@ -215,16 +223,19 @@ pInfix = parseWithPrec 0
else do else do
_ <- pSymbol _ <- pSymbol
rhs <- parseWithPrec nextPrec rhs <- parseWithPrec nextPrec
continue prec (App (App (Var op) lhs) rhs) continue prec $ opFun op lhs rhs
Nothing -> fail $ "unknown operator '" ++ toString op ++ "'" Nothing -> fail $ "unknown operator '" ++ toString op ++ "'"
pAppTerm :: Parser IRExpr
pAppTerm = lexeme $ choice [pLAbs, pALAbs, pPAbs, pLet, pInfix]
pIRExpr :: Parser IRExpr pIRExpr :: Parser IRExpr
pIRExpr = lexeme $ do pIRExpr = lexeme $ choice [pLAbs, pALAbs, pPAbs, pLet, pInfix]
e <- pAppTerm
option e $ (symbol "->" <|> symbol "→") >> Pi "" e <$> pIRExpr -- pAppTerm :: Parser IRExpr
-- pAppTerm = lexeme $ choice [pLAbs, pALAbs, pPAbs, pLet, pInfix]
--
-- pIRExpr :: Parser IRExpr
-- pIRExpr = lexeme $ do
-- e <- pAppTerm
-- option e $ (symbol "->" <|> symbol "→") >> Pi "" e <$> pIRExpr
pAscription :: Parser IRExpr pAscription :: Parser IRExpr
pAscription = lexeme $ try $ symbol ":" >> label "type" pIRExpr pAscription = lexeme $ try $ symbol ":" >> label "type" pIRExpr
@ -232,7 +243,7 @@ pAscription = lexeme $ try $ symbol ":" >> label "type" pIRExpr
pAxiom :: Parser IRDef pAxiom :: Parser IRDef
pAxiom = lexeme $ label "axiom" $ do pAxiom = lexeme $ label "axiom" $ do
pKeyword "axiom" pKeyword "axiom"
ident <- pIdentifier ident <- pIdentifier <|> pSymbol
params <- pManyParams params <- pManyParams
ascription <- fmap (flip (foldr mkPi) params) pAscription ascription <- fmap (flip (foldr mkPi) params) pAscription
symbol ";" symbol ";"
@ -265,7 +276,7 @@ pFixityDec = do
, InfixR <$> (lexeme (char 'r') >> lexeme L.decimal) , InfixR <$> (lexeme (char 'r') >> lexeme L.decimal)
] ]
ident <- pSymbol ident <- pSymbol
modify (M.insert ident fixity) modify $ M.insert ident $ InfixDef fixity $ (App .) . App . Var
symbol ";" symbol ";"
pSection :: Parser IRSectionDef pSection :: Parser IRSectionDef
@ -284,7 +295,7 @@ pIRProgram :: Parser IRProgram
pIRProgram = skipSpace >> concat <$> some pIRDef pIRProgram = skipSpace >> concat <$> some pIRDef
parserWrapper :: Parser a -> String -> Text -> Either String a parserWrapper :: Parser a -> String -> Text -> Either String a
parserWrapper p filename input = first errorBundlePretty $ evalState (runParserT p filename input) M.empty parserWrapper p filename input = first errorBundlePretty $ evalState (runParserT p filename input) initialOps
parseProgram :: String -> Text -> Either String IRProgram parseProgram :: String -> Text -> Either String IRProgram
parseProgram = parserWrapper pIRProgram parseProgram = parserWrapper pIRProgram