diff --git a/examples/logic.pg b/examples/logic.pg index c1da0c2..834a3a3 100644 --- a/examples/logic.pg +++ b/examples/logic.pg @@ -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 := ; +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 diff --git a/lib/Parser.hs b/lib/Parser.hs index e0605ef..6b7b303 100644 --- a/lib/Parser.hs +++ b/lib/Parser.hs @@ -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