working on parser
This commit is contained in:
parent
2c1f193d77
commit
1544a33644
GPG key ID:
B8682D8137B70765
2 changed files with 74 additions and 63 deletions
|
|
@ -11,7 +11,7 @@ def false_elim (A : ★) (contra : false) : A := contra A;
|
|||
|
||||
-- True
|
||||
|
||||
def true : ★ := forall (A : ★), A → A;
|
||||
def true : ★ := forall (A : ★), A -> A;
|
||||
|
||||
def true_intro : true := [A : ★][x : A] x;
|
||||
|
||||
|
|
@ -19,10 +19,10 @@ def true_intro : true := [A : ★][x : A] x;
|
|||
|
||||
-- Negation
|
||||
|
||||
def not (A : ★) : ★ := A → false;
|
||||
def not (A : ★) : ★ := A -> false;
|
||||
|
||||
-- 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
|
||||
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
|
||||
|
||||
def ∧ (A B : ★) : ★ := {A × B};
|
||||
def ∧ (A B : ★) : ★ := A × B;
|
||||
infixl 10 ∧;
|
||||
|
||||
-- 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
|
||||
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
|
||||
|
||||
-- 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 ∨;
|
||||
|
||||
-- left introduction rule
|
||||
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
|
||||
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)
|
||||
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;
|
||||
|
||||
-- --------------------------------------------------------------------------------------------------------------
|
||||
|
|
@ -72,14 +72,14 @@ def or_elim (A B C : ★) (ab : A ∨ B) (ha : A → C) (hb : B → C) : C :=
|
|||
-- 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
|
||||
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;
|
||||
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;
|
||||
|
||||
-- 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;
|
||||
|
||||
-- --------------------------------------------------------------------------------------------------------------
|
||||
|
|
@ -87,53 +87,53 @@ def exists_elim (A B : ★) (P : A → ★) (ex_a : exists A P) (h : forall (a :
|
|||
-- Universal
|
||||
|
||||
-- 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
|
||||
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
|
||||
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
|
||||
|
||||
-- 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
|
||||
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
|
||||
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;
|
||||
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;
|
||||
|
||||
-- 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);
|
||||
|
||||
-- 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) :=
|
||||
fun (P : B → ★) (Hfx : P (f x)) =>
|
||||
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)) =>
|
||||
H (fun (a : A) => P (f a)) Hfx;
|
||||
|
||||
-- --------------------------------------------------------------------------------------------------------------
|
||||
|
||||
-- unique existence
|
||||
def exists_uniq (A : ★) (P : A → ★) : ★ :=
|
||||
exists A (fun (x : A) => P x ∧ (forall (y : A), P y → eq A x y));
|
||||
def exists_uniq (A : ★) (P : A -> ★) : ★ :=
|
||||
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 :=
|
||||
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)) =>
|
||||
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));
|
||||
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
|
||||
(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)
|
||||
(and_elim_r (P a) (forall (y : A), P y -> eq A a y) h2));
|
||||
|
||||
def exists_uniq_t (A : ★) : ★ :=
|
||||
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);
|
||||
|
||||
-- --------------------------------------------------------------------------------------------------------------
|
||||
|
|
@ -146,8 +146,8 @@ section Theorems
|
|||
|
||||
-- ~(A ∨ B) => ~A ∧ ~B
|
||||
def de_morgan1 (h : not (A ∨ B)) : not A ∧ not B :=
|
||||
<[a : A] h (or_intro_l A B a)
|
||||
,[b : B] h (or_intro_r A B b)>;
|
||||
( [a : A] h (or_intro_l A B a)
|
||||
, [b : B] h (or_intro_r A B b));
|
||||
|
||||
-- ~A ∧ ~B => ~(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
|
||||
|
||||
-- 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
|
||||
def or_comm (h : A ∨ B) : B ∨ A :=
|
||||
|
|
@ -174,11 +174,11 @@ section Theorems
|
|||
|
||||
-- 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)
|
||||
def and_assoc_r (h : (A ∧ B) ∧ C) : A ∧ (B ∧ C) :=
|
||||
<π₁ (π₁ h), <π₂ (π₁ h), π₂ h>>;
|
||||
(π₁ (π₁ h), (π₂ (π₁ h), π₂ 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
|
||||
def and_distrib_l_or (h : A ∧ (B ∨ C)) : A ∧ B ∨ A ∧ C :=
|
||||
or_elim B C (A ∧ B ∨ A ∧ C) (π₂ h)
|
||||
(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 (b : B) => or_intro_l (A ∧ B) (A ∧ C) (π₁ h, b))
|
||||
(fun (c : C) => or_intro_r (A ∧ B) (A ∧ C) (π₁ h, c));
|
||||
|
||||
-- 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
|
||||
(fun (ab : A ∧ B) => <π₁ ab, or_intro_l B C (π₂ ab)>)
|
||||
(fun (ac : A ∧ C) => <π₁ ac, or_intro_r B C (π₂ ac)>);
|
||||
(fun (ab : A ∧ B) => (π₁ ab, or_intro_l B C (π₂ ab)))
|
||||
(fun (ac : A ∧ C) => (π₁ ac, or_intro_r B C (π₂ ac)));
|
||||
|
||||
-- Thanks Quinn!
|
||||
-- A ∨ B => ~B => A
|
||||
|
|
@ -216,7 +216,7 @@ section Theorems
|
|||
or_elim A B A hor ([a : A] a) ([b : B] nb 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);
|
||||
|
||||
end Theorems
|
||||
|
|
|
|||
|
|
@ -17,12 +17,25 @@ import qualified Text.Megaparsec.Char.Lexer as L
|
|||
newtype TypeError = TE Error
|
||||
deriving (Eq, Ord)
|
||||
|
||||
data InfixDef = InfixDef
|
||||
{ infixFixity :: Fixity
|
||||
, infixOp :: Text -> IRExpr -> IRExpr -> IRExpr
|
||||
}
|
||||
|
||||
data Fixity
|
||||
= InfixL Int
|
||||
| InfixR Int
|
||||
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)
|
||||
|
||||
|
|
@ -46,7 +59,7 @@ symbol :: Text -> Parser ()
|
|||
symbol = void . L.symbol skipSpace
|
||||
|
||||
symbols :: String
|
||||
symbols = "!@#$%^&*-+=<>,./?[]{}\\|`~'\"∧∨⊙×≅"
|
||||
symbols = "→!@#$%^&*-+=<>,./?[]{}\\|`~'\"∧∨⊙×≅"
|
||||
|
||||
pKeyword :: Text -> Parser ()
|
||||
pKeyword keyword = void $ lexeme (string keyword <* notFollowedBy alphaNumChar)
|
||||
|
|
@ -174,16 +187,11 @@ pSort = lexeme $ pStar <|> pSquare
|
|||
pOpSection :: Parser IRExpr
|
||||
pOpSection = lexeme $ parens $ Var <$> pSymbol
|
||||
|
||||
pProd :: Parser IRExpr
|
||||
pProd = lexeme $ between (char '{') (char '}') $ do
|
||||
left <- pIRExpr
|
||||
_ <- symbol "×"
|
||||
Prod left <$> pIRExpr
|
||||
|
||||
pPair :: Parser IRExpr
|
||||
pPair = lexeme $ between (char '<') (char '>') $ do
|
||||
pPair = lexeme $ between (char '(') (char ')') $ do
|
||||
skipSpace
|
||||
left <- pIRExpr
|
||||
_ <- symbol ","
|
||||
_ <- lexeme $ symbol ","
|
||||
Pair left <$> pIRExpr
|
||||
|
||||
pPi1 :: Parser IRExpr
|
||||
|
|
@ -193,7 +201,7 @@ pPi2 :: Parser IRExpr
|
|||
pPi2 = lexeme $ symbol "π₂" >> Pi2 <$> pIRExpr
|
||||
|
||||
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 = parseWithPrec 0
|
||||
|
|
@ -206,7 +214,7 @@ pInfix = parseWithPrec 0
|
|||
op <- lookAhead pSymbol
|
||||
operators <- get
|
||||
case M.lookup op operators of
|
||||
Just fixity -> do
|
||||
Just (InfixDef fixity opFun) -> do
|
||||
let (opPrec, nextPrec) = case fixity of
|
||||
InfixL p -> (p, p)
|
||||
InfixR p -> (p, p + 1)
|
||||
|
|
@ -215,16 +223,19 @@ pInfix = parseWithPrec 0
|
|||
else do
|
||||
_ <- pSymbol
|
||||
rhs <- parseWithPrec nextPrec
|
||||
continue prec (App (App (Var op) lhs) rhs)
|
||||
continue prec $ opFun op lhs rhs
|
||||
Nothing -> fail $ "unknown operator '" ++ toString op ++ "'"
|
||||
|
||||
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
|
||||
pIRExpr = lexeme $ choice [pLAbs, pALAbs, pPAbs, pLet, pInfix]
|
||||
|
||||
-- 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 = lexeme $ try $ symbol ":" >> label "type" pIRExpr
|
||||
|
|
@ -232,7 +243,7 @@ pAscription = lexeme $ try $ symbol ":" >> label "type" pIRExpr
|
|||
pAxiom :: Parser IRDef
|
||||
pAxiom = lexeme $ label "axiom" $ do
|
||||
pKeyword "axiom"
|
||||
ident <- pIdentifier
|
||||
ident <- pIdentifier <|> pSymbol
|
||||
params <- pManyParams
|
||||
ascription <- fmap (flip (foldr mkPi) params) pAscription
|
||||
symbol ";"
|
||||
|
|
@ -265,7 +276,7 @@ pFixityDec = do
|
|||
, InfixR <$> (lexeme (char 'r') >> lexeme L.decimal)
|
||||
]
|
||||
ident <- pSymbol
|
||||
modify (M.insert ident fixity)
|
||||
modify $ M.insert ident $ InfixDef fixity $ (App .) . App . Var
|
||||
symbol ";"
|
||||
|
||||
pSection :: Parser IRSectionDef
|
||||
|
|
@ -284,7 +295,7 @@ pIRProgram :: Parser IRProgram
|
|||
pIRProgram = skipSpace >> concat <$> some pIRDef
|
||||
|
||||
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 = parserWrapper pIRProgram
|
||||
|
|
|
|||
Loading…
Reference in a new issue