From d4cfbd4045917b1e5b4a9205e641cc436b9849fc Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 22 Sep 2023 01:29:23 +0200 Subject: [PATCH 001/133] add @[fail] modifier to declarations - `@[fail] def foo = ...` succeeds if `foo` has some error. - `@[fail "scope"] def foo = ...` succeeds if `foo` has some error containing the word "scope" somewhere - `@[fail] namespace foo { }` works too and the error must be anywhere in the namespace --- lib/Quox/Parser/FromParser.idr | 94 +++++++++++++------ lib/Quox/Parser/FromParser/Error.idr | 10 ++ lib/Quox/Parser/Lexer.idr | 2 +- lib/Quox/Parser/Parser.idr | 21 ++++- lib/Quox/Parser/Syntax.idr | 31 ++++-- .../PrettyPrint/Bernardy/Core/Decorate.idr | 10 ++ 6 files changed, 127 insertions(+), 41 deletions(-) diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 9c2fdcd..53411c7 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -3,6 +3,7 @@ module Quox.Parser.FromParser import public Quox.Parser.FromParser.Error as Quox.Parser.FromParser +import Quox.Pretty import Quox.Parser.Syntax import Quox.Parser.Parser import public Quox.Parser.LoadFile @@ -42,6 +43,35 @@ FromParserIO : List (Type -> Type) FromParserIO = LoadFile :: FromParserPure +export +fromParserPure : NameSuf -> Definitions -> + Eff FromParserPure a -> + Either Error (a, NameSuf, Definitions) +fromParserPure suf defs act = runSTErr $ do + suf <- liftST $ newSTRef suf + defs <- liftST $ newSTRef defs + res <- runEff act $ with Union.(::) + [handleExcept (\e => stLeft e), + handleStateSTRef defs, + handleStateSTRef !(liftST $ newSTRef [<]), + handleStateSTRef suf] + pure (res, !(liftST $ readSTRef suf), !(liftST $ readSTRef defs)) + + +export covering +fromParserIO : (MonadRec io, HasIO io) => + IncludePath -> IORef SeenSet -> + IORef NameSuf -> IORef Definitions -> + Eff FromParserIO a -> io (Either Error a) +fromParserIO inc seen suf defs act = liftIO $ fromIOErr $ do + runEff act $ with Union.(::) + [handleLoadFileIOE LoadError seen inc, + handleExcept (\e => ioLeft e), + handleStateIORef defs, + handleStateIORef !(newIORef [<]), + handleStateIORef suf] + + parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a) (xs : Context' PatVar n) private @@ -318,12 +348,43 @@ fromPDef (MkPDef qty pname ptype pterm defLoc) = do res <- liftTC $ inferC empty sqty elim addDef name gqty res.type term defLoc + +public export +data HasFail = NoFail | AnyFail | FailWith String + +export +hasFail : List PDeclMod -> HasFail +hasFail [] = NoFail +hasFail (PFail str _ :: _) = maybe AnyFail FailWith str + export covering fromPDecl : PDecl -> Eff FromParserPure (List NDefinition) -fromPDecl (PDef def) = singleton <$> fromPDef def -fromPDecl (PNs ns) = + +export covering +fromPDeclBody : PDeclBody -> Eff FromParserPure (List NDefinition) +fromPDeclBody (PDef def) = singleton <$> fromPDef def +fromPDeclBody (PNs ns) = localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls +export covering +expectFail : PDeclBody -> Eff FromParserPure Error +expectFail body = + case fromParserPure !(getAt GEN) !(getAt DEFS) $ fromPDeclBody body of + Left err => pure err + Right _ => throw $ ExpectedFail body.loc + + +fromPDecl (MkPDecl mods decl loc) = case hasFail mods of + NoFail => fromPDeclBody decl + AnyFail => expectFail decl $> [] + FailWith str => do + err <- expectFail decl + let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e + if str `isInfixOf` renderInfinite msg + then pure [] + else throw $ WrongFail str err loc + + mutual export covering loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition) @@ -339,32 +400,3 @@ mutual fromPTopLevel : PTopLevel -> Eff FromParserIO (List NDefinition) fromPTopLevel (PD decl) = lift $ fromPDecl decl fromPTopLevel (PLoad file loc) = loadProcessFile loc file - - -export -fromParserPure : NameSuf -> Definitions -> - Eff FromParserPure a -> - Either Error (a, NameSuf, Definitions) -fromParserPure suf defs act = runSTErr $ do - suf <- liftST $ newSTRef suf - defs <- liftST $ newSTRef defs - res <- runEff act $ with Union.(::) - [handleExcept (\e => stLeft e), - handleStateSTRef defs, - handleStateSTRef !(liftST $ newSTRef [<]), - handleStateSTRef suf] - pure (res, !(liftST $ readSTRef suf), !(liftST $ readSTRef defs)) - - -export covering -fromParserIO : (MonadRec io, HasIO io) => - IncludePath -> IORef SeenSet -> - IORef NameSuf -> IORef Definitions -> - Eff FromParserIO a -> io (Either Error a) -fromParserIO inc seen suf defs act = liftIO $ fromIOErr $ do - runEff act $ with Union.(::) - [handleLoadFileIOE LoadError seen inc, - handleExcept (\e => ioLeft e), - handleStateIORef defs, - handleStateIORef !(newIORef [<]), - handleStateIORef suf] diff --git a/lib/Quox/Parser/FromParser/Error.idr b/lib/Quox/Parser/FromParser/Error.idr index f6c7e53..0803f1f 100644 --- a/lib/Quox/Parser/FromParser/Error.idr +++ b/lib/Quox/Parser/FromParser/Error.idr @@ -30,6 +30,8 @@ data Error = | DisplacedBoundVar Loc PName | WrapTypeError TypeError | LoadError Loc FilePath FileError + | ExpectedFail Loc + | WrongFail String Error Loc | WrapParseError String ParseError @@ -106,5 +108,13 @@ parameters (showContext : Bool) "couldn't load file" <++> text file, text $ show err] + prettyError (ExpectedFail loc) = pure $ + sep [!(prettyLoc loc), "expected error"] + + prettyError (WrongFail str err loc) = pure $ + sep [!(prettyLoc loc), + "wrong error, expected to match", !(hl Tag $ text "\"\{str}\""), + "but got", !(prettyError err)] + prettyError (WrapParseError file err) = prettyParseError file err diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index d4359d4..a01b6b3 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -190,7 +190,7 @@ reserved : List Reserved reserved = [Punc1 '(', Punc1 ')', Punc1 '[', Punc1 ']', Punc1 '{', Punc1 '}', Punc1 ',', Punc1 ';', - Sym1 "@", + Sym1 "@[", Sym1 "@", Sym1 ":", Sym "⇒" `Or` Sym "=>", Sym "→" `Or` Sym "->", diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index ba90021..b57d54d 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -149,6 +149,12 @@ export qty : FileName -> Grammar True PQty qty fname = withLoc fname [|PQ qtyVal|] +export +exactName : String -> Grammar True () +exactName name = terminal "expected '\{name}'" $ \case + Name (MakePName [<] x) => guard $ x == name + _ => Nothing + ||| pattern var (unqualified name or _) export @@ -576,6 +582,15 @@ term fname = lamTerm fname <|> sigmaTerm fname +export +pragma : Grammar True a -> Grammar True a +pragma p = resC "@[" *> p <* mustWork (resC "]") + +export +declMod : FileName -> Grammar True PDeclMod +declMod fname = withLoc fname $ pragma $ + exactName "fail" *> [|PFail $ optional strLit|] + export decl : FileName -> Grammar True PDecl @@ -610,7 +625,11 @@ where nsInner = [] <$ resC "}" <|> [|(assert_total decl fname <* commit) :: assert_total nsInner|] -decl fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|] +export +declBody : FileName -> Grammar True PDeclBody +declBody fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|] + +decl fname = withLoc fname [|MkPDecl (many $ declMod fname) (declBody fname)|] export load : FileName -> Grammar True PTopLevel diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index b95e351..af92211 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -153,6 +153,12 @@ record PDefinition where export Located PDefinition where def.loc = def.loc_ +public export +data PDeclMod = + PFail (Maybe String) Loc +%name PDeclMod mod +%runElab derive "PDeclMod" [Eq, Ord, Show] + mutual public export record PNamespace where @@ -163,18 +169,27 @@ mutual %name PNamespace ns public export - data PDecl = - PDef PDefinition - | PNs PNamespace - %name PDecl decl -%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show] + record PDecl where + constructor MkPDecl + mods : List PDeclMod + decl : PDeclBody + loc_ : Loc + + public export + data PDeclBody = + PDef PDefinition + | PNs PNamespace + %name PDeclBody decl +%runElab deriveMutual ["PNamespace", "PDecl", "PDeclBody"] [Eq, Ord, Show] export Located PNamespace where ns.loc = ns.loc_ +export Located PDecl where decl.loc = decl.loc_ + export -Located PDecl where - (PDef def).loc = def.loc - (PNs ns).loc = ns.loc +Located PDeclBody where + (PDef def).loc = def.loc + (PNs ns).loc = ns.loc public export data PTopLevel = PD PDecl | PLoad String Loc diff --git a/lib/Text/PrettyPrint/Bernardy/Core/Decorate.idr b/lib/Text/PrettyPrint/Bernardy/Core/Decorate.idr index 9e276d6..c986889 100644 --- a/lib/Text/PrettyPrint/Bernardy/Core/Decorate.idr +++ b/lib/Text/PrettyPrint/Bernardy/Core/Decorate.idr @@ -5,6 +5,7 @@ module Text.PrettyPrint.Bernardy.Core.Decorate import public Text.PrettyPrint.Bernardy.Core import Data.DPair +import Data.String public export @@ -43,3 +44,12 @@ decorateLayout h l@(MkLayout content stats) = export decorate : {opts : _} -> Highlight -> Doc opts -> Doc opts decorate h doc = doc >>= \l => pure (decorateLayout h l) + + +||| render a doc with no line breaks at all +export +renderInfinite : Doc opts -> String +renderInfinite (MkDoc (MkLayout content _) _) = unwords content where + unwords : SnocList String -> String + unwords [<] = "" + unwords (xs :< x) = foldMap (++ " ") xs ++ x From 6153b4f7f8e80c8e55019fa3fe48429c12f6cd5d Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 22 Sep 2023 13:48:11 +0200 Subject: [PATCH 002/133] add a couple of failing examples --- examples/fail.quox | 10 ++++++++++ 1 file changed, 10 insertions(+) create mode 100644 examples/fail.quox diff --git a/examples/fail.quox b/examples/fail.quox new file mode 100644 index 0000000..7d3ed8a --- /dev/null +++ b/examples/fail.quox @@ -0,0 +1,10 @@ +@[fail "but cases for"] +def missing-b : {a, b} → {a} = + λ x ⇒ case x return {a} of { 'a ⇒ 'a } + +-- @[fail "duplicate tags"] +-- def repeat-enum-case : {a} → {a} = +-- λ x ⇒ case x return {a} of { 'a ⇒ 'a; 'a ⇒ 'a } + +@[fail "duplicate tags"] +def repeat-enum-type : {a, a} = 'a From 8395bec4cbeb28852e7bdc74ade39a2aa9d65e2e Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 22 Sep 2023 14:03:00 +0200 Subject: [PATCH 003/133] check for duplicate cases in enum matches --- examples/fail.quox | 6 +++--- lib/Quox/Parser/FromParser.idr | 24 +++++++++++++----------- lib/Quox/Parser/FromParser/Error.idr | 13 +++++++++---- 3 files changed, 25 insertions(+), 18 deletions(-) diff --git a/examples/fail.quox b/examples/fail.quox index 7d3ed8a..d879e61 100644 --- a/examples/fail.quox +++ b/examples/fail.quox @@ -2,9 +2,9 @@ def missing-b : {a, b} → {a} = λ x ⇒ case x return {a} of { 'a ⇒ 'a } --- @[fail "duplicate tags"] --- def repeat-enum-case : {a} → {a} = --- λ x ⇒ case x return {a} of { 'a ⇒ 'a; 'a ⇒ 'a } +@[fail "duplicate arms"] +def repeat-enum-case : {a} → {a} = + λ x ⇒ case x return {a} of { 'a ⇒ 'a; 'a ⇒ 'a } @[fail "duplicate tags"] def repeat-enum-type : {a, a} = 'a diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 53411c7..57bf939 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -181,7 +181,7 @@ mutual map E $ CaseEnum (fromPQty pi) <$> fromPTermElim ds ns tag <*> fromPTermTScope ds ns [< r] ret - <*> assert_total fromPTermEnumArms ds ns arms + <*> assert_total fromPTermEnumArms loc ds ns arms <*> pure loc Nat loc => pure $ Nat loc @@ -196,12 +196,11 @@ mutual <*> fromPTermTScope ds ns [< s, ih] suc <*> pure loc - Enum strs loc => - let set = SortedSet.fromList strs in - if length strs == length (SortedSet.toList set) then - pure $ Enum set loc - else - throw $ DuplicatesInEnum loc strs + Enum strs loc => do + let set = SortedSet.fromList strs + unless (length strs == length (SortedSet.toList set)) $ + throw $ DuplicatesInEnumType loc strs + pure $ Enum set loc Tag str loc => pure $ Tag str loc @@ -259,12 +258,15 @@ mutual <*> pure loc private - fromPTermEnumArms : Context' PatVar d -> Context' PatVar n -> + fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n -> List (PTagVal, PTerm) -> Eff FromParserPure (CaseEnumArms d n) - fromPTermEnumArms ds ns = - map SortedMap.fromList . - traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) + fromPTermEnumArms loc ds ns arms = do + res <- SortedMap.fromList <$> + traverse (bitraverse (pure . fromPTagVal) (fromPTermWith ds ns)) arms + unless (length (keys res) == length arms) $ + throw $ DuplicatesInEnumCase loc (map (fromPTagVal . fst) arms) + pure res private fromPTermElim : Context' PatVar d -> Context' PatVar n -> diff --git a/lib/Quox/Parser/FromParser/Error.idr b/lib/Quox/Parser/FromParser/Error.idr index 0803f1f..d561df7 100644 --- a/lib/Quox/Parser/FromParser/Error.idr +++ b/lib/Quox/Parser/FromParser/Error.idr @@ -22,7 +22,8 @@ ParseError = Parser.Error public export data Error = AnnotationNeeded Loc (NameContexts d n) (Term d n) - | DuplicatesInEnum Loc (List TagVal) + | DuplicatesInEnumType Loc (List TagVal) + | DuplicatesInEnumCase Loc (List TagVal) | TermNotInScope Loc Name | DimNotInScope Loc PBaseName | QtyNotGlobal Loc Qty @@ -64,19 +65,23 @@ prettyParseError file (ParseError errs) = traverse (map ("-" <++>) . prettyParseError1 file) (toList errs) -parameters (showContext : Bool) +parameters {opts : LayoutOpts} (showContext : Bool) export - prettyError : {opts : _} -> Error -> Eff Pretty (Doc opts) + prettyError : Error -> Eff Pretty (Doc opts) prettyError (AnnotationNeeded loc ctx tm) = [|vappend (prettyLoc loc) (hangD "type annotation needed on" !(prettyTerm ctx.dnames ctx.tnames tm))|] -- [todo] print the original PTerm instead - prettyError (DuplicatesInEnum loc tags) = + prettyError (DuplicatesInEnumType loc tags) = [|vappend (prettyLoc loc) (hangD "duplicate tags in enum type" !(prettyEnum tags))|] + prettyError (DuplicatesInEnumCase loc tags) = + [|vappend (prettyLoc loc) + (hangD "duplicate arms in enum case" !(prettyEnum tags))|] + prettyError (DimNotInScope loc i) = [|vappend (prettyLoc loc) (pure $ hsep ["dimension", !(hl DVar $ text i), "not in scope"])|] From bcfb0d81b8d940aaeeb05d63c6dd338d84e3ad4f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 22 Sep 2023 18:38:32 +0200 Subject: [PATCH 004/133] update tests --- tests/Tests/Parser.idr | 47 +++++++++++++++++++++++++++--------------- 1 file changed, 30 insertions(+), 17 deletions(-) diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index abd2bc7..47b9cab 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -424,33 +424,46 @@ tests = "parser" :- [ "top level" :- [ parseMatch input "def0 A : ★⁰ = {}; def0 B : ★¹ = A;" - `([PD $ PDef $ MkPDef (PQ Zero _) "A" (Just $ TYPE 0 _) (Enum [] _) _, - PD $ PDef $ MkPDef (PQ Zero _) "B" (Just $ TYPE 1 _) (V "A" {}) _]), + `([PD $ MkPDecl [] + (PDef $ MkPDef (PQ Zero _) "A" (Just $ TYPE 0 _) (Enum [] _) _) _, + PD $ MkPDecl [] + (PDef $ MkPDef (PQ Zero _) "B" (Just $ TYPE 1 _) (V "A" {}) _) _]), parseMatch input "def0 A : ★⁰ = {} def0 B : ★¹ = A" $ - `([PD $ PDef $ MkPDef (PQ Zero _) "A" (Just $ TYPE 0 _) (Enum [] _) _, - PD $ PDef $ MkPDef (PQ Zero _) "B" (Just $ TYPE 1 _) (V "A" {}) _]), + `([PD $ MkPDecl [] + (PDef $ MkPDef (PQ Zero _) "A" (Just $ TYPE 0 _) (Enum [] _) _) _, + PD $ MkPDecl [] + (PDef $ MkPDef (PQ Zero _) "B" (Just $ TYPE 1 _) (V "A" {}) _) _]), note "empty input", parsesAs input "" [], parseFails input ";;;;;;;;;;;;;;;;;;;;;;;;;;", parseMatch input "namespace a {}" - `([PD $ PNs $ MkPNamespace [< "a"] [] _]), + `([PD $ MkPDecl [] (PNs $ MkPNamespace [< "a"] [] _) _]), parseMatch input "namespace a.b.c {}" - `([PD $ PNs $ MkPNamespace [< "a", "b", "c"] [] _]), + `([PD $ MkPDecl [] + (PNs $ MkPNamespace [< "a", "b", "c"] [] _) _]), parseMatch input "namespace a {namespace b {}}" - `([PD $ PNs $ MkPNamespace [< "a"] [PNs $ MkPNamespace [< "b"] [] _] _]), + `([PD (MkPDecl [] + (PNs $ MkPNamespace [< "a"] + [MkPDecl [] (PNs $ MkPNamespace [< "b"] [] _) _] _) _)]), parseMatch input "namespace a {def x = 't ∷ {t}}" - `([PD $ PNs $ MkPNamespace [< "a"] - [PDef $ MkPDef (PQ Any _) "x" Nothing - (Ann (Tag "t" _) (Enum ["t"] _) _) _] _]), + `([PD (MkPDecl [] + (PNs $ MkPNamespace [< "a"] + [MkPDecl [] + (PDef $ MkPDef (PQ Any _) "x" Nothing + (Ann (Tag "t" _) (Enum ["t"] _) _) _) _] _) _)]), parseMatch input "namespace a {def x = 't ∷ {t}} def y = a.x" - `([PD $ PNs $ MkPNamespace [< "a"] - [PDef $ MkPDef (PQ Any _) "x" Nothing - (Ann (Tag "t" _) (Enum ["t"] _) _) _] _, - PD $ PDef $ MkPDef (PQ Any _) "y" Nothing - (V (MakePName [< "a"] "x") {}) _]), + `([PD (MkPDecl [] + (PNs $ MkPNamespace [< "a"] + [MkPDecl [] + (PDef $ MkPDef (PQ Any _) "x" Nothing + (Ann (Tag "t" _) (Enum ["t"] _) _) _) _] _) _), + PD (MkPDecl [] + (PDef $ MkPDef (PQ Any _) "y" Nothing + (V (MakePName [< "a"] "x") Nothing _) _) _)]), parseMatch input #" load "a.quox"; def b = a.b "# `([PLoad "a.quox" _, - PD $ PDef $ MkPDef (PQ Any _) "b" Nothing - (V (MakePName [< "a"] "b") {}) _]) + PD (MkPDecl [] + (PDef $ MkPDef (PQ Any _) "b" Nothing + (V (MakePName [< "a"] "b") Nothing _) _) _)]) ] ] From d4de74eab63136820b18da5e8b2654e7c29559c2 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 22 Sep 2023 18:38:40 +0200 Subject: [PATCH 005/133] change it to #[..] since # is also reserved --- examples/fail.quox | 6 +++--- lib/Quox/Parser/Lexer.idr | 27 +++++++++++++-------------- lib/Quox/Parser/Parser.idr | 2 +- 3 files changed, 17 insertions(+), 18 deletions(-) diff --git a/examples/fail.quox b/examples/fail.quox index d879e61..a3edac8 100644 --- a/examples/fail.quox +++ b/examples/fail.quox @@ -1,10 +1,10 @@ -@[fail "but cases for"] +#[fail "but cases for"] def missing-b : {a, b} → {a} = λ x ⇒ case x return {a} of { 'a ⇒ 'a } -@[fail "duplicate arms"] +#[fail "duplicate arms"] def repeat-enum-case : {a} → {a} = λ x ⇒ case x return {a} of { 'a ⇒ 'a; 'a ⇒ 'a } -@[fail "duplicate tags"] +#[fail "duplicate tags"] def repeat-enum-type : {a, a} = 'a diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index a01b6b3..57b7e96 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -134,9 +134,11 @@ namespace Reserved ||| description of a reserved symbol ||| @ Word a reserved word (must not be followed by letters, digits, etc) ||| @ Sym a reserved symbol (must not be followed by symbolic chars) - ||| @ Punc a character that doesn't show up in names (brackets, etc) + ||| @ Punc a character that doesn't show up in names (brackets, etc); + ||| also a sequence ending in one of those, like `#[`, since the + ||| difference relates to lookahead public export - data Reserved1 = Word String | Sym String | Punc Char + data Reserved1 = Word String | Sym String | Punc String %runElab derive "Reserved1" [Eq, Ord, Show] ||| description of a token that might have unicode & ascii-only aliases @@ -145,17 +147,14 @@ namespace Reserved %runElab derive "Reserved" [Eq, Ord, Show] public export - Sym1, Word1 : String -> Reserved - Sym1 = Only . Sym + Sym1, Word1, Punc1 : String -> Reserved + Sym1 = Only . Sym Word1 = Only . Word - - public export - Punc1 : Char -> Reserved Punc1 = Only . Punc public export resString1 : Reserved1 -> String -resString1 (Punc x) = singleton x +resString1 (Punc x) = x resString1 (Word w) = w resString1 (Sym s) = s @@ -171,8 +170,8 @@ resTokenizer1 : Reserved1 -> String -> Tokenizer TokenW resTokenizer1 r str = let res : String -> Token := const $ Reserved str in case r of Word w => match (exact w <+> reject idContEnd) res - Sym s => match (exact s <+> reject symCont) res - Punc x => match (is x) res + Sym s => match (exact s <+> reject symCont) res + Punc x => match (exact x) res ||| match a reserved token export @@ -188,16 +187,16 @@ resTokenizer (r `Or` s) = public export reserved : List Reserved reserved = - [Punc1 '(', Punc1 ')', Punc1 '[', Punc1 ']', Punc1 '{', Punc1 '}', - Punc1 ',', Punc1 ';', - Sym1 "@[", Sym1 "@", + [Punc1 "(", Punc1 ")", Punc1 "[", Punc1 "]", Punc1 "{", Punc1 "}", + Punc1 ",", Punc1 ";", Punc1 "#[", + Sym1 "@", Sym1 ":", Sym "⇒" `Or` Sym "=>", Sym "→" `Or` Sym "->", Sym "×" `Or` Sym "**", Sym "≡" `Or` Sym "==", Sym "∷" `Or` Sym "::", - Punc1 '.', + Punc1 ".", Word1 "case", Word1 "case0", Word1 "case1", Word "caseω" `Or` Word "case#", diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index b57d54d..8fb0dcd 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -584,7 +584,7 @@ term fname = lamTerm fname export pragma : Grammar True a -> Grammar True a -pragma p = resC "@[" *> p <* mustWork (resC "]") +pragma p = resC "#[" *> p <* mustWork (resC "]") export declMod : FileName -> Grammar True PDeclMod From f04c4619efd89b083fe7cdb123d7adca411d3faa Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 24 Sep 2023 17:36:20 +0200 Subject: [PATCH 006/133] =?UTF-8?q?detect=20reserved=20words=20inside=20na?= =?UTF-8?q?mes=20like=20'a.=CE=BB.b'?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/Quox/Parser/FromParser/Error.idr | 8 +- lib/Quox/Parser/Lexer.idr | 115 ++++++++++++++++++--------- tests/Tests/Lexer.idr | 16 ++-- 3 files changed, 95 insertions(+), 44 deletions(-) diff --git a/lib/Quox/Parser/FromParser/Error.idr b/lib/Quox/Parser/FromParser/Error.idr index d561df7..301ff59 100644 --- a/lib/Quox/Parser/FromParser/Error.idr +++ b/lib/Quox/Parser/FromParser/Error.idr @@ -39,12 +39,14 @@ data Error = export prettyLexError : {opts : _} -> String -> LexError -> Eff Pretty (Doc opts) prettyLexError file (Err reason line col char) = do - let loc = makeLoc file (MkBounds line col line col) reason <- case reason of - EndInput => pure "unexpected end of input" - NoRuleApply => pure $ text "unrecognised character: \{show char}" + Other msg => pure $ text msg + NoRuleApply => case char of + Just char => pure $ text "unrecognised character: \{show char}" + Nothing => pure $ text "unexpected end of input" ComposeNotClosing (sl, sc) (el, ec) => pure $ hsep ["unterminated token at", !(prettyBounds (MkBounds sl sc el ec))] + let loc = makeLoc file (MkBounds line col line col) pure $ vappend !(prettyLoc loc) reason export diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index 57b7e96..eb71ad9 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -34,16 +34,27 @@ data Token = | Sup Nat %runElab derive "Token" [Eq, Ord, Show] --- token or whitespace +||| token or whitespace +||| @ Skip whitespace, comments, etc +||| @ Invalid a token which failed a post-lexer check +||| (e.g. a qualified name containing a keyword) +||| @ T a well formed token public export -0 TokenW : Type -TokenW = Maybe Token +data ExtToken = Skip | Invalid String String | T Token +%runElab derive "ExtToken" [Eq, Ord, Show] +public export +data ErrorReason = + NoRuleApply + | ComposeNotClosing (Int, Int) (Int, Int) + | Other String +%runElab derive "ErrorReason" [Eq, Ord, Show] + public export record Error where constructor Err - reason : StopReason + reason : ErrorReason line, col : Int ||| `Nothing` if the error is at the end of the input char : Maybe Char @@ -52,19 +63,14 @@ record Error where private -skip : Lexer -> Tokenizer TokenW -skip t = match t $ const Nothing +skip : Lexer -> Tokenizer ExtToken +skip t = match t $ const Skip private -match : Lexer -> (String -> Token) -> Tokenizer TokenW -match t f = Tokenizer.match t (Just . f) -%hide Tokenizer.match +tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken +tmatch t f = match t (T . f) -private -name : Tokenizer TokenW -name = match name $ Name . fromListP . split (== '.') . normalizeNfc - ||| [todo] escapes other than `\"` and (accidentally) `\\` export fromStringLit : String -> String @@ -76,17 +82,17 @@ fromStringLit = pack . go . unpack . drop 1 . dropLast 1 where go (c :: cs) = c :: go cs private -string : Tokenizer TokenW -string = match stringLit (Str . fromStringLit) +string : Tokenizer ExtToken +string = tmatch stringLit (Str . fromStringLit) private -nat : Tokenizer TokenW -nat = match (some (range '0' '9')) (Nat . cast) +nat : Tokenizer ExtToken +nat = tmatch (some (range '0' '9')) (Nat . cast) private -tag : Tokenizer TokenW -tag = match (is '\'' <+> name) (Tag . drop 1) - <|> match (is '\'' <+> stringLit) (Tag . fromStringLit . drop 1) +tag : Tokenizer ExtToken +tag = tmatch (is '\'' <+> name) (Tag . drop 1) + <|> tmatch (is '\'' <+> stringLit) (Tag . fromStringLit . drop 1) @@ -112,17 +118,17 @@ supToNat = cast . pack . map fromSup . unpack -- ★0, Type0. base ★/Type is a Reserved private -universe : Tokenizer TokenW +universe : Tokenizer ExtToken universe = universeWith "★" <|> universeWith "Type" where - universeWith : String -> Tokenizer TokenW + universeWith : String -> Tokenizer ExtToken universeWith pfx = let len = length pfx in - match (exact pfx <+> digits) (TYPE . cast . drop len) + tmatch (exact pfx <+> digits) (TYPE . cast . drop len) private -sup : Tokenizer TokenW -sup = match (some $ pred isSupDigit) (Sup . supToNat) - <|> match (is '^' <+> digits) (Sup . cast . drop 1) +sup : Tokenizer ExtToken +sup = tmatch (some $ pred isSupDigit) (Sup . supToNat) + <|> tmatch (is '^' <+> digits) (Sup . cast . drop 1) private %inline @@ -165,17 +171,23 @@ resString : Reserved -> String resString (Only r) = resString1 r resString (r `Or` _) = resString1 r +||| return both representative strings for a token description +public export +resString2 : Reserved -> List String +resString2 (Only r) = [resString1 r] +resString2 (r `Or` s) = [resString1 r, resString1 s] + private -resTokenizer1 : Reserved1 -> String -> Tokenizer TokenW +resTokenizer1 : Reserved1 -> String -> Tokenizer ExtToken resTokenizer1 r str = let res : String -> Token := const $ Reserved str in - case r of Word w => match (exact w <+> reject idContEnd) res - Sym s => match (exact s <+> reject symCont) res - Punc x => match (exact x) res + case r of Word w => tmatch (exact w <+> reject idContEnd) res + Sym s => tmatch (exact s <+> reject symCont) res + Punc x => tmatch (exact x) res ||| match a reserved token export -resTokenizer : Reserved -> Tokenizer TokenW +resTokenizer : Reserved -> Tokenizer ExtToken resTokenizer (Only r) = resTokenizer1 r (resString1 r) resTokenizer (r `Or` s) = resTokenizer1 r (resString1 r) <|> resTokenizer1 s (resString1 r) @@ -219,14 +231,31 @@ reserved = Word1 "load", Word1 "namespace"] +public export +reservedStrings : List String +reservedStrings = map resString reserved + +public export +allReservedStrings : List String +allReservedStrings = foldMap resString2 reserved + ||| `IsReserved str` is true if `Reserved str` might actually show up in ||| the token stream public export IsReserved : String -> Type -IsReserved str = str `Elem` map resString reserved +IsReserved str = So (str `elem` allReservedStrings) + +private +name : Tokenizer ExtToken +name = + match name $ \str => + let parts = split (== '.') $ normalizeNfc str in + case find (`elem` allReservedStrings) (toList parts) of + Nothing => T $ Name $ fromListP parts + Just w => Invalid "reserved word '\{w}' inside name \{str}" str export -tokens : Tokenizer TokenW +tokens : Tokenizer ExtToken tokens = choice $ map skip [pred isWhitespace, lineComment (exact "--" <+> reject symCont), @@ -235,10 +264,24 @@ tokens = choice $ map resTokenizer reserved <+> [sup, nat, string, tag, name] +export +check : Alternative f => + WithBounds ExtToken -> Either Error (f (WithBounds Token)) +check (MkBounded val irr bounds@(MkBounds line col _ _)) = case val of + Skip => Right empty + T tok => Right $ pure $ MkBounded tok irr bounds + Invalid msg tok => Left $ Err (Other msg) line col (index 0 tok) + +export +toErrorReason : StopReason -> Maybe ErrorReason +toErrorReason EndInput = Nothing +toErrorReason NoRuleApply = Just NoRuleApply +toErrorReason (ComposeNotClosing s e) = Just $ ComposeNotClosing s e + export lex : String -> Either Error (List (WithBounds Token)) lex str = let (res, reason, line, col, str) = lex tokens str in - case reason of - EndInput => Right $ mapMaybe sequence res - _ => Left $ Err {reason, line, col, char = index 0 str} + case toErrorReason reason of + Nothing => concatMap check res @{MonoidApplicative} + Just e => Left $ Err {reason = e, line, col, char = index 0 str} diff --git a/tests/Tests/Lexer.idr b/tests/Tests/Lexer.idr index 7823d5d..910a434 100644 --- a/tests/Tests/Lexer.idr +++ b/tests/Tests/Lexer.idr @@ -47,7 +47,12 @@ tests = "lexer" :- [ lexes " " [], lexes "-- line comment" [], lexes "name -- line comment" [Name "name"], - lexes "-- line comment\nnameBetween -- and another" [Name "nameBetween"], + lexes + """ + -- line comment + nameBetween -- and another + """ + [Name "nameBetween"], lexes "{- block comment -}" [], lexes "{- {- nested -} block comment -}" [] ], @@ -70,13 +75,14 @@ tests = "lexer" :- [ lexes "normalïse" [Name "normalïse"], -- ↑ replace i + combining ¨ with precomposed ï lexes "map#" [Name "map#"], + lexes "map#[" [Name "map#", Reserved "["], -- don't actually do this + lexes "map #[" [Name "map", Reserved "#["], lexes "write!" [Name "write!"], lexes "uhh??!?!?!?" [Name "uhh??!?!?!?"], - todo "check for reserved words in a qname", - skip $ - lexes "abc.fun.def" - [Name "abc", Reserved ".", Reserved "λ", Reserved ".", Name "def"], + lexFail "abc.fun.ghi", + lexFail "abc.λ.ghi", + lexFail "abc.ω.ghi", lexes "+" [Name "+"], lexes "*" [Name "*"], From 9ecaaf72bd5443136d4c0827e95f3338ebd0c2e8 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 21 Oct 2023 20:46:35 +0200 Subject: [PATCH 007/133] bump pack collection --- pack.toml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pack.toml b/pack.toml index a68a382..9843384 100644 --- a/pack.toml +++ b/pack.toml @@ -1,4 +1,4 @@ -collection = "nightly-230916" +collection = "nightly-231020" [custom.all.tap] type = "git" From 69f032584e85c715641ee617578366c741e8f183 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 2 Nov 2023 18:14:28 +0100 Subject: [PATCH 008/133] fix constructor name in comment --- lib/Quox/Parser/Lexer.idr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index eb71ad9..3780809 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -19,7 +19,7 @@ import Derive.Prelude ||| @ Reserved reserved token ||| @ Name name, possibly qualified ||| @ Nat nat literal -||| @ String string literal +||| @ Str string literal ||| @ Tag tag literal ||| @ TYPE "Type" or "★" with ascii nat directly after ||| @ Sup superscript or ^ number (displacement, or universe for ★) From bf605486f0bce8e816aa203e7bdadc1af444e47c Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 17:42:31 +0100 Subject: [PATCH 009/133] example updates MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - misc.All doesn't need to be a ★¹ - add pair.map-fst and pair.map-snd - add bool.dup! - tweak quantities in eta.from-false - add fail.quox to all.quox - add qty.quox --- examples/all.quox | 2 ++ examples/bool.quox | 9 ++++-- examples/eta.quox | 4 +-- examples/misc.quox | 2 +- examples/pair.quox | 10 +++++-- examples/qty.quox | 73 ++++++++++++++++++++++++++++++++++++++++++++++ 6 files changed, 93 insertions(+), 7 deletions(-) create mode 100644 examples/qty.quox diff --git a/examples/all.quox b/examples/all.quox index e95a025..925429c 100644 --- a/examples/all.quox +++ b/examples/all.quox @@ -6,3 +6,5 @@ load "nat.quox" load "pair.quox" load "list.quox" load "eta.quox" +load "fail.quox" +load "qty.quox" diff --git a/examples/bool.quox b/examples/bool.quox index 055e28f..a6f8140 100644 --- a/examples/bool.quox +++ b/examples/bool.quox @@ -18,8 +18,13 @@ def if2 : 0.(A B : ★) → (b : Bool) → ω.A → ω.B → if¹ ★ b A B = def0 T : Bool → ★ = λ b ⇒ if¹ ★ b True False; -def boolω : Bool → [ω.Bool] = - λ b ⇒ if [ω.Bool] b ['true] ['false]; +def dup! : (b : Bool) → [ω. Sing Bool b] = + λ b ⇒ if-dep (λ b ⇒ [ω. Sing Bool b]) b + [('true, [δ _ ⇒ 'true])] + [('false, [δ _ ⇒ 'false])]; + +def dup : Bool → [ω. Bool] = + λ b ⇒ appω (Sing Bool b) Bool (sing.val Bool b) (dup! b); def true-not-false : Not ('true ≡ 'false : Bool) = λ eq ⇒ coe (𝑖 ⇒ T (eq @𝑖)) 'true; diff --git a/examples/eta.quox b/examples/eta.quox index 817bbc3..67d1a8b 100644 --- a/examples/eta.quox +++ b/examples/eta.quox @@ -18,8 +18,8 @@ def0 pair : (A : ★) → (B : A → ★) → (P : Σ A B → ★) → (e : Σ A λ A B P e p ⇒ p -- not exactly η, but kinda related -def0 from-false : (A : ★) → (P : (False → A) → ★) → (f : False → A) → - P (λ x ⇒ void A x) → P f = +def0 from-false : (A : ★) → (P : (0.False → A) → ★) → (f : 0.False → A) → + P (void A) → P f = λ A P f p ⇒ p } diff --git a/examples/misc.quox b/examples/misc.quox index defcffd..d1b3731 100644 --- a/examples/misc.quox +++ b/examples/misc.quox @@ -6,7 +6,7 @@ def0 Not : ★ → ★ = λ A ⇒ ω.A → False def void : 0.(A : ★) → 0.False → A = λ A v ⇒ case0 v return A of { } -def0 All : (A : ★) → (0.A → ★) → ★¹ = +def0 All : (A : ★) → (0.A → ★) → ★ = λ A P ⇒ (x : A) → P x def0 cong : diff --git a/examples/pair.quox b/examples/pair.quox index fd6ec06..4bf33c6 100644 --- a/examples/pair.quox +++ b/examples/pair.quox @@ -28,7 +28,7 @@ def curry : λ A B C f x y ⇒ f (x, y); def curry' : - 0.(A B C : ★) → ((A × B) → C) → A → B → C = + 0.(A B C : ★) → (A × B → C) → A → B → C = λ A B C ⇒ curry A (λ _ ⇒ B) (λ _ ⇒ C); def0 fst-snd : @@ -54,13 +54,19 @@ def map : 0.(A A' : ★) → 0.(B : A → ★) → 0.(B' : A' → ★) → (f : A → A') → (g : 0.(x : A) → (B x) → B' (f x)) → - (Σ A B) → Σ A' B' = + Σ A B → Σ A' B' = λ A A' B B' f g p ⇒ case p return Σ A' B' of { (x, y) ⇒ (f x, g x y) }; def map' : 0.(A A' B B' : ★) → (A → A') → (B → B') → (A × B) → A' × B' = λ A A' B B' f g ⇒ map A A' (λ _ ⇒ B) (λ _ ⇒ B') f (λ _ ⇒ g); +def map-fst : 0.(A A' B : ★) → (A → A') → A × B → A' × B = + λ A A' B f ⇒ map' A A' B B f (λ x ⇒ x); + +def map-snd : 0.(A B B' : ★) → (B → B') → A × B → A × B' = + λ A B B' f ⇒ map' A A B B' (λ x ⇒ x) f; + } def0 Σ = pair.Σ; diff --git a/examples/qty.quox b/examples/qty.quox new file mode 100644 index 0000000..26a1a8b --- /dev/null +++ b/examples/qty.quox @@ -0,0 +1,73 @@ +def0 Qty : ★ = {"zero", one, any} + +def dup : Qty → [ω.Qty] = + λ π ⇒ case π return [ω.Qty] of { + 'zero ⇒ ['zero]; + 'one ⇒ ['one]; + 'any ⇒ ['any]; + } + +def drop : 0.(A : ★) → Qty → A → A = + λ A π x ⇒ case π return A of { + 'zero ⇒ x; + 'one ⇒ x; + 'any ⇒ x; + } + +def if-zero : 0.(A : ★) → Qty → ω.A → ω.A → A = + λ A π z nz ⇒ + case π return A of { 'zero ⇒ z; 'one ⇒ nz; 'any ⇒ nz } + +def plus : Qty → Qty → Qty = + λ π ρ ⇒ + case π return Qty of { + 'zero ⇒ ρ; + 'one ⇒ if-zero Qty ρ 'one 'any; + 'any ⇒ drop Qty ρ 'any; + } + +def times : Qty → Qty → Qty = + λ π ρ ⇒ + case π return Qty of { + 'zero ⇒ drop Qty ρ 'zero; + 'one ⇒ ρ; + 'any ⇒ if-zero Qty ρ 'zero 'any; + } + +def0 FUN : Qty → (A : ★) → (A → ★) → ★ = + λ π A B ⇒ + case π return ★ of { + 'zero ⇒ 0.(x : A) → B x; + 'one ⇒ 1.(x : A) → B x; + 'any ⇒ ω.(x : A) → B x; + } + +def0 Fun : Qty → ★ → ★ → ★ = + λ π A B ⇒ FUN π A (λ _ ⇒ B) + +def0 Box : Qty → ★ → ★ = + λ π A ⇒ + case π return ★ of { + 'zero ⇒ [0.A]; + 'one ⇒ [1.A]; + 'any ⇒ [ω.A]; + } + +def0 unbox : (π : Qty) → (A : ★) → Box π A → A = + λ π A ⇒ + case π return π' ⇒ Box π' A → A of { + 'zero ⇒ λ x ⇒ case x return A of { [x] ⇒ x }; + 'one ⇒ λ x ⇒ case x return A of { [x] ⇒ x }; + 'any ⇒ λ x ⇒ case x return A of { [x] ⇒ x }; + } + +def apply : (π : Qty) → 0.(A : ★) → 0.(B : A → ★) → + FUN π A B → (x : Box π A) → B (unbox π A x) = + λ π A B ⇒ + case π + return π' ⇒ FUN π' A B → (x : Box π' A) → B (unbox π' A x) + of { + 'zero ⇒ λ f x ⇒ case x return x' ⇒ B (unbox 'zero A x') of { [x] ⇒ f x }; + 'one ⇒ λ f x ⇒ case x return x' ⇒ B (unbox 'one A x') of { [x] ⇒ f x }; + 'any ⇒ λ f x ⇒ case x return x' ⇒ B (unbox 'any A x') of { [x] ⇒ f x }; + } From be8797a3ef5cbad12a6c89f2407ebad25acda25e Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Wed, 20 Sep 2023 22:09:08 +0200 Subject: [PATCH 010/133] =?UTF-8?q?untyped=20=CE=BB=20calculus=20syntax?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/Quox/Untyped/Syntax.idr | 129 ++++++++++++++++++++++++++++++++++++ lib/quox-lib.ipkg | 3 +- 2 files changed, 131 insertions(+), 1 deletion(-) create mode 100644 lib/Quox/Untyped/Syntax.idr diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr new file mode 100644 index 0000000..14519fc --- /dev/null +++ b/lib/Quox/Untyped/Syntax.idr @@ -0,0 +1,129 @@ +module Quox.Untyped.Syntax + +import Quox.Var +import Quox.Context +import Quox.Name +import Quox.Pretty + +import Data.Vect +import Data.DPair +import Data.SortedMap +import Derive.Prelude +%hide TT.Name + +%default total +%language ElabReflection + + +public export +data Binder = Bind BaseName +Eq Binder where _ == _ = True +Ord Binder where compare _ _ = EQ +%runElab derive "Binder" [Show] + +public export +data Term : Nat -> Type where + F : (x : Name) -> Term n + B : (i : Var n) -> Term n + + Lam : (x : Binder) -> (body : Term (S n)) -> Term n + App : (fun, arg : Term n) -> Term n + + Pair : (fst, snd : Term n) -> Term n + Fst : (pair : Term n) -> Term n + Snd : (pair : Term n) -> Term n + + Tag : (tag : String) -> Term n + CaseEnum : (tag : Term n) -> (cases : List (String, Term n)) -> Term n + + Zero : Term n + Succ : (nat : Term n) -> Term n + CaseNat : (nat : Term n) -> + (zer : Term n) -> + (x, ih : Binder) -> (suc : Term (2 + n)) -> + Term n + + ||| replacement for terms of type [0.A], for now + ErasedBox : Term n +%name Term s, t, u +%runElab deriveIndexed "Term" [Eq, Ord, Show] + + +public export +0 Definitions : Type +Definitions = SortedMap Name $ Term 0 + + +parameters {opts : LayoutOpts} + export + prettyBind : Binder -> Eff Pretty (Doc opts) + prettyBind (Bind x) = hl TVar $ text $ baseStr x + + export + prettyTerm : Context' Binder n -> Term n -> Eff Pretty (Doc opts) + + export + prettyArg : Context' Binder n -> Term n -> Eff Pretty (Doc opts) + prettyArg xs arg = withPrec Arg $ prettyTerm xs arg + + export + prettyApp' : Context' Binder n -> Doc opts -> Term n -> Eff Pretty (Doc opts) + prettyApp' xs fun arg = + parensIfM App =<< do + arg <- prettyArg xs arg + pure $ sep [fun, arg] + + export + prettyApp : Context' Binder n -> Term n -> Term n -> Eff Pretty (Doc opts) + prettyApp xs fun arg = prettyApp' xs !(prettyArg xs fun) arg + + public export + PrettyCaseArm : Nat -> Type + PrettyCaseArm n = Exists $ \s => (Vect s Binder, Term (s + n)) + + export %inline + caseArm : Vect s Binder -> Term (s + n) -> PrettyCaseArm n + caseArm xs t = Evidence _ (xs, t) + + export + prettyCase : Context' Binder n -> + (a -> Eff Pretty (Doc opts)) -> + Term n -> List (a, PrettyCaseArm n) -> + Eff Pretty (Doc opts) + prettyCase xs f head arms = + parensIfM Outer =<< Prelude.do + header <- hsep <$> sequence [caseD, prettyTerm xs head, ofD] + cases <- for arms $ \(lhs, (Evidence s (ys, rhs))) => do + lhs <- hsep <$> sequence [f lhs, darrowD] + rhs <- withPrec Outer $ prettyTerm (xs <>< ys) rhs + hangDSingle lhs rhs + body <- braces $ separateLoose !semiD cases + pure $ sep [header, body] + + prettyTerm _ (F x) = prettyFree x + prettyTerm xs (B i) = prettyBind $ xs !!! i + prettyTerm xs (Lam x body) = + parensIfM Outer =<< do + header <- hsep <$> sequence [lamD, prettyBind x, darrowD] + body <- withPrec Outer $ prettyTerm (xs :< x) body + hangDSingle header body + prettyTerm xs (App fun arg) = prettyApp xs fun arg + prettyTerm xs (Pair fst snd) = + parens =<< separateTight !commaD <$> + sequence {t = List} [prettyTerm xs fst, prettyTerm xs snd] + prettyTerm xs (Fst pair) = prettyApp' xs !fstD pair + prettyTerm xs (Snd pair) = prettyApp' xs !sndD pair + prettyTerm xs (Tag tag) = prettyTag tag + prettyTerm xs (CaseEnum tag cases) = assert_total + prettyCase xs prettyTag tag $ map (mapSnd $ caseArm []) cases + prettyTerm xs Zero = zeroD + prettyTerm xs (Succ nat) = prettyApp' xs !succD nat + prettyTerm xs (CaseNat nat zer x ih suc) = assert_total + prettyCase xs pure nat + [(!zeroD, caseArm [] zer), + (!sucPat, caseArm [x, ih] suc)] + where + sucPat = separateTight {t = List} !commaD <$> + sequence [[|succD <++> prettyBind x|], prettyBind ih] + prettyTerm _ ErasedBox = + hl Syntax =<< ifUnicode "⌷" "[]" diff --git a/lib/quox-lib.ipkg b/lib/quox-lib.ipkg index 7e0af1b..26d4b6f 100644 --- a/lib/quox-lib.ipkg +++ b/lib/quox-lib.ipkg @@ -56,4 +56,5 @@ modules = Quox.Parser.LoadFile, Quox.Parser.FromParser, Quox.Parser.FromParser.Error, - Quox.Parser + Quox.Parser, + Quox.Untyped.Syntax From 6896c8fcc4c5dca92018eb92e76b3ee1112664cf Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 30 Sep 2023 18:31:23 +0200 Subject: [PATCH 011/133] =?UTF-8?q?rename=20SQtys=20to=20sg=20(=CF=83)?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/Quox/Whnf/ComputeElimType.idr | 40 ++++++++++++++++--------------- 1 file changed, 21 insertions(+), 19 deletions(-) diff --git a/lib/Quox/Whnf/ComputeElimType.idr b/lib/Quox/Whnf/ComputeElimType.idr index 1f299b9..4bb3727 100644 --- a/lib/Quox/Whnf/ComputeElimType.idr +++ b/lib/Quox/Whnf/ComputeElimType.idr @@ -11,24 +11,26 @@ import Quox.Displace ||| - assumes the elim is already typechecked ||| - the return value is not reduced export covering -computeElimType : CanWhnf Term Interface.isRedexT => - CanWhnf Elim Interface.isRedexE => - {d, n : Nat} -> - (defs : Definitions) -> WhnfContext d n -> (pi : SQty) -> - (e : Elim d n) -> (0 ne : No (isRedexE defs pi e)) => - Eff Whnf (Term d n) +computeElimType : + CanWhnf Term Interface.isRedexT => + CanWhnf Elim Interface.isRedexE => + {d, n : Nat} -> + (defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) -> + (e : Elim d n) -> (0 ne : No (isRedexE defs sg e)) => + Eff Whnf (Term d n) ||| computes a type and then reduces it to whnf export covering -computeWhnfElimType0 : CanWhnf Term Interface.isRedexT => - CanWhnf Elim Interface.isRedexE => - {d, n : Nat} -> - (defs : Definitions) -> WhnfContext d n -> (pi : SQty) -> - (e : Elim d n) -> (0 ne : No (isRedexE defs pi e)) => - Eff Whnf (Term d n) +computeWhnfElimType0 : + CanWhnf Term Interface.isRedexT => + CanWhnf Elim Interface.isRedexE => + {d, n : Nat} -> + (defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) -> + (e : Elim d n) -> (0 ne : No (isRedexE defs sg e)) => + Eff Whnf (Term d n) -computeElimType defs ctx pi e {ne} = +computeElimType defs ctx sg e = case e of F x u loc => do let Just def = lookup x defs @@ -39,7 +41,7 @@ computeElimType defs ctx pi e {ne} = pure $ ctx.tctx !! i App f s loc => - case !(computeWhnfElimType0 defs ctx pi f {ne = noOr1 ne}) of + case !(computeWhnfElimType0 defs ctx sg f {ne = noOr1 ne}) of Pi {arg, res, _} => pure $ sub1 res $ Ann s arg loc ty => throw $ ExpectedPi loc ctx.names ty @@ -47,12 +49,12 @@ computeElimType defs ctx pi e {ne} = pure $ sub1 ret pair Fst pair loc => - case !(computeWhnfElimType0 defs ctx pi pair {ne = noOr1 ne}) of + case !(computeWhnfElimType0 defs ctx sg pair {ne = noOr1 ne}) of Sig {fst, _} => pure fst ty => throw $ ExpectedSig loc ctx.names ty Snd pair loc => - case !(computeWhnfElimType0 defs ctx pi pair {ne = noOr1 ne}) of + case !(computeWhnfElimType0 defs ctx sg pair {ne = noOr1 ne}) of Sig {snd, _} => pure $ sub1 snd $ Fst pair loc ty => throw $ ExpectedSig loc ctx.names ty @@ -66,7 +68,7 @@ computeElimType defs ctx pi e {ne} = pure $ sub1 ret box DApp {fun = f, arg = p, loc} => - case !(computeWhnfElimType0 defs ctx pi f {ne = noOr1 ne}) of + case !(computeWhnfElimType0 defs ctx sg f {ne = noOr1 ne}) of Eq {ty, _} => pure $ dsub1 ty p t => throw $ ExpectedEq loc ctx.names t @@ -82,5 +84,5 @@ computeElimType defs ctx pi e {ne} = TypeCase {ret, _} => pure ret -computeWhnfElimType0 defs ctx pi e = - computeElimType defs ctx pi e >>= whnf0 defs ctx pi +computeWhnfElimType0 defs ctx sg e = + computeElimType defs ctx sg e >>= whnf0 defs ctx SZero From 9cbd998d6fc0287d8213731a57c53fd63c5a7b62 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 30 Sep 2023 18:32:26 +0200 Subject: [PATCH 012/133] simplify isEmpty and isSubSing --- lib/Quox/Equal.idr | 20 ++++---------------- 1 file changed, 4 insertions(+), 16 deletions(-) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 3782de3..3c35354 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -74,6 +74,8 @@ isEmpty : {n : Nat} -> Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool isEmpty defs ctx sg ty0 = do Element ty0 nc <- whnf defs ctx sg ty0.loc ty0 + let Left y = choose $ isTyConE ty0 + | Right n => pure False case ty0 of TYPE {} => pure False Pi {arg, res, _} => pure False @@ -85,15 +87,7 @@ isEmpty defs ctx sg ty0 = do Eq {} => pure False Nat {} => pure False BOX {ty, _} => isEmpty defs ctx sg ty - E (Ann {tm, _}) => isEmpty defs ctx sg tm E _ => pure False - Lam {} => pure False - Pair {} => pure False - Tag {} => pure False - DLam {} => pure False - Zero {} => pure False - Succ {} => pure False - Box {} => pure False ||| true if a type is known to be a subsingleton purely by its form. ||| a subsingleton is a type with only zero or one possible values. @@ -110,6 +104,8 @@ isSubSing : {n : Nat} -> Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool isSubSing defs ctx sg ty0 = do Element ty0 nc <- whnf defs ctx sg ty0.loc ty0 + let Left y = choose $ isTyConE ty0 + | Right n => pure False case ty0 of TYPE {} => pure False Pi {arg, res, _} => @@ -123,15 +119,7 @@ isSubSing defs ctx sg ty0 = do Eq {} => pure True Nat {} => pure False BOX {ty, _} => isSubSing defs ctx sg ty - E (Ann {tm, _}) => isSubSing defs ctx sg tm E _ => pure False - Lam {} => pure False - Pair {} => pure False - Tag {} => pure False - DLam {} => pure False - Zero {} => pure False - Succ {} => pure False - Box {} => pure False ||| the left argument if the current mode is `Super`; otherwise the right one. From 0b7bd0ef46499f05dff1dbf095f5f5f7d7ddba2f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 30 Sep 2023 18:36:30 +0200 Subject: [PATCH 013/133] add locations and substitutions to untyped syntax --- lib/Quox/Untyped/Syntax.idr | 155 +++++++++++++++++++++++++----------- 1 file changed, 109 insertions(+), 46 deletions(-) diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 14519fc..2a5a312 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -4,10 +4,12 @@ import Quox.Var import Quox.Context import Quox.Name import Quox.Pretty +import Quox.Syntax.Subst import Data.Vect import Data.DPair import Data.SortedMap +import Data.SnocVect import Derive.Prelude %hide TT.Name @@ -15,40 +17,54 @@ import Derive.Prelude %language ElabReflection -public export -data Binder = Bind BaseName -Eq Binder where _ == _ = True -Ord Binder where compare _ _ = EQ -%runElab derive "Binder" [Show] - public export data Term : Nat -> Type where - F : (x : Name) -> Term n - B : (i : Var n) -> Term n + F : (x : Name) -> Loc -> Term n + B : (i : Var n) -> Loc -> Term n - Lam : (x : Binder) -> (body : Term (S n)) -> Term n - App : (fun, arg : Term n) -> Term n + Lam : (x : BindName) -> (body : Term (S n)) -> Loc -> Term n + App : (fun, arg : Term n) -> Loc -> Term n - Pair : (fst, snd : Term n) -> Term n - Fst : (pair : Term n) -> Term n - Snd : (pair : Term n) -> Term n + Pair : (fst, snd : Term n) -> Loc -> Term n + Fst : (pair : Term n) -> Loc -> Term n + Snd : (pair : Term n) -> Loc -> Term n - Tag : (tag : String) -> Term n - CaseEnum : (tag : Term n) -> (cases : List (String, Term n)) -> Term n + Tag : (tag : String) -> Loc -> Term n + CaseEnum : (tag : Term n) -> (cases : List (String, Term n)) -> Loc -> Term n + ||| empty match with an erased head + Absurd : Loc -> Term n - Zero : Term n - Succ : (nat : Term n) -> Term n + Zero : Loc -> Term n + Succ : (nat : Term n) -> Loc -> Term n CaseNat : (nat : Term n) -> (zer : Term n) -> - (x, ih : Binder) -> (suc : Term (2 + n)) -> + (x, ih : BindName) -> (suc : Term (2 + n)) -> + Loc -> Term n - ||| replacement for terms of type [0.A], for now - ErasedBox : Term n + Erased : Loc -> Term n %name Term s, t, u %runElab deriveIndexed "Term" [Eq, Ord, Show] +export +Located (Term n) where + (F x loc).loc = loc + (B i loc).loc = loc + (Lam x body loc).loc = loc + (App fun arg loc).loc = loc + (Pair fst snd loc).loc = loc + (Fst pair loc).loc = loc + (Snd pair loc).loc = loc + (Tag tag loc).loc = loc + (CaseEnum tag cases loc).loc = loc + (Absurd loc).loc = loc + (Zero loc).loc = loc + (Succ nat loc).loc = loc + (CaseNat nat zer x ih suc loc).loc = loc + (Erased loc).loc = loc + + public export 0 Definitions : Type Definitions = SortedMap Name $ Term 0 @@ -56,37 +72,33 @@ Definitions = SortedMap Name $ Term 0 parameters {opts : LayoutOpts} export - prettyBind : Binder -> Eff Pretty (Doc opts) - prettyBind (Bind x) = hl TVar $ text $ baseStr x + prettyTerm : BContext n -> Term n -> Eff Pretty (Doc opts) export - prettyTerm : Context' Binder n -> Term n -> Eff Pretty (Doc opts) - - export - prettyArg : Context' Binder n -> Term n -> Eff Pretty (Doc opts) + prettyArg : BContext n -> Term n -> Eff Pretty (Doc opts) prettyArg xs arg = withPrec Arg $ prettyTerm xs arg export - prettyApp' : Context' Binder n -> Doc opts -> Term n -> Eff Pretty (Doc opts) + prettyApp' : Context' BindName n -> Doc opts -> Term n -> Eff Pretty (Doc opts) prettyApp' xs fun arg = parensIfM App =<< do arg <- prettyArg xs arg pure $ sep [fun, arg] export - prettyApp : Context' Binder n -> Term n -> Term n -> Eff Pretty (Doc opts) + prettyApp : Context' BindName n -> Term n -> Term n -> Eff Pretty (Doc opts) prettyApp xs fun arg = prettyApp' xs !(prettyArg xs fun) arg public export PrettyCaseArm : Nat -> Type - PrettyCaseArm n = Exists $ \s => (Vect s Binder, Term (s + n)) + PrettyCaseArm n = Exists $ \s => (Vect s BindName, Term (s + n)) export %inline - caseArm : Vect s Binder -> Term (s + n) -> PrettyCaseArm n + caseArm : Vect s BindName -> Term (s + n) -> PrettyCaseArm n caseArm xs t = Evidence _ (xs, t) export - prettyCase : Context' Binder n -> + prettyCase : Context' BindName n -> (a -> Eff Pretty (Doc opts)) -> Term n -> List (a, PrettyCaseArm n) -> Eff Pretty (Doc opts) @@ -100,30 +112,81 @@ parameters {opts : LayoutOpts} body <- braces $ separateLoose !semiD cases pure $ sep [header, body] - prettyTerm _ (F x) = prettyFree x - prettyTerm xs (B i) = prettyBind $ xs !!! i - prettyTerm xs (Lam x body) = + prettyTerm _ (F x _) = prettyFree x + prettyTerm xs (B i _) = prettyTBind $ xs !!! i + prettyTerm xs (Lam x body _) = parensIfM Outer =<< do - header <- hsep <$> sequence [lamD, prettyBind x, darrowD] + header <- hsep <$> sequence [lamD, prettyTBind x, darrowD] body <- withPrec Outer $ prettyTerm (xs :< x) body hangDSingle header body - prettyTerm xs (App fun arg) = prettyApp xs fun arg - prettyTerm xs (Pair fst snd) = + prettyTerm xs (App fun arg _) = prettyApp xs fun arg + prettyTerm xs (Pair fst snd _) = parens =<< separateTight !commaD <$> sequence {t = List} [prettyTerm xs fst, prettyTerm xs snd] - prettyTerm xs (Fst pair) = prettyApp' xs !fstD pair - prettyTerm xs (Snd pair) = prettyApp' xs !sndD pair - prettyTerm xs (Tag tag) = prettyTag tag - prettyTerm xs (CaseEnum tag cases) = assert_total + prettyTerm xs (Fst pair _) = prettyApp' xs !fstD pair + prettyTerm xs (Snd pair _) = prettyApp' xs !sndD pair + prettyTerm xs (Tag tag _) = prettyTag tag + prettyTerm xs (CaseEnum tag cases _) = assert_total prettyCase xs prettyTag tag $ map (mapSnd $ caseArm []) cases - prettyTerm xs Zero = zeroD - prettyTerm xs (Succ nat) = prettyApp' xs !succD nat - prettyTerm xs (CaseNat nat zer x ih suc) = assert_total + prettyTerm xs (Absurd _) = hl Syntax "absurd" + prettyTerm xs (Zero _) = zeroD + prettyTerm xs (Succ nat _) = prettyApp' xs !succD nat + prettyTerm xs (CaseNat nat zer x ih suc _) = assert_total prettyCase xs pure nat [(!zeroD, caseArm [] zer), (!sucPat, caseArm [x, ih] suc)] where sucPat = separateTight {t = List} !commaD <$> - sequence [[|succD <++> prettyBind x|], prettyBind ih] - prettyTerm _ ErasedBox = + sequence [[|succD <++> prettyTBind x|], prettyTBind ih] + prettyTerm _ (Erased _) = hl Syntax =<< ifUnicode "⌷" "[]" + + +public export +USubst : Nat -> Nat -> Type +USubst = Subst Term + + +public export FromVar Term where fromVarLoc = B + + +public export +CanSubstSelf Term where + s // th = case s of + F x loc => + F x loc + B i loc => + getLoc th i loc + Lam x body loc => + Lam x (assert_total $ body // push th) loc + App fun arg loc => + App (fun // th) (arg // th) loc + Pair fst snd loc => + Pair (fst // th) (snd // th) loc + Fst pair loc => + Fst (pair // th) loc + Snd pair loc => + Snd (pair // th) loc + Tag tag loc => + Tag tag loc + CaseEnum tag cases loc => + CaseEnum (tag // th) (map (assert_total mapSnd (// th)) cases) loc + Absurd loc => + Absurd loc + Zero loc => + Zero loc + Succ nat loc => + Succ (nat // th) loc + CaseNat nat zer x ih suc loc => + CaseNat (nat // th) (zer // th) + x ih (assert_total $ suc // pushN 2 th) loc + Erased loc => + Erased loc + +public export +subN : SnocVect s (Term n) -> Term (s + n) -> Term n +subN th t = t // fromSnocVect th + +public export +sub1 : Term n -> Term (S n) -> Term n +sub1 e = subN [< e] From 428397f42bfbd81470b47e49bbe38bbf0bb811c3 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 30 Sep 2023 18:37:44 +0200 Subject: [PATCH 014/133] erasure to untyped syntax --- lib/Quox/Typing/Context.idr | 2 +- lib/Quox/Untyped/Erase.idr | 450 ++++++++++++++++++++++++++++++++++++ lib/quox-lib.ipkg | 3 +- 3 files changed, 453 insertions(+), 2 deletions(-) create mode 100644 lib/Quox/Untyped/Erase.idr diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index 385721f..52418e0 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -73,7 +73,7 @@ namespace TContext zeroFor : Context tm n -> QOutput n zeroFor ctx = Zero <$ ctx -private +public export extendLen : Telescope a n1 n2 -> Singleton n1 -> Singleton n2 extendLen [<] x = x extendLen (tel :< _) x = [|S $ extendLen tel x|] diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr new file mode 100644 index 0000000..1330f03 --- /dev/null +++ b/lib/Quox/Untyped/Erase.idr @@ -0,0 +1,450 @@ +module Quox.Untyped.Erase + +import Quox.Definition +import Quox.Syntax.Term.Base as Q +import Quox.Syntax.Term.Subst +import Quox.Untyped.Syntax as U +import Quox.Typing.Context +import Quox.Whnf + +import Quox.EffExtra +import Data.Singleton +import Data.SnocVect +import Language.Reflection + +%default total +%language ElabReflection + +%hide TT.Name + + +public export +data IsErased = Erased | Kept + +public export +isErased : Qty -> IsErased +isErased Zero = Erased +isErased One = Kept +isErased Any = Kept + +public export +ifErased : Qty -> Lazy a -> Lazy a -> a +ifErased pi x y = case isErased pi of + Erased => x + Kept => y + + +public export +EContext : Nat -> Type +EContext = Context' IsErased + +public export +record ErasureContext d n where + constructor MkEContexts + {auto dimLen : Singleton d} + {auto termLen : Singleton n} + dnames : BContext d + tnames : BContext n + tctx : TContext d n + erased : EContext n +%name ErasureContext ctx + + +public export +TypeError : Type +TypeError = Typing.Error.Error +%hide Typing.Error.Error + +public export +data Error = + CompileTimeOnly (ErasureContext d n) (Q.Term d n) +| ErasedVar (ErasureContext d n) (Var n) +| NotInScope Name +| WrapTypeError TypeError + +public export +Erase : List (Type -> Type) +Erase = [Except Error, DefsReader, NameGen] + + +export +toWhnfContext : ErasureContext d n -> WhnfContext d n +toWhnfContext (MkEContexts {dnames, tnames, tctx, _}) = + MkWhnfContext {dnames, tnames, tctx} + +export +(.names) : ErasureContext d n -> NameContexts d n +ctx.names = MkNameContexts ctx.dnames ctx.tnames + + +export +liftWhnf : Eff Whnf a -> Eff Erase a +liftWhnf act = runEff act + [\x => send x, \case (Err e) => throw $ WrapTypeError e] + +export covering +whnf0 : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => + ErasureContext d n -> SQty -> + tm d n -> Eff Erase (tm d n) +whnf0 ctx sg tm = do + let Val n = ctx.termLen; Val d = ctx.dimLen + liftWhnf $ whnf0 !(askAt DEFS) (toWhnfContext ctx) sg tm + +export covering +computeElimType : ErasureContext d n -> SQty -> Elim d n -> Eff Erase (Term d n) +computeElimType ctx sg e = do + let Val n = ctx.termLen; Val d = ctx.dimLen + ctx = toWhnfContext ctx + defs <- askAt DEFS + Element e enf <- liftWhnf $ whnf defs ctx sg e + liftWhnf $ computeElimType defs ctx sg e + + +parameters (ctx : ErasureContext d n) (loc : Loc) + private covering %macro + expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> TypeError) -> + TTImp -> TTImp -> Elab (Term d n -> Eff Erase a) + expect k l r = do + f <- check `(\case ~(l) => Just ~(r); _ => Nothing) + pure $ \t => + let err = throw $ WrapTypeError $ k loc ctx.names t in + maybe err pure . f =<< whnf0 ctx SZero t + + export covering %inline + expectTYPE : Term d n -> Eff Erase Universe + expectTYPE = expect ExpectedTYPE `(TYPE {l, _}) `(l) + + export covering %inline + expectPi : Term d n -> Eff Erase (Qty, Term d n, ScopeTerm d n) + expectPi = expect ExpectedPi `(Pi {qty, arg, res, _}) `((qty, arg, res)) + + export covering %inline + expectSig : Term d n -> Eff Erase (Term d n, ScopeTerm d n) + expectSig = expect ExpectedSig `(Sig {fst, snd, _}) `((fst, snd)) + + export covering %inline + expectEnum : Term d n -> Eff Erase (SortedSet TagVal) + expectEnum = expect ExpectedEnum `(Enum {cases, _}) `(cases) + + export covering %inline + expectEq : Term d n -> Eff Erase (DScopeTerm d n, Term d n, Term d n) + expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r)) + + export covering %inline + expectNat : Term d n -> Eff Erase () + expectNat = expect ExpectedNat `(Nat {}) `(()) + + export covering %inline + expectBOX : Term d n -> Eff Erase (Qty, Term d n) + expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty)) + + +export +extendTyN : CtxExtension d n1 n2 -> + ErasureContext d n1 -> ErasureContext d n2 +extendTyN tel (MkEContexts {termLen, dnames, tnames, tctx, erased}) = + let (qs, xs, ss) = unzip3 tel in + MkEContexts { + dnames, + tnames = tnames . xs, + tctx = tctx . ss, + erased = erased . map isErased qs, + termLen = extendLen tel termLen + } + +export +extendTy : Qty -> BindName -> Term d n -> + ErasureContext d n -> ErasureContext d (S n) +extendTy pi x ty = extendTyN [< (pi, x, ty)] + +export +extendDim : BindName -> ErasureContext d n -> ErasureContext (S d) n +extendDim i (MkEContexts {dimLen, dnames, tnames, tctx, erased}) = + MkEContexts { + tnames, erased, + dimLen = [|S dimLen|], + dnames = dnames :< i, + tctx = map (dweakT 1) tctx + } + + +public export +record EraseElimResult d n where + constructor EraRes + type : Lazy (Q.Term d n) + term : U.Term n + + +export covering +eraseTerm : ErasureContext d n -> + (ty, tm : Q.Term d n) -> Eff Erase (U.Term n) + +export covering +eraseElim : ErasureContext d n -> (tm : Q.Elim d n) -> + Eff Erase (EraseElimResult d n) + +eraseTerm ctx _ s@(TYPE {}) = + throw $ CompileTimeOnly ctx s + +eraseTerm ctx _ s@(Pi {}) = + throw $ CompileTimeOnly ctx s + +-- π.x : A ⊢ s ⤋ s' ⇐ B +-- ---------------------------------------- +-- (λ x ⇒ s) ⤋ (λ x ⇒ s') ⇐ π.(x : A) → B +-- +-- becomes a lambda even when π = 0, +-- to preserve expected evaluation order +eraseTerm ctx ty (Lam body loc) = do + (qty, arg, res) <- expectPi ctx loc ty + let x = body.name + body <- eraseTerm (extendTy qty x arg ctx) res.term body.term + pure $ U.Lam x body loc + +eraseTerm ctx _ s@(Sig {}) = + throw $ CompileTimeOnly ctx s + +-- s ⤋ s' ⇐ A t ⤋ t' ⇐ B[s/x] +-- --------------------------------- +-- (s, t) ⤋ (s', t') ⇐ (x : A) × B +eraseTerm ctx ty (Pair fst snd loc) = do + (a, b) <- expectSig ctx loc ty + let b = sub1 b (Ann fst a a.loc) + fst <- eraseTerm ctx a fst + snd <- eraseTerm ctx b snd + pure $ Pair fst snd loc + +eraseTerm ctx _ s@(Enum {}) = + throw $ CompileTimeOnly ctx s + +-- '𝐚 ⤋ '𝐚 ⇐ {⋯} +eraseTerm ctx _ (Tag tag loc) = + pure $ Tag tag loc + +eraseTerm ctx ty s@(Eq {}) = + throw $ CompileTimeOnly ctx s + +-- 𝑖 ⊢ s ⤋ s' ⇐ A +-- --------------------------------- +-- (δ 𝑖 ⇒ s) ⤋ s' ⇐ Eq (𝑖 ⇒ A) l r +eraseTerm ctx ty (DLam body loc) = do + a <- fst <$> expectEq ctx loc ty + eraseTerm (extendDim body.name ctx) a.term body.term + +eraseTerm ctx _ s@(Nat {}) = + throw $ CompileTimeOnly ctx s + +-- 0 ⤋ 0 ⇐ ℕ +eraseTerm _ _ (Zero loc) = + pure $ Zero loc + +-- s ⤋ s' ⇐ ℕ +-- ----------------------- +-- succ s ⤋ succ s' ⇐ ℕ +eraseTerm ctx ty (Succ p loc) = do + p <- eraseTerm ctx ty p + pure $ Succ p loc + +eraseTerm ctx ty s@(BOX {}) = + throw $ CompileTimeOnly ctx s + +-- [s] ⤋ ⌷ ⇐ [0.A] +-- +-- π ≠ 0 s ⤋ s' ⇐ A +-- -------------------- +-- [s] ⤋ s' ⇐ [π.A] +eraseTerm ctx ty (Box val loc) = do + (qty, a) <- expectBOX ctx loc ty + case isErased qty of + Erased => pure $ Erased loc + Kept => eraseTerm ctx a val + +-- e ⤋ e' ⇒ B +-- ------------ +-- e ⤋ e' ⇐ A +eraseTerm ctx ty (E e) = + term <$> eraseElim ctx e + +eraseTerm ctx ty (CloT (Sub term th)) = + eraseTerm ctx ty $ pushSubstsWith' id th term + +eraseTerm ctx ty (DCloT (Sub term th)) = + eraseTerm ctx ty $ pushSubstsWith' th id term + +-- defω x : A = s +-- ---------------- +-- x ⤋ x ⇒ A +eraseElim ctx e@(F x u loc) = do + Just def <- asksAt DEFS $ lookup x + | Nothing => throw $ NotInScope x + case isErased def.qty.qty of + Erased => throw $ CompileTimeOnly ctx $ E e + Kept => + let Val d = ctx.dimLen; Val n = ctx.termLen in + pure $ EraRes def.type $ F x loc + +-- π ≠ 0 +-- ---------------------------- +-- Γ, π.x : A, Γ' ⊢ x ⤋ x ⇒ A +eraseElim ctx e@(B i loc) = do + case ctx.erased !!! i of + Erased => throw $ CompileTimeOnly ctx $ E e + Kept => pure $ EraRes (ctx.tctx !! i) $ B i loc + +-- f ⤋ f' ⇒ π.(x : A) → B s ⤋ s' ⇒ A π ≠ 0 +-- --------------------------------------------- +-- f s ⤋ f' s' ⇒ B[s/x] +-- +-- f ⤋ f' ⇒ 0.(x : A) → B +-- ------------------------- +-- f s ⤋ f' ⌷ ⇒ B[s/x] +eraseElim ctx (App fun arg loc) = do + efun <- eraseElim ctx fun + (qty, targ, tres) <- expectPi ctx loc efun.type + let ty = sub1 tres (Ann arg targ arg.loc) + case isErased qty of + Erased => pure $ EraRes ty $ App efun.term (Erased arg.loc) loc + Kept => do arg <- eraseTerm ctx targ arg + pure $ EraRes ty $ App efun.term arg loc + +-- e ⤋ e' ⇒ (x : A) × B +-- ρ.x : A, ρ.y : B ⊢ s ⤋ s' ⇐ R[((x,y) ∷ (x : A) × B)/z] +-- x̃ ≔ if ρ = 0 then ⌷ else fst e' ỹ ≔ if ρ = 0 then ⌷ else snd e' +-- ------------------------------------------------------------------- +-- (caseρ e return z ⇒ R of {(x, y) ⇒ s}) ⤋ s'[x̃/x, ỹ/y] ⇒ R[e/z] +eraseElim ctx (CasePair qty pair ret body loc) = do + epair <- eraseElim ctx pair + let ty = sub1 (ret // shift 2) $ + Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 epair.type) loc + (tfst, tsnd) <- expectSig ctx loc epair.type + let [< x, y] = body.names + let ctx' = extendTyN [< (qty, x, tfst), (qty, y, tsnd.term)] ctx + body' <- eraseTerm ctx' ty body.term + let x' = ifErased qty (Erased loc) (Fst epair.term loc) + y' = ifErased qty (Erased loc) (Snd epair.term loc) + pure $ EraRes (sub1 ret pair) $ body' // fromSnocVect [< x', y'] + +-- e ⤋ e' ⇒ (x : A) × B +-- ---------------------- +-- fst e ⤋ fst e' ⇒ A +eraseElim ctx (Fst pair loc) = do + epair <- eraseElim ctx pair + a <- fst <$> expectSig ctx loc epair.type + pure $ EraRes a $ Fst epair.term loc + +-- e ⤋ e' ⇒ (x : A) × B +-- ----------------------------- +-- snd e ⤋ snd e' ⇒ B[fst e/x] +eraseElim ctx (Snd pair loc) = do + epair <- eraseElim ctx pair + b <- snd <$> expectSig ctx loc epair.type + pure $ EraRes (sub1 b (Fst pair loc)) $ Snd epair.term loc + +-- case0 e return z ⇒ R of {} ⤋ absurd ⇒ R[e/z] +-- +-- s ⤋ s' ⇐ R[𝐚∷{𝐚}/z] +-- ----------------------------------------------- +-- case0 e return z ⇒ R of {𝐚 ⇒ s} ⤋ s' ⇒ R[e/z] +-- +-- e ⤋ e' ⇒ A ρ ≠ 0 sᵢ ⤋ s'ᵢ ⇐ R[𝐚ᵢ/z] +-- ------------------------------------------------------------------- +-- caseρ e return z ⇒ R of {𝐚ᵢ ⇒ sᵢ} ⤋ case e of {𝐚ᵢ ⇒ s'ᵢ} ⇒ R[e/z] +eraseElim ctx e@(CaseEnum qty tag ret arms loc) = + case isErased qty of + Erased => case SortedMap.toList arms of + [] => pure $ EraRes (sub1 ret tag) $ Absurd loc + [(t, arm)] => do + let ty = sub1 ret tag + ty' = sub1 ret (Ann (Tag t loc) (enum [t] loc) loc) + arm' <- eraseTerm ctx ty' arm + pure $ EraRes ty arm' + _ => throw $ CompileTimeOnly ctx $ E e + Kept => do + let ty = sub1 ret tag + etag <- eraseElim ctx tag + arms <- for (SortedMap.toList arms) $ \(t, rhs) => do + let ty' = sub1 ret (Ann (Tag t loc) etag.type loc) + rhs' <- eraseTerm ctx ty' rhs + pure (t, rhs') + pure $ EraRes ty $ CaseEnum etag.term arms loc + +-- n ⤋ n' ⇒ ℕ z ⤋ z' ⇐ R[zero∷ℕ/z] +-- ρ.m : ℕ, ς.ih : R[m/z] ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z] +-- --------------------------------------------------- +-- caseρ n return z ⇒ R of {0 ⇒ z; succ m, ς.ih ⇒ s} +-- ⤋ +-- case n' of {0 ⇒ z'; succ m, ih ⇒ s'} +-- ⇒ R[n/z] +eraseElim ctx (CaseNat qty qtyIH nat ret zero succ loc) = do + let ty = sub1 ret nat + enat <- eraseElim ctx nat + zero <- eraseTerm ctx (sub1 ret (Ann (Zero loc) (Nat loc) loc)) zero + let [< p, ih] = succ.names + succ <- eraseTerm + (extendTyN [< (qty, p, Nat loc), + (qtyIH, ih, sub1 (ret // shift 1) (BV 0 loc))] ctx) + (sub1 (ret // shift 2) (Ann (Succ (BVT 1 loc) loc) (Nat loc) loc)) + succ.term + pure $ EraRes ty $ CaseNat enat.term zero p ih succ loc + +-- b ⤋ b' ⇒ [π.A] π ≠ 0 +-- πρ.x : A ⊢ s ⤋ s' ⇐ R[[x]∷[π.A]/z] +-- ------------------------------------------------------- +-- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[b'/x] ⇒ R[b/z] +-- +-- b ⇒ [0.A] 0.x : A ⊢ s ⤋ s' ⇐ R[[x]∷[0.A]/z] +-- ------------------------------------------------------- +-- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[⌷/x] ⇒ R[b/z] +eraseElim ctx (CaseBox qty box ret body loc) = do + tbox <- computeElimType ctx SOne box -- [fixme] is there any way to avoid this? + (pi, tinner) <- expectBOX ctx loc tbox + let ctx' = extendTy Zero body.name tinner ctx + bty = sub1 (ret // shift 1) $ + Ann (Box (BVT 0 loc) loc) (weakT 1 tbox) loc + case isErased pi of + Kept => do + ebox <- eraseElim ctx box + ebody <- eraseTerm ctx' bty body.term + pure $ EraRes (sub1 ret box) $ ebody // one ebox.term + Erased => do + body' <- eraseTerm ctx' bty body.term + pure $ EraRes (sub1 ret box) $ body' // one (Erased loc) + +-- f ⤋ f' ⇒ Eq (𝑖 ⇒ A) l r +-- ------------------------------ +-- f @r ⤋ f' ⇒ A‹r/𝑖› +eraseElim ctx (DApp fun arg loc) = do + efun <- eraseElim ctx fun + a <- fst <$> expectEq ctx loc efun.type + pure $ EraRes (dsub1 a arg) efun.term + +-- s ⤋ s' ⇐ A +-- ---------------- +-- s ∷ A ⤋ s' ⇒ A +eraseElim ctx (Ann tm ty loc) = + EraRes ty <$> eraseTerm ctx ty tm + +-- s ⤋ s' ⇐ A‹p/𝑖› +-- ----------------------------------- +-- coe (𝑖 ⇒ A) @p @q s ⤋ s' ⇒ A‹q/𝑖› +eraseElim ctx (Coe ty p q val loc) = do + val <- eraseTerm ctx (dsub1 ty p) val + pure $ EraRes (dsub1 ty q) val + +-- s ⤋ s' ⇐ A +-- -------------------------------- +-- comp A @p @q s @r {⋯} ⤋ s' ⇒ A +-- +-- [todo] is this ok? they are equal, but even so, +-- maybe t₀ and t₁ have different performance characteristics +eraseElim ctx (Comp ty p q val r zero one loc) = + EraRes ty <$> eraseTerm ctx ty val + +eraseElim ctx t@(TypeCase ty ret arms def loc) = + throw $ CompileTimeOnly ctx $ E t + +eraseElim ctx (CloE (Sub term th)) = + eraseElim ctx $ pushSubstsWith' id th term + +eraseElim ctx (DCloE (Sub term th)) = + eraseElim ctx $ pushSubstsWith' th id term diff --git a/lib/quox-lib.ipkg b/lib/quox-lib.ipkg index 26d4b6f..de8d2f3 100644 --- a/lib/quox-lib.ipkg +++ b/lib/quox-lib.ipkg @@ -57,4 +57,5 @@ modules = Quox.Parser.FromParser, Quox.Parser.FromParser.Error, Quox.Parser, - Quox.Untyped.Syntax + Quox.Untyped.Syntax, + Quox.Untyped.Erase From 2e9183bc1458ededc9f5a7073e9da438573e9385 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 15 Oct 2023 16:12:43 +0200 Subject: [PATCH 015/133] add prettyDef --- lib/Quox/Definition.idr | 12 ++++++++++++ 1 file changed, 12 insertions(+) diff --git a/lib/Quox/Definition.idr b/lib/Quox/Definition.idr index 030584c..677f856 100644 --- a/lib/Quox/Definition.idr +++ b/lib/Quox/Definition.idr @@ -5,6 +5,7 @@ import public Quox.Syntax import Quox.Displace import public Data.SortedMap import public Quox.Loc +import Quox.Pretty import Control.Eff import Decidable.Decidable @@ -87,3 +88,14 @@ DefsState = StateL DEFS Definitions public export %inline lookupElim : {d, n : Nat} -> Name -> Universe -> Definitions -> Maybe (Elim d n) lookupElim x u defs = toElim !(lookup x defs) u + + +export +prettyDef : {opts : LayoutOpts} -> Name -> Definition -> Eff Pretty (Doc opts) +prettyDef name (MkDef qty type _ _) = withPrec Outer $ do + qty <- prettyQty qty.qty + dot <- dotD + name <- prettyFree name + colon <- colonD + type <- prettyTerm [<] [<] type + pure $ sep [hsep [hcat [qty, dot, name], colon], type] From 0c1df54d627982d573a449d139a2571270ce3908 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 15 Oct 2023 16:23:38 +0200 Subject: [PATCH 016/133] improve handling of context lengths --- lib/Quox/Definition.idr | 18 +++++++++++++++++- lib/Quox/Equal.idr | 27 +++++++++------------------ lib/Quox/FreeVars.idr | 8 ++++++++ lib/Quox/Typechecker.idr | 6 ++++-- lib/Quox/Typing.idr | 1 - lib/Quox/Typing/Context.idr | 11 ++++++++++- lib/Quox/Untyped/Erase.idr | 18 +++++++----------- lib/Quox/Whnf/Coercion.idr | 2 +- lib/Quox/Whnf/ComputeElimType.idr | 4 +--- lib/Quox/Whnf/Interface.idr | 10 ++++------ lib/Quox/Whnf/Main.idr | 4 ++-- lib/Quox/Whnf/TypeCase.idr | 2 +- 12 files changed, 64 insertions(+), 47 deletions(-) diff --git a/lib/Quox/Definition.idr b/lib/Quox/Definition.idr index 677f856..8bd2fa9 100644 --- a/lib/Quox/Definition.idr +++ b/lib/Quox/Definition.idr @@ -7,6 +7,7 @@ import public Data.SortedMap import public Quox.Loc import Quox.Pretty import Control.Eff +import Data.Singleton import Decidable.Decidable @@ -63,6 +64,18 @@ parameters {d, n : Nat} toElim : Definition -> Universe -> Maybe $ Elim d n toElim def u = pure $ Ann !(def.termAt u) (def.typeAt u) def.loc +public export +(.typeWith) : Definition -> Singleton d -> Singleton n -> Term d n +g.typeWith (Val d) (Val n) = g.type + +public export +(.typeWithAt) : Definition -> Singleton d -> Singleton n -> Universe -> Term d n +g.typeWithAt d n u = displace u $ g.typeWith d n + +public export +(.termWith) : Definition -> Singleton d -> Singleton n -> Maybe (Term d n) +g.termWith (Val d) (Val n) = g.term + public export %inline isZero : Definition -> Bool @@ -84,11 +97,14 @@ public export DefsState : Type -> Type DefsState = StateL DEFS Definitions - public export %inline lookupElim : {d, n : Nat} -> Name -> Universe -> Definitions -> Maybe (Elim d n) lookupElim x u defs = toElim !(lookup x defs) u +public export %inline +lookupElim0 : Name -> Universe -> Definitions -> Maybe (Elim 0 0) +lookupElim0 = lookupElim + export prettyDef : {opts : LayoutOpts} -> Name -> Definition -> Eff Pretty (Doc opts) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 3c35354..bbaa6d5 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -70,7 +70,7 @@ sameTyCon (E {}) _ = False ||| * `[π.A]` is empty if `A` is. ||| * that's it. public export covering -isEmpty : {n : Nat} -> Definitions -> EqContext n -> SQty -> Term 0 n -> +isEmpty : Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool isEmpty defs ctx sg ty0 = do Element ty0 nc <- whnf defs ctx sg ty0.loc ty0 @@ -100,7 +100,7 @@ isEmpty defs ctx sg ty0 = do ||| * an enum type is a subsingleton if it has zero or one tags. ||| * a box type is a subsingleton if its content is public export covering -isSubSing : {n : Nat} -> Definitions -> EqContext n -> SQty -> Term 0 n -> +isSubSing : Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool isSubSing defs ctx sg ty0 = do Element ty0 nc <- whnf defs ctx sg ty0.loc ty0 @@ -175,7 +175,7 @@ namespace Term -- Γ ⊢ A empty -- ------------------------------------------- -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) : (π·x : A) → B - if !(isEmpty' arg) then pure () else + if !(isEmpty defs ctx sg arg) then pure () else case (s, t) of -- Γ, x : A ⊢ s = t : B -- ------------------------------------------- @@ -195,9 +195,6 @@ namespace Term (E _, t) => wrongType t.loc ctx ty t (s, _) => wrongType s.loc ctx ty s where - isEmpty' : Term 0 n -> Eff EqualInner Bool - isEmpty' t = let Val n = ctx.termLen in isEmpty defs ctx sg arg - ctx' : EqContext (S n) ctx' = extendTy qty res.name arg ctx @@ -390,9 +387,9 @@ lookupFree : Has ErrorEff fs => Definitions -> EqContext n -> Name -> Universe -> Loc -> Eff fs (Term 0 n) lookupFree defs ctx x u loc = - let Val n = ctx.termLen in - maybe (throw $ NotInScope loc x) (\d => pure $ d.typeAt u) $ - lookup x defs + case lookup x defs of + Nothing => throw $ NotInScope loc x + Just d => pure $ d.typeWithAt [|Z|] ctx.termLen u namespace Elim @@ -410,9 +407,8 @@ namespace Elim computeElimTypeE : (defs : Definitions) -> EqContext n -> (sg : SQty) -> (e : Elim 0 n) -> (0 ne : NotRedex defs sg e) => Eff EqualElim (Term 0 n) - computeElimTypeE defs ectx sg e = - let Val n = ectx.termLen in - lift $ computeElimType defs (toWhnfContext ectx) sg e + computeElimTypeE defs ectx sg e = lift $ + computeElimType defs (toWhnfContext ectx) sg e private putError : Has InnerErrEff fs => Error -> Eff fs () @@ -701,7 +697,6 @@ namespace Elim clashE defs ctx sg e f compare0Inner defs ctx sg e f = do - let Val n = ctx.termLen Element e ne <- whnf defs ctx sg e.loc e Element f nf <- whnf defs ctx sg f.loc f ty <- compare0Inner' defs ctx sg e f ne nf @@ -714,7 +709,6 @@ namespace Elim namespace Term compare0 defs ctx sg ty s t = wrapErr (WhileComparingT ctx !mode sg ty s t) $ do - let Val n = ctx.termLen Element ty' _ <- whnf defs ctx SZero ty.loc ty Element s' _ <- whnf defs ctx sg s.loc s Element t' _ <- whnf defs ctx sg t.loc t @@ -727,7 +721,6 @@ namespace Elim maybe (pure ty) throw err compareType defs ctx s t = do - let Val n = ctx.termLen Element s' _ <- whnf defs ctx SZero s.loc s Element t' _ <- whnf defs ctx SZero t.loc t ts <- ensureTyCon s.loc ctx s' @@ -747,7 +740,6 @@ parameters (loc : Loc) (ctx : TyContext d n) eachFace : Applicative f => FreeVars d -> (EqContext n -> DSubst d 0 -> f ()) -> f () eachFace fvs act = - let Val d = ctx.dimLen in for_ (splits loc ctx.dctx fvs) $ \th => act (makeEqContext ctx th) th @@ -762,8 +754,7 @@ parameters (loc : Loc) (ctx : TyContext d n) private fdvAll : HasFreeDVars t => List (t d n) -> FreeVars d - fdvAll ts = - let Val d = ctx.dimLen; Val n = ctx.termLen in foldMap fdv ts + fdvAll = let Val d = ctx.dimLen in foldMap (fdvWith [|d|] ctx.termLen) namespace Term export covering diff --git a/lib/Quox/FreeVars.idr b/lib/Quox/FreeVars.idr index 130c37c..ef8c42a 100644 --- a/lib/Quox/FreeVars.idr +++ b/lib/Quox/FreeVars.idr @@ -93,6 +93,14 @@ interface HasFreeDVars (0 tm : TermLike) where constructor HFDV fdv : {d, n : Nat} -> tm d n -> FreeVars d +public export %inline +fvWith : HasFreeVars tm => Singleton n -> tm n -> FreeVars n +fvWith (Val n) = fv + +public export %inline +fdvWith : HasFreeDVars tm => Singleton d -> Singleton n -> tm d n -> FreeVars d +fdvWith (Val d) (Val n) = fdv + export Fdv : (0 tm : TermLike) -> {n : Nat} -> HasFreeDVars tm => HasFreeVars (\d => tm d n) diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index 9145e04..563e6df 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -328,8 +328,10 @@ mutual -- if σ ≤ π expectCompatQ loc sg.qty g.qty.qty -- then Ψ | Γ ⊢ σ · x ⇒ A ⊳ 𝟎 - let Val d = ctx.dimLen; Val n = ctx.termLen - pure $ InfRes {type = g.typeAt u, qout = zeroFor ctx} + pure $ InfRes { + type = g.typeWithAt ctx.dimLen ctx.termLen u, + qout = zeroFor ctx + } infer' ctx sg (B i _) = -- if x : A ∈ Γ diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index ad4fec3..cfd402d 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -118,7 +118,6 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => tm 0 n -> Eff fs (NonRedex tm 0 n defs sg) whnf tm = do - let Val n = ctx.termLen res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm rethrow res diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index 52418e0..a1dd49a 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -58,6 +58,8 @@ record EqContext n where public export record WhnfContext d n where constructor MkWhnfContext + {auto dimLen : Singleton d} + {auto termLen : Singleton n} dnames : BContext d tnames : BContext n tctx : TContext d n @@ -232,6 +234,12 @@ namespace EqContext toWhnfContext (MkEqContext {tnames, tctx, _}) = MkWhnfContext {dnames = [<], tnames, tctx} + export + injElim : WhnfContext d n -> Elim 0 0 -> Elim d n + injElim ctx e = + let Val d = ctx.dimLen; Val n = ctx.termLen in + e // shift0 d // shift0 n + namespace WhnfContext public export %inline empty : WhnfContext 0 0 @@ -240,8 +248,9 @@ namespace WhnfContext export extendDimN : {s : Nat} -> BContext s -> WhnfContext d n -> WhnfContext (s + d) n - extendDimN ns (MkWhnfContext {dnames, tnames, tctx}) = + extendDimN ns (MkWhnfContext {dnames, tnames, tctx, dimLen}) = MkWhnfContext { + dimLen = [|Val s + dimLen|], dnames = dnames ++ toSnocVect' ns, tctx = dweakT s <$> tctx, tnames diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 1330f03..f8e650d 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -86,18 +86,16 @@ export covering whnf0 : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => ErasureContext d n -> SQty -> tm d n -> Eff Erase (tm d n) -whnf0 ctx sg tm = do - let Val n = ctx.termLen; Val d = ctx.dimLen - liftWhnf $ whnf0 !(askAt DEFS) (toWhnfContext ctx) sg tm +whnf0 ctx sg tm = liftWhnf $ whnf0 !(askAt DEFS) (toWhnfContext ctx) sg tm export covering computeElimType : ErasureContext d n -> SQty -> Elim d n -> Eff Erase (Term d n) computeElimType ctx sg e = do - let Val n = ctx.termLen; Val d = ctx.dimLen - ctx = toWhnfContext ctx - defs <- askAt DEFS - Element e enf <- liftWhnf $ whnf defs ctx sg e - liftWhnf $ computeElimType defs ctx sg e + defs <- askAt DEFS + liftWhnf $ do + let ctx = toWhnfContext ctx + Element e enf <- whnf defs ctx sg e + computeElimType defs ctx sg e parameters (ctx : ErasureContext d n) (loc : Loc) @@ -279,9 +277,7 @@ eraseElim ctx e@(F x u loc) = do | Nothing => throw $ NotInScope x case isErased def.qty.qty of Erased => throw $ CompileTimeOnly ctx $ E e - Kept => - let Val d = ctx.dimLen; Val n = ctx.termLen in - pure $ EraRes def.type $ F x loc + Kept => pure $ EraRes (def.typeWith ctx.dimLen ctx.termLen) $ F x loc -- π ≠ 0 -- ---------------------------- diff --git a/lib/Quox/Whnf/Coercion.idr b/lib/Quox/Whnf/Coercion.idr index 831ee8d..7ee26cb 100644 --- a/lib/Quox/Whnf/Coercion.idr +++ b/lib/Quox/Whnf/Coercion.idr @@ -23,7 +23,7 @@ where parameters {auto _ : CanWhnf Term Interface.isRedexT} {auto _ : CanWhnf Elim Interface.isRedexE} - {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n) (sg : SQty) + (defs : Definitions) (ctx : WhnfContext d n) (sg : SQty) ||| reduce a function application `App (Coe ty p q val) s loc` export covering piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> diff --git a/lib/Quox/Whnf/ComputeElimType.idr b/lib/Quox/Whnf/ComputeElimType.idr index 4bb3727..441ba1e 100644 --- a/lib/Quox/Whnf/ComputeElimType.idr +++ b/lib/Quox/Whnf/ComputeElimType.idr @@ -14,7 +14,6 @@ export covering computeElimType : CanWhnf Term Interface.isRedexT => CanWhnf Elim Interface.isRedexE => - {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) -> (e : Elim d n) -> (0 ne : No (isRedexE defs sg e)) => Eff Whnf (Term d n) @@ -25,7 +24,6 @@ export covering computeWhnfElimType0 : CanWhnf Term Interface.isRedexT => CanWhnf Elim Interface.isRedexE => - {d, n : Nat} -> (defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) -> (e : Elim d n) -> (0 ne : No (isRedexE defs sg e)) => Eff Whnf (Term d n) @@ -35,7 +33,7 @@ computeElimType defs ctx sg e = F x u loc => do let Just def = lookup x defs | Nothing => throw $ NotInScope loc x - pure $ def.typeAt u + pure $ def.typeWithAt ctx.dimLen ctx.termLen u B i _ => pure $ ctx.tctx !! i diff --git a/lib/Quox/Whnf/Interface.idr b/lib/Quox/Whnf/Interface.idr index fd10b0e..8a6a43a 100644 --- a/lib/Quox/Whnf/Interface.idr +++ b/lib/Quox/Whnf/Interface.idr @@ -18,13 +18,12 @@ Whnf = [NameGen, Except Error] public export 0 RedexTest : TermLike -> Type -RedexTest tm = {d, n : Nat} -> Definitions -> SQty -> tm d n -> Bool +RedexTest tm = {0 d, n : Nat} -> Definitions -> SQty -> tm d n -> Bool public export interface CanWhnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm where - whnf : {d, n : Nat} -> (defs : Definitions) -> - (ctx : WhnfContext d n) -> (q : SQty) -> + whnf : (defs : Definitions) -> (ctx : WhnfContext d n) -> (q : SQty) -> tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs q)) -- having isRedex be part of the class header, and needing to be explicitly -- quantified on every use since idris can't infer its type, is a little ugly. @@ -32,7 +31,7 @@ where -- cases idris can't tell that `isRedex` and `isRedexT` are the same thing public export %inline -whnf0 : {d, n : Nat} -> {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => +whnf0 : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => Definitions -> WhnfContext d n -> SQty -> tm d n -> Eff Whnf (tm d n) whnf0 defs ctx q t = fst <$> whnf defs ctx q t @@ -194,8 +193,7 @@ mutual ||| 7. a closure public export isRedexE : RedexTest Elim - isRedexE defs sg (F {x, u, _}) {d, n} = - isJust $ lookupElim x u defs {d, n} + isRedexE defs sg (F {x, u, _}) = isJust $ lookupElim0 x u defs isRedexE _ sg (B {}) = False isRedexE defs sg (App {fun, _}) = isRedexE defs sg fun || isLamHead fun diff --git a/lib/Quox/Whnf/Main.idr b/lib/Quox/Whnf/Main.idr index 6aff789..264c61a 100644 --- a/lib/Quox/Whnf/Main.idr +++ b/lib/Quox/Whnf/Main.idr @@ -16,8 +16,8 @@ export covering CanWhnf Elim Interface.isRedexE covering CanWhnf Elim Interface.isRedexE where - whnf defs ctx sg (F x u loc) with (lookupElim x u defs) proof eq - _ | Just y = whnf defs ctx sg $ setLoc loc y + whnf defs ctx sg (F x u loc) with (lookupElim0 x u defs) proof eq + _ | Just y = whnf defs ctx sg $ setLoc loc $ injElim ctx y _ | Nothing = pure $ Element (F x u loc) $ rewrite eq in Ah whnf _ _ _ (B i loc) = pure $ nred $ B i loc diff --git a/lib/Quox/Whnf/TypeCase.idr b/lib/Quox/Whnf/TypeCase.idr index c30cd71..0c1f5e1 100644 --- a/lib/Quox/Whnf/TypeCase.idr +++ b/lib/Quox/Whnf/TypeCase.idr @@ -30,7 +30,7 @@ tycaseRhsDef0 def k arms = fromMaybe def $ tycaseRhs0 k arms parameters {auto _ : CanWhnf Term Interface.isRedexT} {auto _ : CanWhnf Elim Interface.isRedexE} - {d, n : Nat} (defs : Definitions) (ctx : WhnfContext d n) + (defs : Definitions) (ctx : WhnfContext d n) ||| for π.(x : A) → B, returns (A, B); ||| for an elim returns a pair of type-cases that will reduce to that; ||| for other intro forms error From 52e54dcc3c9e7a42da4c35ff7cbfe6ddb8c3e662 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 20 Oct 2023 04:53:20 +0200 Subject: [PATCH 017/133] add PrettyVal stuff for parser AST --- exe/quox.ipkg | 2 +- lib/Quox/Loc.idr | 17 +++++++++++++++-- lib/Quox/Name.idr | 7 ++++--- lib/Quox/Parser/Syntax.idr | 20 +++++++++++--------- lib/Quox/PrettyValExtra.idr | 10 ++++++++++ lib/Quox/Syntax/Dim.idr | 3 ++- lib/Quox/Syntax/Qty.idr | 7 ++++--- lib/quox-lib.ipkg | 5 ++++- 8 files changed, 51 insertions(+), 20 deletions(-) create mode 100644 lib/Quox/PrettyValExtra.idr diff --git a/exe/quox.ipkg b/exe/quox.ipkg index e20197a..fed30f4 100644 --- a/exe/quox.ipkg +++ b/exe/quox.ipkg @@ -1,7 +1,7 @@ package quox version = 0 -depends = base, contrib, elab-util, sop, quox-lib +depends = base, contrib, elab-util, pretty-show, quox-lib executable = quox main = Main diff --git a/lib/Quox/Loc.idr b/lib/Quox/Loc.idr index cd63e2f..5776ec9 100644 --- a/lib/Quox/Loc.idr +++ b/lib/Quox/Loc.idr @@ -1,6 +1,7 @@ ||| file locations module Quox.Loc +import Quox.PrettyValExtra import public Text.Bounded import Data.SortedMap import Derive.Prelude @@ -12,12 +13,12 @@ public export FileName : Type FileName = String -%runElab derive "Bounds" [Ord] +%runElab derive "Bounds" [Ord, PrettyVal] public export data Loc_ = NoLoc | YesLoc FileName Bounds %name Loc_ loc -%runElab derive "Loc_" [Eq, Ord, Show] +%runElab derive "Loc_" [Eq, Ord, Show, PrettyVal] ||| a wrapper for locations which are always considered equal @@ -39,6 +40,18 @@ public export %inline makeLoc : FileName -> Bounds -> Loc makeLoc = L .: YesLoc +public export %inline +loc : FileName -> (sl, sc, el, ec : Int) -> Loc +loc file sl sc el ec = makeLoc file $ MkBounds sl sc el ec + +export +PrettyVal Loc where + prettyVal (L NoLoc) = Con "noLoc" [] + prettyVal (L (YesLoc file (MkBounds sl sc el ec))) = + Con "loc" [prettyVal file, + prettyVal sl, prettyVal sc, + prettyVal el, prettyVal ec] + export onlyStart_ : Loc_ -> Loc_ diff --git a/lib/Quox/Name.idr b/lib/Quox/Name.idr index ce34c29..6c81091 100644 --- a/lib/Quox/Name.idr +++ b/lib/Quox/Name.idr @@ -2,6 +2,7 @@ module Quox.Name import Quox.Loc import Quox.CharExtra +import Quox.PrettyValExtra import public Data.SnocList import Data.List import Control.Eff @@ -23,7 +24,7 @@ data BaseName = UN String -- user-given name | MN String NameSuf -- machine-generated name | Unused -- "_" -%runElab derive "BaseName" [Eq, Ord] +%runElab derive "BaseName" [Eq, Ord, PrettyVal] export baseStr : BaseName -> String @@ -66,7 +67,7 @@ record PName where constructor MakePName mods : Mods base : PBaseName -%runElab derive "PName" [Eq, Ord] +%runElab derive "PName" [Eq, Ord, PrettyVal] export %inline fromPName : PName -> Name @@ -97,7 +98,7 @@ record BindName where constructor BN val : BaseName loc_ : Loc -%runElab derive "BindName" [Eq, Ord, Show] +%runElab derive "BindName" [Eq, Ord, Show, PrettyVal] export Located BindName where n.loc = n.loc_ export Relocatable BindName where setLoc loc (BN x _) = BN x loc diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index af92211..f2f6180 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -3,6 +3,7 @@ module Quox.Parser.Syntax import public Quox.Loc import public Quox.Syntax import public Quox.Definition +import Quox.PrettyValExtra import Derive.Prelude %hide TT.Name @@ -14,7 +15,7 @@ import Derive.Prelude public export data PatVar = Unused Loc | PV PBaseName Loc %name PatVar v -%runElab derive "PatVar" [Eq, Ord, Show] +%runElab derive "PatVar" [Eq, Ord, Show, PrettyVal] export Located PatVar where @@ -38,7 +39,7 @@ record PQty where val : Qty loc_ : Loc %name PQty qty -%runElab derive "PQty" [Eq, Ord, Show] +%runElab derive "PQty" [Eq, Ord, Show, PrettyVal] export Located PQty where q.loc = q.loc_ @@ -46,7 +47,7 @@ namespace PDim public export data PDim = K DimConst Loc | V PBaseName Loc %name PDim p, q - %runElab derive "PDim" [Eq, Ord, Show] + %runElab derive "PDim" [Eq, Ord, Show, PrettyVal] export Located PDim where @@ -56,7 +57,7 @@ Located PDim where public export data PTagVal = PT TagVal Loc %name PTagVal tag -%runElab derive "PTagVal" [Eq, Ord, Show] +%runElab derive "PTagVal" [Eq, Ord, Show, PrettyVal] namespace PTerm @@ -104,7 +105,7 @@ namespace PTerm | CaseBox PatVar PTerm Loc %name PCaseBody body -%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show] +%runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal] export Located PTerm where @@ -149,7 +150,7 @@ record PDefinition where term : PTerm loc_ : Loc %name PDefinition def -%runElab derive "PDefinition" [Eq, Ord, Show] +%runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal] export Located PDefinition where def.loc = def.loc_ @@ -157,7 +158,7 @@ public export data PDeclMod = PFail (Maybe String) Loc %name PDeclMod mod -%runElab derive "PDeclMod" [Eq, Ord, Show] +%runElab derive "PDeclMod" [Eq, Ord, Show, PrettyVal] mutual public export @@ -180,7 +181,8 @@ mutual PDef PDefinition | PNs PNamespace %name PDeclBody decl -%runElab deriveMutual ["PNamespace", "PDecl", "PDeclBody"] [Eq, Ord, Show] +%runElab deriveMutual ["PNamespace", "PDecl", "PDeclBody"] + [Eq, Ord, Show, PrettyVal] export Located PNamespace where ns.loc = ns.loc_ @@ -194,7 +196,7 @@ Located PDeclBody where public export data PTopLevel = PD PDecl | PLoad String Loc %name PTopLevel t -%runElab derive "PTopLevel" [Eq, Ord, Show] +%runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal] export Located PTopLevel where diff --git a/lib/Quox/PrettyValExtra.idr b/lib/Quox/PrettyValExtra.idr new file mode 100644 index 0000000..afd210e --- /dev/null +++ b/lib/Quox/PrettyValExtra.idr @@ -0,0 +1,10 @@ +module Quox.PrettyValExtra + +import Derive.Prelude +import public Text.Show.Value +import public Text.Show.PrettyVal +import public Text.Show.PrettyVal.Derive + +%language ElabReflection + +%runElab derive "SnocList" [PrettyVal] diff --git a/lib/Quox/Syntax/Dim.idr b/lib/Quox/Syntax/Dim.idr index 2229b6d..5f60a17 100644 --- a/lib/Quox/Syntax/Dim.idr +++ b/lib/Quox/Syntax/Dim.idr @@ -6,6 +6,7 @@ import Quox.Var import Quox.Syntax.Subst import Quox.Pretty import Quox.Context +import Quox.PrettyValExtra import Decidable.Equality import Control.Function @@ -18,7 +19,7 @@ import Derive.Prelude public export data DimConst = Zero | One %name DimConst e -%runElab derive "DimConst" [Eq, Ord, Show] +%runElab derive "DimConst" [Eq, Ord, Show, PrettyVal] ||| `ends l r e` returns `l` if `e` is `Zero`, or `r` if it is `One`. public export diff --git a/lib/Quox/Syntax/Qty.idr b/lib/Quox/Syntax/Qty.idr index 5133eff..d0d3d79 100644 --- a/lib/Quox/Syntax/Qty.idr +++ b/lib/Quox/Syntax/Qty.idr @@ -6,6 +6,7 @@ module Quox.Syntax.Qty import Quox.Pretty import Quox.Decidable +import Quox.PrettyValExtra import Data.DPair import Derive.Prelude @@ -20,7 +21,7 @@ import Derive.Prelude ||| - ω (or #): don't care. an ω variable *can* also be used 0/1 time public export data Qty = Zero | One | Any -%runElab derive "Qty" [Eq, Ord, Show] +%runElab derive "Qty" [Eq, Ord, Show, PrettyVal] %name Qty.Qty pi, rh @@ -79,7 +80,7 @@ lub p q = if p == q then p else Any ||| for the subject of a typing judgment. see @qtt, §2.3 for more detail public export data SQty = SZero | SOne -%runElab derive "SQty" [Eq, Ord, Show] +%runElab derive "SQty" [Eq, Ord, Show, PrettyVal] %name Qty.SQty sg ||| "σ ⨴ π" @@ -96,7 +97,7 @@ subjMult sg _ = sg ||| at runtime at all or not public export data GQty = GZero | GAny -%runElab derive "GQty" [Eq, Ord, Show] +%runElab derive "GQty" [Eq, Ord, Show, PrettyVal] %name GQty rh public export diff --git a/lib/quox-lib.ipkg b/lib/quox-lib.ipkg index de8d2f3..27063b1 100644 --- a/lib/quox-lib.ipkg +++ b/lib/quox-lib.ipkg @@ -5,7 +5,9 @@ authors = "rhiannon morris" sourceloc = "https://git.rhiannon.website/rhi/quox" license = "acsl" -depends = base, contrib, elab-util, sop, snocvect, eff, prettier +depends = + base, contrib, elab-util, sop, snocvect, eff, prettier, + pretty-show, parser-show modules = Text.PrettyPrint.Bernardy.Core.Decorate, @@ -14,6 +16,7 @@ modules = Quox.CharExtra, Quox.NatExtra, Quox.EffExtra, + Quox.PrettyValExtra, Quox.Decidable, Quox.No, Quox.Loc, From d6985cad55c8fa51b4434168a5c9697d51b31f7e Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 20 Oct 2023 04:53:49 +0200 Subject: [PATCH 018/133] tweak the pretty printer stuff slightly --- .../PrettyPrint/Bernardy/Core/Decorate.idr | 26 +++++++++++++------ 1 file changed, 18 insertions(+), 8 deletions(-) diff --git a/lib/Text/PrettyPrint/Bernardy/Core/Decorate.idr b/lib/Text/PrettyPrint/Bernardy/Core/Decorate.idr index c986889..6e73cc6 100644 --- a/lib/Text/PrettyPrint/Bernardy/Core/Decorate.idr +++ b/lib/Text/PrettyPrint/Bernardy/Core/Decorate.idr @@ -1,29 +1,37 @@ -- this module has to be called this because a module A.B's private elements are -- still visible to A.B.C, even if they're in different packages. which i don't -- think is a good idea but i also don't want to fork prettier over it +-- +-- also i adapted this code from stefan höck's prettier-ansi package +-- (https://github.com/idris-community/idris2-ansi) module Text.PrettyPrint.Bernardy.Core.Decorate import public Text.PrettyPrint.Bernardy.Core import Data.DPair import Data.String +import Derive.Prelude + +%language ElabReflection public export record Highlight where constructor MkHighlight before, after : String +%name Highlight h +%runElab derive "Highlight" [Eq] export -emptyHL : Highlight -> Bool -emptyHL (MkHighlight before after) = before == "" && after == "" +emptyHL : Highlight +emptyHL = MkHighlight "" "" --- taken from prettier-ansi +-- lifted from prettier-ansi private decorateImpl : Highlight -> (ss : SnocList String) -> (0 _ : NonEmptySnoc ss) => Subset (SnocList String) NonEmptySnoc -decorateImpl h [ SnocList String -> SnocList String @@ -35,17 +43,19 @@ decorateImpl h (sx :< x) = Element (go [] sx :< (x ++ h.after)) %search ||| changing its stats like width or height. export decorateLayout : Highlight -> Layout -> Layout -decorateLayout h l@(MkLayout content stats) = - if emptyHL h then l else +decorateLayout h (MkLayout content stats) = layout (decorateImpl h content) stats ||| Decorate a `Doc` with the given highlighting *without* ||| changing its stats like width or height. export -decorate : {opts : _} -> Highlight -> Doc opts -> Doc opts -decorate h doc = doc >>= \l => pure (decorateLayout h l) +decorate : {opts : LayoutOpts} -> Highlight -> Doc opts -> Doc opts +decorate h doc = + if h == emptyHL then doc else doc >>= pure . decorateLayout h +-- this function has nothing to do with highlighting but it's here because it +-- _also_ needs access to the private stuff ||| render a doc with no line breaks at all export renderInfinite : Doc opts -> String From b651ed54478eb9b9ca46015d6507ee5eb630e03b Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 20 Oct 2023 05:23:56 +0200 Subject: [PATCH 019/133] LoadFile does the parsing --- lib/Quox/Parser/FromParser.idr | 11 +++++------ lib/Quox/Parser/LoadFile.idr | 26 ++++++++++++++------------ lib/Quox/Parser/Parser.idr | 4 ++-- lib/Quox/Parser/Syntax.idr | 5 +++++ 4 files changed, 26 insertions(+), 20 deletions(-) diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 57bf939..e537962 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -19,6 +19,7 @@ import System.File import System.Path import Data.IORef + %hide Typing.Error %hide Lexer.Error %hide Parser.Error @@ -63,9 +64,9 @@ fromParserIO : (MonadRec io, HasIO io) => IncludePath -> IORef SeenSet -> IORef NameSuf -> IORef Definitions -> Eff FromParserIO a -> io (Either Error a) -fromParserIO inc seen suf defs act = liftIO $ fromIOErr $ do - runEff act $ with Union.(::) - [handleLoadFileIOE LoadError seen inc, +fromParserIO inc seen suf defs act = + liftIO $ fromIOErr $ runEff act $ with Union.(::) + [handleLoadFileIOE LoadError WrapParseError seen inc, handleExcept (\e => ioLeft e), handleStateIORef defs, handleStateIORef !(newIORef [<]), @@ -392,9 +393,7 @@ mutual loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition) loadProcessFile loc file = case !(loadFile loc file) of - Just inp => do - tl <- either (throw . WrapParseError file) pure $ lexParseInput file inp - concat <$> traverse fromPTopLevel tl + Just tl => concat <$> traverse fromPTopLevel tl Nothing => pure [] ||| populates the `defs` field of the state diff --git a/lib/Quox/Parser/LoadFile.idr b/lib/Quox/Parser/LoadFile.idr index 2935fb5..720a480 100644 --- a/lib/Quox/Parser/LoadFile.idr +++ b/lib/Quox/Parser/LoadFile.idr @@ -1,5 +1,7 @@ module Quox.Parser.LoadFile +import public Quox.Parser.Syntax +import Quox.Parser.Parser import Quox.Loc import Quox.EffExtra import Data.IORef @@ -20,7 +22,7 @@ data LoadFileL : (lbl : k) -> Type -> Type where [search lbl] Seen : FilePath -> LoadFileL lbl Bool SetSeen : FilePath -> LoadFileL lbl () - DoLoad : Loc -> FilePath -> LoadFileL lbl String + DoLoad : Loc -> FilePath -> LoadFileL lbl PFile public export LoadFile : Type -> Type @@ -47,11 +49,11 @@ setSeen = setSeenAt () export doLoadAt : (0 lbl : k) -> Has (LoadFileL lbl) fs => - Loc -> FilePath -> Eff fs String + Loc -> FilePath -> Eff fs PFile doLoadAt lbl loc file = send $ DoLoad {lbl} loc file export %inline -doLoad : Has LoadFile fs => Loc -> FilePath -> Eff fs String +doLoad : Has LoadFile fs => Loc -> FilePath -> Eff fs PFile doLoad = doLoadAt () @@ -63,10 +65,6 @@ public export IncludePath : Type IncludePath = List String -public export -ErrorWrapper : Type -> Type -ErrorWrapper e = Loc -> FilePath -> FileError -> e - export covering readFileFrom : HasIO io => IncludePath -> FilePath -> io (Either FileError String) @@ -76,23 +74,27 @@ readFileFrom inc f = Nothing => pure $ Left $ FileNotFound export covering -handleLoadFileIOE : ErrorWrapper e -> +handleLoadFileIOE : (Loc -> FilePath -> FileError -> e) -> + (FilePath -> Parser.Error -> e) -> IORef SeenSet -> IncludePath -> LoadFileL lbl a -> IOErr e a -handleLoadFileIOE inj seen inc = \case +handleLoadFileIOE injf injp seen inc = \case Seen f => contains f <$> readIORef seen SetSeen f => modifyIORef seen $ insert f - DoLoad l f => readFileFrom inc f >>= either (ioLeft . inj l f) pure + DoLoad l f => + case !(readFileFrom inc f) of + Left err => ioLeft $ injf l f err + Right str => either (ioLeft . injp f) pure $ lexParseInput f str export loadFileAt : (0 lbl : k) -> Has (LoadFileL lbl) fs => - Loc -> FilePath -> Eff fs (Maybe String) + Loc -> FilePath -> Eff fs (Maybe PFile) loadFileAt lbl loc file = if !(seenAt lbl file) then pure Nothing else Just <$> doLoadAt lbl loc file <* setSeenAt lbl file export -loadFile : Has LoadFile fs => Loc -> FilePath -> Eff fs (Maybe String) +loadFile : Has LoadFile fs => Loc -> FilePath -> Eff fs (Maybe PFile) loadFile = loadFileAt () diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index 8fb0dcd..a5ed716 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -641,7 +641,7 @@ topLevel : FileName -> Grammar True PTopLevel topLevel fname = load fname <|> [|PD $ decl fname|] export -input : FileName -> Grammar False (List PTopLevel) +input : FileName -> Grammar False PFile input fname = [] <$ eof <|> [|(topLevel fname <* commit) :: assert_total input fname|] @@ -650,5 +650,5 @@ lexParseTerm : FileName -> String -> Either Error PTerm lexParseTerm = lexParseWith . term export -lexParseInput : FileName -> String -> Either Error (List PTopLevel) +lexParseInput : FileName -> String -> Either Error PFile lexParseInput = lexParseWith . input diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index f2f6180..8edf657 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -208,3 +208,8 @@ public export fromNat : Nat -> Loc -> PTerm fromNat 0 loc = Zero loc fromNat (S k) loc = Succ (fromNat k loc) loc + + +public export +PFile : Type +PFile = List PTopLevel From fbb862c88beb0c03a79b944ee470414f8be8cd7c Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 20 Oct 2023 05:28:42 +0200 Subject: [PATCH 020/133] %default total --- lib/Quox/Parser/FromParser/Error.idr | 2 + lib/Quox/Typing/Error.idr | 313 ++++++++++++++------------- 2 files changed, 161 insertions(+), 154 deletions(-) diff --git a/lib/Quox/Parser/FromParser/Error.idr b/lib/Quox/Parser/FromParser/Error.idr index 301ff59..44cd0db 100644 --- a/lib/Quox/Parser/FromParser/Error.idr +++ b/lib/Quox/Parser/FromParser/Error.idr @@ -7,6 +7,8 @@ import System.File import Quox.Pretty +%default total + %hide Text.PrettyPrint.Prettyprinter.Doc.infixr.(<++>) diff --git a/lib/Quox/Typing/Error.idr b/lib/Quox/Typing/Error.idr index a48b4d7..1589612 100644 --- a/lib/Quox/Typing/Error.idr +++ b/lib/Quox/Typing/Error.idr @@ -13,6 +13,8 @@ import Derive.Prelude %language ElabReflection %hide TT.Name +%default total + public export record NameContexts d n where @@ -246,162 +248,165 @@ where hangDSingle "with quantities" $ separateTight !commaD $ toSnocList' !(traverse prettyQty qs)] -export -prettyErrorNoLoc : {opts : _} -> (showContext : Bool) -> Error -> - Eff Pretty (Doc opts) -prettyErrorNoLoc showContext = \case - ExpectedTYPE _ ctx s => - hangDSingle "expected a type universe, but got" - !(prettyTerm ctx.dnames ctx.tnames s) - - ExpectedPi _ ctx s => - hangDSingle "expected a function type, but got" - !(prettyTerm ctx.dnames ctx.tnames s) - - ExpectedSig _ ctx s => - hangDSingle "expected a pair type, but got" - !(prettyTerm ctx.dnames ctx.tnames s) - - ExpectedEnum _ ctx s => - hangDSingle "expected an enumeration type, but got" - !(prettyTerm ctx.dnames ctx.tnames s) - - ExpectedEq _ ctx s => - hangDSingle "expected an enumeration type, but got" - !(prettyTerm ctx.dnames ctx.tnames s) - - ExpectedNat _ ctx s => - hangDSingle - ("expected the type" <++> - !(prettyTerm [<] [<] $ Nat noLoc) <+> ", but got") - !(prettyTerm ctx.dnames ctx.tnames s) - - ExpectedBOX _ ctx s => - hangDSingle "expected a box type, but got" - !(prettyTerm ctx.dnames ctx.tnames s) - - BadUniverse _ k l => pure $ - sep ["the universe level" <++> !(prettyUniverse k), - "is not strictly less than" <++> !(prettyUniverse l)] - - TagNotIn _ tag set => - hangDSingle (hsep ["the tag", !(prettyTag tag), "is not contained in"]) - !(prettyTerm [<] [<] $ Enum set noLoc) - - BadCaseEnum _ head body => sep <$> sequence - [hangDSingle "case expression has head of type" - !(prettyTerm [<] [<] $ Enum head noLoc), - hangDSingle "but cases for" - !(prettyTerm [<] [<] $ Enum body noLoc)] - - BadQtys _ what ctx arms => - hangDSingle (text "inconsistent variable usage in \{what}") $ - sep !(printCaseQtys ctx ctx.tnames arms) - - ClashT _ ctx mode ty s t => - inEContext ctx . sep =<< sequence - [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s), - hangDSingle (text "is not \{prettyMode mode}") - !(prettyTerm [<] ctx.tnames t), - hangDSingle "at type" !(prettyTerm [<] ctx.tnames ty)] - - ClashTy _ ctx mode a b => - inEContext ctx . sep =<< sequence - [hangDSingle "the type" !(prettyTerm [<] ctx.tnames a), - hangDSingle (text "is not \{prettyMode mode}") - !(prettyTerm [<] ctx.tnames b)] - - ClashE _ ctx mode e f => - inEContext ctx . sep =<< sequence - [hangDSingle "the term" !(prettyElim [<] ctx.tnames e), - hangDSingle (text "is not \{prettyMode mode}") - !(prettyElim [<] ctx.tnames f)] - - ClashU _ mode k l => pure $ - sep ["the universe level" <++> !(prettyUniverse k), - text "is not \{prettyModeU mode}" <++> !(prettyUniverse l)] - - ClashQ _ pi rh => pure $ - sep ["the quantity" <++> !(prettyQty pi), - "is not equal to" <++> !(prettyQty rh)] - - NotInScope _ x => pure $ - hsep [!(prettyFree x), "is not in scope"] - - NotType _ ctx s => - inTContext ctx . sep =<< sequence - [hangDSingle "the term" !(prettyTerm ctx.dnames ctx.tnames s), - pure "is not a type"] - - WrongType _ ctx ty s => - inEContext ctx . sep =<< sequence - [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s), - hangDSingle "cannot have type" !(prettyTerm [<] ctx.tnames ty)] - - MissingEnumArm _ tag tags => pure $ - sep [hsep ["the tag", !(prettyTag tag), "is not contained in"], - !(prettyTerm [<] [<] $ Enum (fromList tags) noLoc)] - - WhileChecking ctx sg s a err => - [|vappendBlank - (inTContext ctx . sep =<< sequence - [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s), - hangDSingle "has type" !(prettyTerm ctx.dnames ctx.tnames a), - hangDSingle "with quantity" !(prettyQty sg.qty)]) - (prettyErrorNoLoc showContext err)|] - - WhileCheckingTy ctx a k err => - [|vappendBlank - (inTContext ctx . sep =<< sequence - [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a), - pure $ text $ isTypeInUniverse k]) - (prettyErrorNoLoc showContext err)|] - - WhileInferring ctx sg e err => - [|vappendBlank - (inTContext ctx . sep =<< sequence - [hangDSingle "while inferring the type of" - !(prettyElim ctx.dnames ctx.tnames e), - hangDSingle "with quantity" !(prettyQty sg.qty)]) - (prettyErrorNoLoc showContext err)|] - - WhileComparingT ctx mode sg a s t err => - [|vappendBlank - (inEContext ctx . sep =<< sequence - [hangDSingle "while checking that" !(prettyTerm [<] ctx.tnames s), - hangDSingle (text "is \{prettyMode mode}") - !(prettyTerm [<] ctx.tnames t), - hangDSingle "at type" !(prettyTerm [<] ctx.tnames a), - hangDSingle "with quantity" !(prettyQty sg.qty)]) - (prettyErrorNoLoc showContext err)|] - - WhileComparingE ctx mode sg e f err => - [|vappendBlank - (inEContext ctx . sep =<< sequence - [hangDSingle "while checking that" !(prettyElim [<] ctx.tnames e), - hangDSingle (text "is \{prettyMode mode}") - !(prettyElim [<] ctx.tnames f), - hangDSingle "with quantity" !(prettyQty sg.qty)]) - (prettyErrorNoLoc showContext err)|] - -where - vappendBlank : Doc opts -> Doc opts -> Doc opts - vappendBlank a b = flush a `vappend` b +parameters {opts : LayoutOpts} (showContext : Bool) + export + inContext' : Bool -> a -> (a -> Eff Pretty (Doc opts)) -> + Doc opts -> Eff Pretty (Doc opts) + inContext' null ctx f doc = + if showContext && not null then + pure $ vappend doc (sep ["in context", !(f ctx)]) + else pure doc + export %inline inTContext : TyContext d n -> Doc opts -> Eff Pretty (Doc opts) - inTContext ctx doc = - if showContext && not (null ctx) then - pure $ vappend doc (sep ["in context", !(prettyTyContext ctx)]) - else pure doc + inTContext ctx = inContext' (null ctx) ctx prettyTyContext + export %inline inEContext : EqContext n -> Doc opts -> Eff Pretty (Doc opts) - inEContext ctx doc = - if showContext && not (null ctx) then - pure $ vappend doc (sep ["in context", !(prettyEqContext ctx)]) - else pure doc + inEContext ctx = inContext' (null ctx) ctx prettyEqContext -export -prettyError : {opts : _} -> (showContext : Bool) -> - Error -> Eff Pretty (Doc opts) -prettyError showContext err = sep <$> sequence - [prettyLoc err.loc, indentD =<< prettyErrorNoLoc showContext err] + export + prettyErrorNoLoc : Error -> Eff Pretty (Doc opts) + prettyErrorNoLoc err0 = case err0 of + ExpectedTYPE _ ctx s => + hangDSingle "expected a type universe, but got" + !(prettyTerm ctx.dnames ctx.tnames s) + + ExpectedPi _ ctx s => + hangDSingle "expected a function type, but got" + !(prettyTerm ctx.dnames ctx.tnames s) + + ExpectedSig _ ctx s => + hangDSingle "expected a pair type, but got" + !(prettyTerm ctx.dnames ctx.tnames s) + + ExpectedEnum _ ctx s => + hangDSingle "expected an enumeration type, but got" + !(prettyTerm ctx.dnames ctx.tnames s) + + ExpectedEq _ ctx s => + hangDSingle "expected an enumeration type, but got" + !(prettyTerm ctx.dnames ctx.tnames s) + + ExpectedNat _ ctx s => + hangDSingle + ("expected the type" <++> + !(prettyTerm [<] [<] $ Nat noLoc) <+> ", but got") + !(prettyTerm ctx.dnames ctx.tnames s) + + ExpectedBOX _ ctx s => + hangDSingle "expected a box type, but got" + !(prettyTerm ctx.dnames ctx.tnames s) + + BadUniverse _ k l => pure $ + sep ["the universe level" <++> !(prettyUniverse k), + "is not strictly less than" <++> !(prettyUniverse l)] + + TagNotIn _ tag set => + hangDSingle (hsep ["the tag", !(prettyTag tag), "is not contained in"]) + !(prettyTerm [<] [<] $ Enum set noLoc) + + BadCaseEnum _ head body => sep <$> sequence + [hangDSingle "case expression has head of type" + !(prettyTerm [<] [<] $ Enum head noLoc), + hangDSingle "but cases for" + !(prettyTerm [<] [<] $ Enum body noLoc)] + + BadQtys _ what ctx arms => + hangDSingle (text "inconsistent variable usage in \{what}") $ + sep !(printCaseQtys ctx ctx.tnames arms) + + ClashT _ ctx mode ty s t => + inEContext ctx . sep =<< sequence + [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s), + hangDSingle (text "is not \{prettyMode mode}") + !(prettyTerm [<] ctx.tnames t), + hangDSingle "at type" !(prettyTerm [<] ctx.tnames ty)] + + ClashTy _ ctx mode a b => + inEContext ctx . sep =<< sequence + [hangDSingle "the type" !(prettyTerm [<] ctx.tnames a), + hangDSingle (text "is not \{prettyMode mode}") + !(prettyTerm [<] ctx.tnames b)] + + ClashE _ ctx mode e f => + inEContext ctx . sep =<< sequence + [hangDSingle "the term" !(prettyElim [<] ctx.tnames e), + hangDSingle (text "is not \{prettyMode mode}") + !(prettyElim [<] ctx.tnames f)] + + ClashU _ mode k l => pure $ + sep ["the universe level" <++> !(prettyUniverse k), + text "is not \{prettyModeU mode}" <++> !(prettyUniverse l)] + + ClashQ _ pi rh => pure $ + sep ["the quantity" <++> !(prettyQty pi), + "is not equal to" <++> !(prettyQty rh)] + + NotInScope _ x => pure $ + hsep [!(prettyFree x), "is not in scope"] + + NotType _ ctx s => + inTContext ctx . sep =<< sequence + [hangDSingle "the term" !(prettyTerm ctx.dnames ctx.tnames s), + pure "is not a type"] + + WrongType _ ctx ty s => + inEContext ctx . sep =<< sequence + [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s), + hangDSingle "cannot have type" !(prettyTerm [<] ctx.tnames ty)] + + MissingEnumArm _ tag tags => pure $ + sep [hsep ["the tag", !(prettyTag tag), "is not contained in"], + !(prettyTerm [<] [<] $ Enum (fromList tags) noLoc)] + + WhileChecking ctx sg s a err => + [|vappendBlank + (inTContext ctx . sep =<< sequence + [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames s), + hangDSingle "has type" !(prettyTerm ctx.dnames ctx.tnames a), + hangDSingle "with quantity" !(prettyQty sg.qty)]) + (prettyErrorNoLoc err)|] + + WhileCheckingTy ctx a k err => + [|vappendBlank + (inTContext ctx . sep =<< sequence + [hangDSingle "while checking" !(prettyTerm ctx.dnames ctx.tnames a), + pure $ text $ isTypeInUniverse k]) + (prettyErrorNoLoc err)|] + + WhileInferring ctx sg e err => + [|vappendBlank + (inTContext ctx . sep =<< sequence + [hangDSingle "while inferring the type of" + !(prettyElim ctx.dnames ctx.tnames e), + hangDSingle "with quantity" !(prettyQty sg.qty)]) + (prettyErrorNoLoc err)|] + + WhileComparingT ctx mode sg a s t err => + [|vappendBlank + (inEContext ctx . sep =<< sequence + [hangDSingle "while checking that" !(prettyTerm [<] ctx.tnames s), + hangDSingle (text "is \{prettyMode mode}") + !(prettyTerm [<] ctx.tnames t), + hangDSingle "at type" !(prettyTerm [<] ctx.tnames a), + hangDSingle "with quantity" !(prettyQty sg.qty)]) + (prettyErrorNoLoc err)|] + + WhileComparingE ctx mode sg e f err => + [|vappendBlank + (inEContext ctx . sep =<< sequence + [hangDSingle "while checking that" !(prettyElim [<] ctx.tnames e), + hangDSingle (text "is \{prettyMode mode}") + !(prettyElim [<] ctx.tnames f), + hangDSingle "with quantity" !(prettyQty sg.qty)]) + (prettyErrorNoLoc err)|] + + where + vappendBlank : Doc opts -> Doc opts -> Doc opts + vappendBlank a b = flush a `vappend` b + + export + prettyError : Error -> Eff Pretty (Doc opts) + prettyError err = sep <$> sequence + [prettyLoc err.loc, indentD =<< prettyErrorNoLoc err] From 421eb220fd949e7ff7210ac6a7660ef2edbb8797 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 20 Oct 2023 06:09:20 +0200 Subject: [PATCH 021/133] erasure refactor --- lib/Quox/EffExtra.idr | 18 +++ lib/Quox/Untyped/Erase.idr | 221 +++++++++++++++--------------------- lib/Quox/Untyped/Syntax.idr | 5 +- lib/Quox/Whnf/Interface.idr | 2 +- 4 files changed, 113 insertions(+), 133 deletions(-) diff --git a/lib/Quox/EffExtra.idr b/lib/Quox/EffExtra.idr index d3c3692..55edfef 100644 --- a/lib/Quox/EffExtra.idr +++ b/lib/Quox/EffExtra.idr @@ -80,6 +80,24 @@ catchMaybe : (Has (Except e) fs, Length fs) => (e -> Eff fs a) -> Eff fs a -> Eff fs a catchMaybe = catchMaybeAt () + +export +rethrowAtWith : (0 lbl : tag) -> Has (ExceptL lbl e') fs => + (e -> e') -> Either e a -> Eff fs a +rethrowAtWith lbl f = rethrowAt lbl . mapFst f + +export +rethrowWith : Has (Except e') fs => (e -> e') -> Either e a -> Eff fs a +rethrowWith = rethrowAtWith () + +export +wrapErr' : Length fs => (e -> e') -> + Eff (ExceptL lbl e :: fs) a -> + Eff (ExceptL lbl e' :: fs) a +wrapErr' f act = + catchAt lbl (throwAt lbl . f) @{S Z} $ + lift @{subsetTail _} act + export wrapErrAt : (0 lbl : tag) -> (Has (ExceptL lbl e) fs, Length fs) => (e -> e) -> Eff fs a -> Eff fs a diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index f8e650d..afa5bc3 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -1,11 +1,12 @@ module Quox.Untyped.Erase -import Quox.Definition +import Quox.Definition as Q import Quox.Syntax.Term.Base as Q import Quox.Syntax.Term.Subst import Quox.Untyped.Syntax as U -import Quox.Typing.Context +import Quox.Typing import Quox.Whnf +import Quox.Pretty import Quox.EffExtra import Data.Singleton @@ -35,19 +36,8 @@ ifErased pi x y = case isErased pi of public export -EContext : Nat -> Type -EContext = Context' IsErased - -public export -record ErasureContext d n where - constructor MkEContexts - {auto dimLen : Singleton d} - {auto termLen : Singleton n} - dnames : BContext d - tnames : BContext n - tctx : TContext d n - erased : EContext n -%name ErasureContext ctx +ErasureContext : Nat -> Nat -> Type +ErasureContext = TyContext public export @@ -58,35 +48,46 @@ TypeError = Typing.Error.Error public export data Error = CompileTimeOnly (ErasureContext d n) (Q.Term d n) -| ErasedVar (ErasureContext d n) (Var n) -| NotInScope Name | WrapTypeError TypeError +| Postulate Loc Name +%name Error err + +private %inline +notInScope : Loc -> Name -> Error +notInScope = WrapTypeError .: NotInScope + +export +Located Error where + (CompileTimeOnly _ s).loc = s.loc + (WrapTypeError err).loc = err.loc + (Postulate loc _).loc = loc + + +parameters {opts : LayoutOpts} (showContext : Bool) + export + prettyErrorNoLoc : Error -> Eff Pretty (Doc opts) + prettyErrorNoLoc (CompileTimeOnly ctx s) = + inTContext showContext ctx $ + sep ["the term", !(prettyTerm ctx.dnames ctx.tnames s), + "only exists at compile time"] + prettyErrorNoLoc (WrapTypeError err) = + prettyErrorNoLoc showContext err + prettyErrorNoLoc (Postulate _ x) = + pure $ sep [!(prettyFree x), "is a postulate with no definition"] + + export + prettyError : Error -> Eff Pretty (Doc opts) + prettyError err = sep <$> sequence + [prettyLoc err.loc, indentD =<< prettyErrorNoLoc err] + public export Erase : List (Type -> Type) Erase = [Except Error, DefsReader, NameGen] - -export -toWhnfContext : ErasureContext d n -> WhnfContext d n -toWhnfContext (MkEContexts {dnames, tnames, tctx, _}) = - MkWhnfContext {dnames, tnames, tctx} - -export -(.names) : ErasureContext d n -> NameContexts d n -ctx.names = MkNameContexts ctx.dnames ctx.tnames - - export liftWhnf : Eff Whnf a -> Eff Erase a -liftWhnf act = runEff act - [\x => send x, \case (Err e) => throw $ WrapTypeError e] - -export covering -whnf0 : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => - ErasureContext d n -> SQty -> - tm d n -> Eff Erase (tm d n) -whnf0 ctx sg tm = liftWhnf $ whnf0 !(askAt DEFS) (toWhnfContext ctx) sg tm +liftWhnf act = lift $ wrapErr' WrapTypeError act export covering computeElimType : ErasureContext d n -> SQty -> Elim d n -> Eff Erase (Term d n) @@ -98,72 +99,17 @@ computeElimType ctx sg e = do computeElimType defs ctx sg e -parameters (ctx : ErasureContext d n) (loc : Loc) - private covering %macro - expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> TypeError) -> - TTImp -> TTImp -> Elab (Term d n -> Eff Erase a) - expect k l r = do - f <- check `(\case ~(l) => Just ~(r); _ => Nothing) - pure $ \t => - let err = throw $ WrapTypeError $ k loc ctx.names t in - maybe err pure . f =<< whnf0 ctx SZero t - - export covering %inline - expectTYPE : Term d n -> Eff Erase Universe - expectTYPE = expect ExpectedTYPE `(TYPE {l, _}) `(l) - - export covering %inline - expectPi : Term d n -> Eff Erase (Qty, Term d n, ScopeTerm d n) - expectPi = expect ExpectedPi `(Pi {qty, arg, res, _}) `((qty, arg, res)) - - export covering %inline - expectSig : Term d n -> Eff Erase (Term d n, ScopeTerm d n) - expectSig = expect ExpectedSig `(Sig {fst, snd, _}) `((fst, snd)) - - export covering %inline - expectEnum : Term d n -> Eff Erase (SortedSet TagVal) - expectEnum = expect ExpectedEnum `(Enum {cases, _}) `(cases) - - export covering %inline - expectEq : Term d n -> Eff Erase (DScopeTerm d n, Term d n, Term d n) - expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r)) - - export covering %inline - expectNat : Term d n -> Eff Erase () - expectNat = expect ExpectedNat `(Nat {}) `(()) - - export covering %inline - expectBOX : Term d n -> Eff Erase (Qty, Term d n) - expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty)) - - -export -extendTyN : CtxExtension d n1 n2 -> - ErasureContext d n1 -> ErasureContext d n2 -extendTyN tel (MkEContexts {termLen, dnames, tnames, tctx, erased}) = - let (qs, xs, ss) = unzip3 tel in - MkEContexts { - dnames, - tnames = tnames . xs, - tctx = tctx . ss, - erased = erased . map isErased qs, - termLen = extendLen tel termLen - } - -export -extendTy : Qty -> BindName -> Term d n -> - ErasureContext d n -> ErasureContext d (S n) -extendTy pi x ty = extendTyN [< (pi, x, ty)] - -export -extendDim : BindName -> ErasureContext d n -> ErasureContext (S d) n -extendDim i (MkEContexts {dimLen, dnames, tnames, tctx, erased}) = - MkEContexts { - tnames, erased, - dimLen = [|S dimLen|], - dnames = dnames :< i, - tctx = map (dweakT 1) tctx - } +private %macro +wrapExpect : TTImp -> + Elab (TyContext d n -> Loc -> Term d n -> Eff Erase a) +wrapExpect f {a} = do + f' <- check `(\x => ~(f) x) + pure $ \ctx, loc, s => wrapExpect' f' ctx loc s +where + wrapExpect' : (Q.Definitions -> TyContext d n -> SQty -> Loc -> Term d n -> + Eff [Except TypeError, NameGen] a) -> + TyContext d n -> Loc -> Term d n -> Eff Erase a + wrapExpect' f ctx loc s = liftWhnf $ f !(askAt DEFS) ctx SZero loc s public export @@ -173,10 +119,16 @@ record EraseElimResult d n where term : U.Term n +-- "Ψ | Γ | Σ ⊢ s ⤋ s' ⇐ A" for `s' <- eraseTerm (Ψ,Γ,Σ) A s` +-- +-- in the below comments, Ψ, Γ, Σ are implicit and +-- only their extensions are written export covering eraseTerm : ErasureContext d n -> (ty, tm : Q.Term d n) -> Eff Erase (U.Term n) + +-- "Ψ | Γ | Σ ⊢ e ⤋ e' ⇒ A" for `EraRes A e' <- eraseElim (Ψ,Γ,Σ) e` export covering eraseElim : ErasureContext d n -> (tm : Q.Elim d n) -> Eff Erase (EraseElimResult d n) @@ -187,14 +139,14 @@ eraseTerm ctx _ s@(TYPE {}) = eraseTerm ctx _ s@(Pi {}) = throw $ CompileTimeOnly ctx s --- π.x : A ⊢ s ⤋ s' ⇐ B +-- x : A | π.x ⊢ s ⤋ s' ⇐ B -- ---------------------------------------- -- (λ x ⇒ s) ⤋ (λ x ⇒ s') ⇐ π.(x : A) → B -- -- becomes a lambda even when π = 0, -- to preserve expected evaluation order eraseTerm ctx ty (Lam body loc) = do - (qty, arg, res) <- expectPi ctx loc ty + (qty, arg, res) <- wrapExpect `(expectPi) ctx loc ty let x = body.name body <- eraseTerm (extendTy qty x arg ctx) res.term body.term pure $ U.Lam x body loc @@ -206,7 +158,7 @@ eraseTerm ctx _ s@(Sig {}) = -- --------------------------------- -- (s, t) ⤋ (s', t') ⇐ (x : A) × B eraseTerm ctx ty (Pair fst snd loc) = do - (a, b) <- expectSig ctx loc ty + (a, b) <- wrapExpect `(expectSig) ctx loc ty let b = sub1 b (Ann fst a a.loc) fst <- eraseTerm ctx a fst snd <- eraseTerm ctx b snd @@ -226,7 +178,7 @@ eraseTerm ctx ty s@(Eq {}) = -- --------------------------------- -- (δ 𝑖 ⇒ s) ⤋ s' ⇐ Eq (𝑖 ⇒ A) l r eraseTerm ctx ty (DLam body loc) = do - a <- fst <$> expectEq ctx loc ty + a <- fst <$> wrapExpect `(expectEq) ctx loc ty eraseTerm (extendDim body.name ctx) a.term body.term eraseTerm ctx _ s@(Nat {}) = @@ -252,7 +204,7 @@ eraseTerm ctx ty s@(BOX {}) = -- -------------------- -- [s] ⤋ s' ⇐ [π.A] eraseTerm ctx ty (Box val loc) = do - (qty, a) <- expectBOX ctx loc ty + (qty, a) <- wrapExpect `(expectBOX) ctx loc ty case isErased qty of Erased => pure $ Erased loc Kept => eraseTerm ctx a val @@ -274,16 +226,16 @@ eraseTerm ctx ty (DCloT (Sub term th)) = -- x ⤋ x ⇒ A eraseElim ctx e@(F x u loc) = do Just def <- asksAt DEFS $ lookup x - | Nothing => throw $ NotInScope x + | Nothing => throw $ notInScope loc x case isErased def.qty.qty of Erased => throw $ CompileTimeOnly ctx $ E e Kept => pure $ EraRes (def.typeWith ctx.dimLen ctx.termLen) $ F x loc --- π ≠ 0 --- ---------------------------- --- Γ, π.x : A, Γ' ⊢ x ⤋ x ⇒ A +-- π.x ∈ Σ π ≠ 0 +-- ----------------- +-- x ⤋ x ⇒ A eraseElim ctx e@(B i loc) = do - case ctx.erased !!! i of + case isErased $ ctx.qtys !!! i of Erased => throw $ CompileTimeOnly ctx $ E e Kept => pure $ EraRes (ctx.tctx !! i) $ B i loc @@ -296,7 +248,7 @@ eraseElim ctx e@(B i loc) = do -- f s ⤋ f' ⌷ ⇒ B[s/x] eraseElim ctx (App fun arg loc) = do efun <- eraseElim ctx fun - (qty, targ, tres) <- expectPi ctx loc efun.type + (qty, targ, tres) <- wrapExpect `(expectPi) ctx loc efun.type let ty = sub1 tres (Ann arg targ arg.loc) case isErased qty of Erased => pure $ EraRes ty $ App efun.term (Erased arg.loc) loc @@ -304,7 +256,7 @@ eraseElim ctx (App fun arg loc) = do pure $ EraRes ty $ App efun.term arg loc -- e ⤋ e' ⇒ (x : A) × B --- ρ.x : A, ρ.y : B ⊢ s ⤋ s' ⇐ R[((x,y) ∷ (x : A) × B)/z] +-- x : A, y : B | ρ.x, ρ.y ⊢ s ⤋ s' ⇐ R[((x,y) ∷ (x : A) × B)/z] -- x̃ ≔ if ρ = 0 then ⌷ else fst e' ỹ ≔ if ρ = 0 then ⌷ else snd e' -- ------------------------------------------------------------------- -- (caseρ e return z ⇒ R of {(x, y) ⇒ s}) ⤋ s'[x̃/x, ỹ/y] ⇒ R[e/z] @@ -312,7 +264,7 @@ eraseElim ctx (CasePair qty pair ret body loc) = do epair <- eraseElim ctx pair let ty = sub1 (ret // shift 2) $ Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 epair.type) loc - (tfst, tsnd) <- expectSig ctx loc epair.type + (tfst, tsnd) <- wrapExpect `(expectSig) ctx loc epair.type let [< x, y] = body.names let ctx' = extendTyN [< (qty, x, tfst), (qty, y, tsnd.term)] ctx body' <- eraseTerm ctx' ty body.term @@ -325,7 +277,7 @@ eraseElim ctx (CasePair qty pair ret body loc) = do -- fst e ⤋ fst e' ⇒ A eraseElim ctx (Fst pair loc) = do epair <- eraseElim ctx pair - a <- fst <$> expectSig ctx loc epair.type + a <- fst <$> wrapExpect `(expectSig) ctx loc epair.type pure $ EraRes a $ Fst epair.term loc -- e ⤋ e' ⇒ (x : A) × B @@ -333,7 +285,7 @@ eraseElim ctx (Fst pair loc) = do -- snd e ⤋ snd e' ⇒ B[fst e/x] eraseElim ctx (Snd pair loc) = do epair <- eraseElim ctx pair - b <- snd <$> expectSig ctx loc epair.type + b <- snd <$> wrapExpect `(expectSig) ctx loc epair.type pure $ EraRes (sub1 b (Fst pair loc)) $ Snd epair.term loc -- case0 e return z ⇒ R of {} ⤋ absurd ⇒ R[e/z] @@ -364,13 +316,13 @@ eraseElim ctx e@(CaseEnum qty tag ret arms loc) = pure (t, rhs') pure $ EraRes ty $ CaseEnum etag.term arms loc --- n ⤋ n' ⇒ ℕ z ⤋ z' ⇐ R[zero∷ℕ/z] --- ρ.m : ℕ, ς.ih : R[m/z] ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z] --- --------------------------------------------------- --- caseρ n return z ⇒ R of {0 ⇒ z; succ m, ς.ih ⇒ s} --- ⤋ --- case n' of {0 ⇒ z'; succ m, ih ⇒ s'} --- ⇒ R[n/z] +-- n ⤋ n' ⇒ ℕ z ⤋ z' ⇐ R[zero∷ℕ/z] +-- m : ℕ, ih : R[m/z] | ρ.m, ς.ih ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z] +-- ----------------------------------------------------------- +-- caseρ n return z ⇒ R of {0 ⇒ z; succ m, ς.ih ⇒ s} +-- ⤋ +-- case n' of {0 ⇒ z'; succ m, ih ⇒ s'} +-- ⇒ R[n/z] eraseElim ctx (CaseNat qty qtyIH nat ret zero succ loc) = do let ty = sub1 ret nat enat <- eraseElim ctx nat @@ -384,16 +336,16 @@ eraseElim ctx (CaseNat qty qtyIH nat ret zero succ loc) = do pure $ EraRes ty $ CaseNat enat.term zero p ih succ loc -- b ⤋ b' ⇒ [π.A] π ≠ 0 --- πρ.x : A ⊢ s ⤋ s' ⇐ R[[x]∷[π.A]/z] +-- x : A | πρ.x ⊢ s ⤋ s' ⇐ R[[x]∷[π.A]/z] -- ------------------------------------------------------- -- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[b'/x] ⇒ R[b/z] -- --- b ⇒ [0.A] 0.x : A ⊢ s ⤋ s' ⇐ R[[x]∷[0.A]/z] +-- b ⇒ [0.A] x : A | 0.x ⊢ s ⤋ s' ⇐ R[[x]∷[0.A]/z] -- ------------------------------------------------------- -- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[⌷/x] ⇒ R[b/z] eraseElim ctx (CaseBox qty box ret body loc) = do tbox <- computeElimType ctx SOne box -- [fixme] is there any way to avoid this? - (pi, tinner) <- expectBOX ctx loc tbox + (pi, tinner) <- wrapExpect `(expectBOX) ctx loc tbox let ctx' = extendTy Zero body.name tinner ctx bty = sub1 (ret // shift 1) $ Ann (Box (BVT 0 loc) loc) (weakT 1 tbox) loc @@ -411,7 +363,7 @@ eraseElim ctx (CaseBox qty box ret body loc) = do -- f @r ⤋ f' ⇒ A‹r/𝑖› eraseElim ctx (DApp fun arg loc) = do efun <- eraseElim ctx fun - a <- fst <$> expectEq ctx loc efun.type + a <- fst <$> wrapExpect `(expectEq) ctx loc efun.type pure $ EraRes (dsub1 a arg) efun.term -- s ⤋ s' ⇐ A @@ -430,9 +382,6 @@ eraseElim ctx (Coe ty p q val loc) = do -- s ⤋ s' ⇐ A -- -------------------------------- -- comp A @p @q s @r {⋯} ⤋ s' ⇒ A --- --- [todo] is this ok? they are equal, but even so, --- maybe t₀ and t₁ have different performance characteristics eraseElim ctx (Comp ty p q val r zero one loc) = EraRes ty <$> eraseTerm ctx ty val @@ -444,3 +393,13 @@ eraseElim ctx (CloE (Sub term th)) = eraseElim ctx (DCloE (Sub term th)) = eraseElim ctx $ pushSubstsWith' th id term + + +export covering +eraseDef : Name -> Q.Definition -> Eff Erase U.Definition +eraseDef name (MkDef qty type body loc) = do + case isErased qty.qty of + Erased => pure ErasedDef + Kept => case body of + Concrete body => KeptDef <$> eraseTerm empty type body + Postulate => throw $ Postulate loc name diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 2a5a312..62dbbc3 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -65,9 +65,12 @@ Located (Term n) where (Erased loc).loc = loc +public export +data Definition = ErasedDef | KeptDef (Term 0) + public export 0 Definitions : Type -Definitions = SortedMap Name $ Term 0 +Definitions = SortedMap Name Definition parameters {opts : LayoutOpts} diff --git a/lib/Quox/Whnf/Interface.idr b/lib/Quox/Whnf/Interface.idr index 8a6a43a..eebdcc9 100644 --- a/lib/Quox/Whnf/Interface.idr +++ b/lib/Quox/Whnf/Interface.idr @@ -13,7 +13,7 @@ import public Control.Eff public export Whnf : List (Type -> Type) -Whnf = [NameGen, Except Error] +Whnf = [Except Error, NameGen] public export From 83ab871d61ff6e02fa4a78eec1fdaaa219a6c8de Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 20 Oct 2023 17:42:01 +0200 Subject: [PATCH 022/133] new main --- examples/fail.quox | 6 + exe/Main.idr | 203 +++++++++++++++++++++++---- exe/Options.idr | 158 +++++++++++++++++++++ lib/Quox/Parser/FromParser.idr | 2 + lib/Quox/Parser/FromParser/Error.idr | 5 + lib/Quox/Pretty.idr | 12 +- lib/Quox/Syntax/DimEq.idr | 27 ++-- lib/Quox/Untyped/Syntax.idr | 9 ++ 8 files changed, 388 insertions(+), 34 deletions(-) create mode 100644 exe/Options.idr diff --git a/examples/fail.quox b/examples/fail.quox index a3edac8..daf5c05 100644 --- a/examples/fail.quox +++ b/examples/fail.quox @@ -8,3 +8,9 @@ def repeat-enum-case : {a} → {a} = #[fail "duplicate tags"] def repeat-enum-type : {a, a} = 'a + +#[fail "double-def.X has already been defined"] +namespace double-def { + def0 X : ★ = {a} + def0 X : ★ = {a} +} diff --git a/exe/Main.idr b/exe/Main.idr index e522169..dbb7897 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -1,46 +1,201 @@ module Main -import Quox.Syntax +import Quox.Syntax as Q import Quox.Parser -import Quox.Definition +import Quox.Definition as Q import Quox.Pretty +import Quox.Untyped.Syntax as U +import Quox.Untyped.Erase +import Options -import System import Data.IORef import Data.SortedSet +import Text.Show.PrettyVal +import Text.Show.Pretty +import System +import System.File import Control.Eff -private -Opts : LayoutOpts -Opts = Opts 80 +%hide Doc.(>>=) +%hide Core.(>>=) + + +parameters {auto _ : HasIO io} (width : Nat) + private + putDoc : Doc (Opts width) -> io () + putDoc = putStr . render _ + + private + fPutDoc : File -> Doc (Opts width) -> io (Either FileError ()) + fPutDoc h = fPutStr h . render _ + + private + putDocErr : Doc (Opts width) -> io () + putDocErr = ignore . fPutDoc stderr + + private + die : Doc (Opts width) -> io a + die err = do putDocErr err; exitFailure private -putDoc : Doc Opts -> IO () -putDoc = putStr . render Opts +runPretty : Options -> Eff Pretty a -> a +runPretty opts act = + let doColor = opts.color && opts.outFile == Stdout + hl = if doColor then highlightSGR else noHighlight + in + runPrettyWith Outer opts.flavor hl 2 act private -die : Doc Opts -> IO a -die err = do putDoc err; exitFailure +putErrLn : HasIO io => String -> io () +putErrLn = ignore . fPutStrLn stderr private -prettySig : Name -> Definition -> Eff Pretty (Doc Opts) -prettySig name def = do - qty <- prettyQty def.qty.qty - name <- prettyFree name - type <- prettyTerm [<] [<] def.type - hangDSingle (hsep [hcat [qty, !dotD, name], !colonD]) type +record State where + constructor MkState + seen : IORef SeenSet + defs : IORef Q.Definitions + ns : IORef Mods + suf : IORef NameSuf +%name Main.State state + +private +newState : HasIO io => io State +newState = pure $ MkState { + seen = !(newIORef empty), + defs = !(newIORef empty), + ns = !(newIORef [<]), + suf = !(newIORef 0) +} + +private +data Error + = ParseError String Parser.Error + | FromParserError FromParser.Error + | EraseError Erase.Error + | WriteError FilePath FileError +%hide FromParser.Error +%hide Erase.Error +%hide Lexer.Error +%hide Parser.Error + +private +loadError : Loc -> FilePath -> FileError -> Error +loadError loc file err = FromParserError $ LoadError loc file err + +private +data CompileTag = OPTS | STATE + +private +Compile : List (Type -> Type) +Compile = + [Except Error, + ReaderL STATE State, ReaderL OPTS Options, + LoadFile, IO] + +private +runCompile : Options -> State -> Eff Compile a -> IO (Either Error a) +runCompile opts state act = + fromIOErr $ runEff act $ with Union.(::) + [handleExcept (\e => ioLeft e), + handleReaderConst state, + handleReaderConst opts, + handleLoadFileIOE loadError ParseError state.seen opts.include, + liftIO] + + +private +data StopTag = STOP + +private +CompileStop : List (Type -> Type) +CompileStop = FailL STOP :: Compile + +private +withEarlyStop : Has (FailL STOP) fs => Eff fs () -> Eff (fs - FailL STOP) () +withEarlyStop = ignore . runFailAt STOP + +private +stopHere : Has (FailL STOP) fs => Eff fs () +stopHere = failAt STOP + + +private +FlexDoc : Type +FlexDoc = {opts : LayoutOpts} -> Doc opts + + +private +outputDoc : FlexDoc -> Eff Compile () +outputDoc doc = + case !(asksAt OPTS outFile) of + None => pure () + Stdout => putDoc !(asksAt OPTS width) doc + File f => do + res <- withFile f WriteTruncate pure $ \h => + fPutDoc !(asksAt OPTS width) h doc + rethrow $ mapFst (WriteError f) res + +private +outputDocStopIf : Phase -> FlexDoc -> Eff CompileStop () +outputDocStopIf p doc = + when (!(asksAt OPTS until) == Just p) $ do + lift (outputDoc doc) + stopHere + +private +liftFromParser : Eff FromParserIO a -> Eff CompileStop a +liftFromParser act = + runEff act $ with Union.(::) + [\g => send g, + handleExcept (\err => throw $ FromParserError err), + handleStateIORef !(asksAt STATE defs), + handleStateIORef !(asksAt STATE ns), + handleStateIORef !(asksAt STATE suf)] + +private +liftErase : Q.Definitions -> Eff Erase a -> Eff CompileStop a +liftErase defs act = + runEff act + [\case Err e => throw $ EraseError e, + \case Ask => pure defs, + handleStateIORef !(asksAt STATE suf)] + + +private +processFile : String -> Eff Compile () +processFile file = withEarlyStop $ do + Just ast <- loadFile noLoc file + | Nothing => pure () + putErrLn "checking \{file}" + outputDocStopIf Parse $ dumpDoc ast + defList <- liftFromParser $ concat <$> traverse fromPTopLevel ast + outputDocStopIf Check $ runPretty !(askAt OPTS) $ + vsep <$> traverse (uncurry Q.prettyDef) defList + let defs = SortedMap.fromList defList + erased <- liftErase defs $ + traverse (\(x, d) => (x,) <$> eraseDef x d) defList + outputDocStopIf Erase $ runPretty !(askAt OPTS) $ + vsep . catMaybes <$> traverse (uncurry U.prettyDef) erased + die "that's all folks" + +private +dieError : HasIO io => Options -> Error -> io a +dieError opts e = do + die opts.width $ runPretty opts $ case e of + ParseError file e => prettyParseError file e + FromParserError e => FromParser.prettyError True e + EraseError e => Erase.prettyError True e + WriteError file e => pure $ + hangSingle 2 (text "couldn't write file \{file}:") (pshow e) export main : IO () main = do - seen <- newIORef SortedSet.empty - defs <- newIORef SortedMap.empty - suf <- newIORef 0 - for_ (drop 1 !getArgs) $ \file => do - putStrLn "checking \{file}" - Right res <- fromParserIO ["."] seen suf defs $ loadProcessFile noLoc file - | Left err => die $ runPrettyColor $ prettyError True err - for_ res $ \(name, def) => putDoc $ runPrettyColor $ prettySig name def + (_, opts, files) <- options + case !(runCompile opts !newState $ traverse_ processFile files) of + Right () => pure () + Left e => dieError opts e + ----------------------------------- {- diff --git a/exe/Options.idr b/exe/Options.idr new file mode 100644 index 0000000..58b545b --- /dev/null +++ b/exe/Options.idr @@ -0,0 +1,158 @@ +module Options + +import Quox.Pretty +import System +import System.Console.GetOpt +import System.File +import System.Term +import Derive.Prelude + +%language ElabReflection + +public export +data OutFile = File String | Stdout | None +%name OutFile f +%runElab derive "OutFile" [Eq, Ord, Show] + +public export +data Phase = Parse | Check | Erase +%name Phase p +%runElab derive "Phase" [Eq, Ord, Show] + +||| a list of all `Phase`s +public export %inline +allPhases : List Phase +allPhases = %runElab do + -- as a script so it stays up to date + cs <- getCons $ fst !(lookupName "Phase") + traverse (check . var) cs + +public export +record Options where + constructor MkOpts + color : Bool + outFile : OutFile + until : Maybe Phase + flavor : Pretty.Flavor + width : Nat + include : List String +%name Options opts +%runElab derive "Options" [Show] + +export +defaultOpts : IO Options +defaultOpts = pure $ MkOpts { + color = True, + outFile = Stdout, + until = Nothing, + flavor = Unicode, + width = cast !getTermCols, + include = ["."] +} + +private +data HelpType = Common | All + +private +data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options) +%name OptAction act + +private +toOutFile : String -> OptAction +toOutFile "" = Ok {outFile := None} +toOutFile "-" = Ok {outFile := Stdout} +toOutFile f = Ok {outFile := File f} + +private +phaseName : Phase -> String +phaseName Parse = "parse" +phaseName Check = "check" +phaseName Erase = "erase" + +private +toPhase : String -> OptAction +toPhase str = case toLower str of + "parse" => Ok {until := Just Parse} + "check" => Ok {until := Just Check} + "erase" => Ok {until := Just Erase} + _ => Err "unknown phase name \{show str}\nphases: \{phaseNames}" +where phaseNames = joinBy ", " $ map phaseName allPhases + +private +toWidth : String -> OptAction +toWidth s = case parsePositive s of + Just n => Ok {width := n} + Nothing => Err "invalid width: \{show s}" + +private +commonOptDescrs' : List (OptDescr OptAction) +commonOptDescrs' = [ + MkOpt ['i'] ["include"] (ReqArg (\i => Ok {include $= (i ::)}) "") + "add a directory to look for source files", + MkOpt ['o'] ["output"] (ReqArg toOutFile "") + "output file (\"-\" for stdout, \"\" for no output)", + MkOpt ['P'] ["phase"] (ReqArg toPhase "") + "phase to stop at (by default go as far as exists)" +] + +private +extraOptDescrs : List (OptDescr OptAction) +extraOptDescrs = [ + MkOpt [] ["unicode"] (NoArg $ Ok {flavor := Unicode}) + "use unicode syntax when printing (default)", + MkOpt [] ["ascii"] (NoArg $ Ok {flavor := Ascii}) + "use ascii syntax when printing", + MkOpt [] ["width"] (ReqArg toWidth "") + "max output width (defaults to terminal width)", + MkOpt [] ["color", "colour"] (NoArg $ Ok {color := True}) + "use colour output (default)", + MkOpt [] ["no-color", "no-colour"] (NoArg $ Ok {color := False}) + "don't use colour output" +] + +private +helpOptDescrs : List (OptDescr OptAction) +helpOptDescrs = [ + MkOpt ['h'] ["help"] (NoArg $ ShowHelp Common) "show common options", + MkOpt [] ["help-all"] (NoArg $ ShowHelp All) "show all options" +] + +commonOptDescrs = commonOptDescrs' ++ helpOptDescrs +allOptDescrs = commonOptDescrs' ++ extraOptDescrs ++ helpOptDescrs + +export +usageHeader : String +usageHeader = joinBy "\n" [ + "quox [options] [file.quox ...]", + "rawr" +] + +export +usage : List (OptDescr _) -> IO a +usage ds = do + ignore $ fPutStr stderr $ usageInfo usageHeader ds + exitSuccess + +private +applyAction : Options -> OptAction -> IO Options +applyAction opts (ShowHelp Common) = usage commonOptDescrs +applyAction opts (ShowHelp All) = usage allOptDescrs +applyAction opts (Err err) = die err +applyAction opts (Ok f) = pure $ f opts + +private +finalise : Options -> Options +finalise = {include $= reverse} + +export +options : IO (String, Options, List String) +options = do + app :: args <- getArgs + | [] => die "couldn't get command line arguments" + let res = getOpt Permute allOptDescrs args + unless (null res.errors) $ + die $ trim $ concat res.errors + unless (null res.unrecognized) $ + die "unrecognised options: \{joinBy ", " res.unrecognized}" + opts <- foldlM applyAction !defaultOpts res.options + pure (app, finalise opts, res.nonOptions) diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index e537962..f34a3d7 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -335,6 +335,8 @@ export covering fromPDef : PDefinition -> Eff FromParserPure NDefinition fromPDef (MkPDef qty pname ptype pterm defLoc) = do name <- fromPBaseNameNS pname + when !(getsAt DEFS $ isJust . lookup name) $ do + throw $ AlreadyExists defLoc name gqty <- globalPQty qty.val qty.loc let sqty = globalToSubj gqty type <- traverse fromPTerm ptype diff --git a/lib/Quox/Parser/FromParser/Error.idr b/lib/Quox/Parser/FromParser/Error.idr index 44cd0db..eee70b5 100644 --- a/lib/Quox/Parser/FromParser/Error.idr +++ b/lib/Quox/Parser/FromParser/Error.idr @@ -32,6 +32,7 @@ data Error = | DimNameInTerm Loc PBaseName | DisplacedBoundVar Loc PName | WrapTypeError TypeError + | AlreadyExists Loc Name | LoadError Loc FilePath FileError | ExpectedFail Loc | WrongFail String Error Loc @@ -112,6 +113,10 @@ parameters {opts : LayoutOpts} (showContext : Bool) prettyError (WrapTypeError err) = Typing.prettyError showContext $ trimContext 2 err + prettyError (AlreadyExists loc name) = pure $ + vsep [!(prettyLoc loc), + sep [!(prettyFree name), "has already been defined"]] + prettyError (LoadError loc file err) = pure $ vsep [!(prettyLoc loc), "couldn't load file" <++> text file, diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index 4aaf792..4753d76 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -115,11 +115,14 @@ export %inline hangD : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts) hangD d1 d2 = pure $ hangSep !(askAt INDENT) d1 d2 +export %inline +hangSingle : {opts : LayoutOpts} -> Nat -> Doc opts -> Doc opts -> Doc opts +hangSingle n d1 d2 = ifMultiline (d1 <++> d2) (vappend d1 (indent n d2)) + export %inline hangDSingle : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts) -hangDSingle d1 d2 = - pure $ ifMultiline (d1 <++> d2) (vappend d1 !(indentD d2)) +hangDSingle d1 d2 = pure $ hangSingle !(askAt INDENT) d1 d2 export @@ -193,6 +196,11 @@ parameters {opts : LayoutOpts} {auto _ : Foldable t} fillSeparateTight d = fillSep . exceptLast (<+> d) . toList +export %inline +pshow : {opts : LayoutOpts} -> Show a => a -> Doc opts +pshow = text . show + + export %inline ifUnicode : (uni, asc : Lazy a) -> Eff Pretty a ifUnicode uni asc = diff --git a/lib/Quox/Syntax/DimEq.idr b/lib/Quox/Syntax/DimEq.idr index 4f9ba19..574414f 100644 --- a/lib/Quox/Syntax/DimEq.idr +++ b/lib/Quox/Syntax/DimEq.idr @@ -237,9 +237,20 @@ setSelf (B i _) (C eqs) with (compareP i i) | (compare i.nat i.nat) _ | IsGT gt | GT = absurd gt +private %inline +dimEqPrec : BContext d -> Maybe (DimEq' d) -> PPrec +dimEqPrec vars eqs = + if length vars <= 1 && maybe True null eqs then Arg else Outer + private -prettyDVars : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts)) -prettyDVars = traverse prettyDBind . toSnocList' +prettyDVars' : {opts : _} -> BContext d -> Eff Pretty (SnocList (Doc opts)) +prettyDVars' = traverse prettyDBind . toSnocList' + +export +prettyDVars : {opts : _} -> BContext d -> Eff Pretty (Doc opts) +prettyDVars vars = + parensIfM (dimEqPrec vars Nothing) $ + fillSeparateTight !commaD $ !(prettyDVars' vars) private prettyCst : {opts : _} -> BContext d -> Dim d -> Dim d -> Eff Pretty (Doc opts) @@ -256,16 +267,16 @@ prettyCsts dnames (eqs :< Just q) = export prettyDimEq' : {opts : _} -> BContext d -> DimEq' d -> Eff Pretty (Doc opts) -prettyDimEq' dnames eqs = do - vars <- prettyDVars dnames - eqs <- prettyCsts dnames eqs - let prec = if length vars <= 1 && null eqs then Arg else Outer - parensIfM prec $ fillSeparateTight !commaD $ toList vars ++ toList eqs +prettyDimEq' vars eqs = do + vars' <- prettyDVars' vars + eqs' <- prettyCsts vars eqs + parensIfM (dimEqPrec vars (Just eqs)) $ + fillSeparateTight !commaD $ vars' ++ eqs' export prettyDimEq : {opts : _} -> BContext d -> DimEq d -> Eff Pretty (Doc opts) prettyDimEq dnames ZeroIsOne = do - vars <- prettyDVars dnames + vars <- prettyDVars' dnames cst <- prettyCst [<] (K Zero noLoc) (K One noLoc) pure $ separateTight !commaD $ vars :< cst prettyDimEq dnames (C eqs) = prettyDimEq' dnames eqs diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 62dbbc3..daea0a7 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -144,6 +144,15 @@ parameters {opts : LayoutOpts} prettyTerm _ (Erased _) = hl Syntax =<< ifUnicode "⌷" "[]" + export + prettyDef : Name -> Definition -> Eff Pretty (Maybe (Doc opts)) + prettyDef _ ErasedDef = [|Nothing|] + prettyDef name (KeptDef rhs) = map Just $ do + name <- prettyFree name + eq <- cstD + rhs <- prettyTerm [<] rhs + hangDSingle (name <++> eq) rhs + public export USubst : Nat -> Nat -> Type From ea74c148b70faf27b73f0ce11b2826b436cd605f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 21 Oct 2023 20:48:28 +0200 Subject: [PATCH 023/133] some of this EffExtra stuff doesn't work --- lib/Quox/EffExtra.idr | 28 ++++------------------------ lib/Quox/Untyped/Erase.idr | 2 +- 2 files changed, 5 insertions(+), 25 deletions(-) diff --git a/lib/Quox/EffExtra.idr b/lib/Quox/EffExtra.idr index 55edfef..6d9d311 100644 --- a/lib/Quox/EffExtra.idr +++ b/lib/Quox/EffExtra.idr @@ -69,17 +69,6 @@ subsetTail : Length xs => (0 x : a) -> Subset xs (x :: xs) subsetTail _ = subsetWith S -export -catchMaybeAt : (0 lbl : tag) -> (Has (ExceptL lbl e) fs, Length fs) => - (e -> Eff fs a) -> Eff fs a -> Eff fs a -catchMaybeAt lbl hnd act = - catchAt lbl hnd $ lift @{subsetTail $ ExceptL lbl e} act - -export %inline -catchMaybe : (Has (Except e) fs, Length fs) => - (e -> Eff fs a) -> Eff fs a -> Eff fs a -catchMaybe = catchMaybeAt () - export rethrowAtWith : (0 lbl : tag) -> Has (ExceptL lbl e') fs => @@ -91,22 +80,13 @@ rethrowWith : Has (Except e') fs => (e -> e') -> Either e a -> Eff fs a rethrowWith = rethrowAtWith () export -wrapErr' : Length fs => (e -> e') -> - Eff (ExceptL lbl e :: fs) a -> - Eff (ExceptL lbl e' :: fs) a -wrapErr' f act = +wrapErr : Length fs => (e -> e') -> + Eff (ExceptL lbl e :: fs) a -> + Eff (ExceptL lbl e' :: fs) a +wrapErr f act = catchAt lbl (throwAt lbl . f) @{S Z} $ lift @{subsetTail _} act -export -wrapErrAt : (0 lbl : tag) -> (Has (ExceptL lbl e) fs, Length fs) => - (e -> e) -> Eff fs a -> Eff fs a -wrapErrAt lbl wrap = catchMaybeAt lbl (\ex => throwAt lbl $ wrap ex) - -export %inline -wrapErr : (Has (Except e) fs, Length fs) => (e -> e) -> Eff fs a -> Eff fs a -wrapErr = wrapErrAt () - export handleExcept : Functor m => (forall c. e -> m c) -> ExceptL lbl e a -> m a diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index afa5bc3..d14766d 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -87,7 +87,7 @@ Erase = [Except Error, DefsReader, NameGen] export liftWhnf : Eff Whnf a -> Eff Erase a -liftWhnf act = lift $ wrapErr' WrapTypeError act +liftWhnf act = lift $ wrapErr WrapTypeError act export covering computeElimType : ErasureContext d n -> SQty -> Elim d n -> Eff Erase (Term d n) From 8e0d66cab822188ba4175423143c02db90170e18 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 21 Oct 2023 20:49:29 +0200 Subject: [PATCH 024/133] more erasure --- lib/Quox/Untyped/Erase.idr | 21 +++-- lib/Quox/Untyped/Syntax.idr | 153 +++++++++++++++++++----------------- 2 files changed, 95 insertions(+), 79 deletions(-) diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index d14766d..8118920 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -50,6 +50,7 @@ data Error = CompileTimeOnly (ErasureContext d n) (Q.Term d n) | WrapTypeError TypeError | Postulate Loc Name +| WhileErasing Name Q.Definition Error %name Error err private %inline @@ -58,9 +59,10 @@ notInScope = WrapTypeError .: NotInScope export Located Error where - (CompileTimeOnly _ s).loc = s.loc - (WrapTypeError err).loc = err.loc - (Postulate loc _).loc = loc + (CompileTimeOnly _ s).loc = s.loc + (WrapTypeError err).loc = err.loc + (Postulate loc _).loc = loc + (WhileErasing _ def e).loc = e.loc `or` def.loc parameters {opts : LayoutOpts} (showContext : Bool) @@ -74,6 +76,9 @@ parameters {opts : LayoutOpts} (showContext : Bool) prettyErrorNoLoc showContext err prettyErrorNoLoc (Postulate _ x) = pure $ sep [!(prettyFree x), "is a postulate with no definition"] + prettyErrorNoLoc (WhileErasing name def err) = pure $ + vsep [hsep ["while erasing the definition", !(prettyFree name)], + !(prettyErrorNoLoc err)] export prettyError : Error -> Eff Pretty (Doc opts) @@ -147,7 +152,8 @@ eraseTerm ctx _ s@(Pi {}) = -- to preserve expected evaluation order eraseTerm ctx ty (Lam body loc) = do (qty, arg, res) <- wrapExpect `(expectPi) ctx loc ty - let x = body.name + let x = case isErased qty of Kept => body.name + Erased => BN Unused body.name.loc body <- eraseTerm (extendTy qty x arg ctx) res.term body.term pure $ U.Lam x body loc @@ -346,7 +352,7 @@ eraseElim ctx (CaseNat qty qtyIH nat ret zero succ loc) = do eraseElim ctx (CaseBox qty box ret body loc) = do tbox <- computeElimType ctx SOne box -- [fixme] is there any way to avoid this? (pi, tinner) <- wrapExpect `(expectBOX) ctx loc tbox - let ctx' = extendTy Zero body.name tinner ctx + let ctx' = extendTy (pi * qty) body.name tinner ctx bty = sub1 (ret // shift 1) $ Ann (Box (BVT 0 loc) loc) (weakT 1 tbox) loc case isErased pi of @@ -397,9 +403,10 @@ eraseElim ctx (DCloE (Sub term th)) = export covering eraseDef : Name -> Q.Definition -> Eff Erase U.Definition -eraseDef name (MkDef qty type body loc) = do +eraseDef name def@(MkDef qty type body loc) = + wrapErr (WhileErasing name def) $ case isErased qty.qty of Erased => pure ErasedDef Kept => case body of - Concrete body => KeptDef <$> eraseTerm empty type body Postulate => throw $ Postulate loc name + Concrete body => KeptDef <$> eraseTerm empty type body diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index daea0a7..e4f67e4 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -73,85 +73,94 @@ public export Definitions = SortedMap Name Definition -parameters {opts : LayoutOpts} - export - prettyTerm : BContext n -> Term n -> Eff Pretty (Doc opts) +export +prettyTerm : {opts : LayoutOpts} -> BContext n -> + Term n -> Eff Pretty (Doc opts) - export - prettyArg : BContext n -> Term n -> Eff Pretty (Doc opts) - prettyArg xs arg = withPrec Arg $ prettyTerm xs arg +export +prettyArg : {opts : LayoutOpts} -> BContext n -> Term n -> Eff Pretty (Doc opts) +prettyArg xs arg = withPrec Arg $ prettyTerm xs arg - export - prettyApp' : Context' BindName n -> Doc opts -> Term n -> Eff Pretty (Doc opts) - prettyApp' xs fun arg = - parensIfM App =<< do - arg <- prettyArg xs arg - pure $ sep [fun, arg] +export +prettyApp' : {opts : LayoutOpts} -> BContext n -> Doc opts -> + Term n -> Eff Pretty (Doc opts) +prettyApp' xs fun arg = + parensIfM App =<< do + arg <- prettyArg xs arg + pure $ sep [fun, arg] - export - prettyApp : Context' BindName n -> Term n -> Term n -> Eff Pretty (Doc opts) - prettyApp xs fun arg = prettyApp' xs !(prettyArg xs fun) arg +export +prettyApp : {opts : LayoutOpts} -> BContext n -> + Term n -> Term n -> Eff Pretty (Doc opts) +prettyApp xs fun arg = + prettyApp' xs !(withPrec App $ prettyTerm xs fun) arg - public export - PrettyCaseArm : Nat -> Type - PrettyCaseArm n = Exists $ \s => (Vect s BindName, Term (s + n)) +public export +record PrettyCaseArm a n where + constructor MkPrettyCaseArm + lhs : a + {len : Nat} + vars : Vect len BindName + rhs : Term (len + n) - export %inline - caseArm : Vect s BindName -> Term (s + n) -> PrettyCaseArm n - caseArm xs t = Evidence _ (xs, t) +export +prettyCase : {opts : LayoutOpts} -> BContext n -> + (a -> Eff Pretty (Doc opts)) -> + Term n -> List (PrettyCaseArm a n) -> + Eff Pretty (Doc opts) +prettyCase xs f head arms = + parensIfM Outer =<< do + header <- hsep <$> sequence [caseD, prettyTerm xs head, ofD] + cases <- for arms $ \(MkPrettyCaseArm lhs ys rhs) => do + lhs <- hsep <$> sequence [f lhs, darrowD] + rhs <- withPrec Outer $ prettyTerm (xs <>< ys) rhs + hangDSingle lhs rhs + lb <- hl Delim "{"; sc <- semiD; rb <- hl Delim "}"; d <- askAt INDENT + pure $ ifMultiline + (hsep [header, lb, separateTight sc cases, rb]) + (vsep [hsep [header, lb], indent d $ vsep (map (<+> sc) cases), rb]) - export - prettyCase : Context' BindName n -> - (a -> Eff Pretty (Doc opts)) -> - Term n -> List (a, PrettyCaseArm n) -> - Eff Pretty (Doc opts) - prettyCase xs f head arms = - parensIfM Outer =<< Prelude.do - header <- hsep <$> sequence [caseD, prettyTerm xs head, ofD] - cases <- for arms $ \(lhs, (Evidence s (ys, rhs))) => do - lhs <- hsep <$> sequence [f lhs, darrowD] - rhs <- withPrec Outer $ prettyTerm (xs <>< ys) rhs - hangDSingle lhs rhs - body <- braces $ separateLoose !semiD cases - pure $ sep [header, body] +prettyTerm _ (F x _) = prettyFree x +prettyTerm xs (B i _) = prettyTBind $ xs !!! i +prettyTerm xs (Lam x body _) = + parensIfM Outer =<< do + header <- hsep <$> sequence [lamD, prettyTBind x, darrowD] + body <- withPrec Outer $ prettyTerm (xs :< x) body + hangDSingle header body +prettyTerm xs (App fun arg _) = prettyApp xs fun arg +prettyTerm xs (Pair fst snd _) = + parens =<< separateTight !commaD <$> + sequence {t = List} [prettyTerm xs fst, prettyTerm xs snd] +prettyTerm xs (Fst pair _) = prettyApp' xs !fstD pair +prettyTerm xs (Snd pair _) = prettyApp' xs !sndD pair +prettyTerm xs (Tag tag _) = prettyTag tag +prettyTerm xs (CaseEnum tag cases _) = + assert_total + prettyCase xs prettyTag tag $ + map (\(t, rhs) => MkPrettyCaseArm t [] rhs) cases +prettyTerm xs (Absurd _) = hl Syntax "absurd" +prettyTerm xs (Zero _) = zeroD +prettyTerm xs (Succ nat _) = prettyApp' xs !succD nat +prettyTerm xs (CaseNat nat zer x ih suc _) = + assert_total + prettyCase xs pure nat + [MkPrettyCaseArm !zeroD [] zer, + MkPrettyCaseArm !sucPat [x, ih] suc] +where + sucPat = pure $ + hsep [!succD, !(prettyTBind x) <+> !commaD, !(prettyTBind ih)] +prettyTerm _ (Erased _) = + hl Syntax =<< ifUnicode "⌷" "[]" - prettyTerm _ (F x _) = prettyFree x - prettyTerm xs (B i _) = prettyTBind $ xs !!! i - prettyTerm xs (Lam x body _) = - parensIfM Outer =<< do - header <- hsep <$> sequence [lamD, prettyTBind x, darrowD] - body <- withPrec Outer $ prettyTerm (xs :< x) body - hangDSingle header body - prettyTerm xs (App fun arg _) = prettyApp xs fun arg - prettyTerm xs (Pair fst snd _) = - parens =<< separateTight !commaD <$> - sequence {t = List} [prettyTerm xs fst, prettyTerm xs snd] - prettyTerm xs (Fst pair _) = prettyApp' xs !fstD pair - prettyTerm xs (Snd pair _) = prettyApp' xs !sndD pair - prettyTerm xs (Tag tag _) = prettyTag tag - prettyTerm xs (CaseEnum tag cases _) = assert_total - prettyCase xs prettyTag tag $ map (mapSnd $ caseArm []) cases - prettyTerm xs (Absurd _) = hl Syntax "absurd" - prettyTerm xs (Zero _) = zeroD - prettyTerm xs (Succ nat _) = prettyApp' xs !succD nat - prettyTerm xs (CaseNat nat zer x ih suc _) = assert_total - prettyCase xs pure nat - [(!zeroD, caseArm [] zer), - (!sucPat, caseArm [x, ih] suc)] - where - sucPat = separateTight {t = List} !commaD <$> - sequence [[|succD <++> prettyTBind x|], prettyTBind ih] - prettyTerm _ (Erased _) = - hl Syntax =<< ifUnicode "⌷" "[]" - - export - prettyDef : Name -> Definition -> Eff Pretty (Maybe (Doc opts)) - prettyDef _ ErasedDef = [|Nothing|] - prettyDef name (KeptDef rhs) = map Just $ do - name <- prettyFree name - eq <- cstD - rhs <- prettyTerm [<] rhs - hangDSingle (name <++> eq) rhs +export +prettyDef : {opts : LayoutOpts} -> Name -> + Definition -> Eff Pretty (Maybe (Doc opts)) +prettyDef _ ErasedDef = [|Nothing|] +prettyDef name (KeptDef rhs) = map Just $ do + name <- prettyFree name + eq <- cstD + rhs <- prettyTerm [<] rhs + hangDSingle (name <++> eq) rhs public export From f4a45b6c52c3632c3b5466818bbbafc63d3209c5 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 17:45:02 +0100 Subject: [PATCH 025/133] keep the Except effect at the start of the list --- exe/Main.idr | 6 +++--- lib/Quox/Parser/FromParser.idr | 8 ++++---- 2 files changed, 7 insertions(+), 7 deletions(-) diff --git a/exe/Main.idr b/exe/Main.idr index dbb7897..be03398 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -146,11 +146,11 @@ private liftFromParser : Eff FromParserIO a -> Eff CompileStop a liftFromParser act = runEff act $ with Union.(::) - [\g => send g, - handleExcept (\err => throw $ FromParserError err), + [handleExcept (\err => throw $ FromParserError err), handleStateIORef !(asksAt STATE defs), handleStateIORef !(asksAt STATE ns), - handleStateIORef !(asksAt STATE suf)] + handleStateIORef !(asksAt STATE suf), + \g => send g] private liftErase : Q.Definitions -> Eff Erase a -> Eff CompileStop a diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index f34a3d7..84eaed9 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -41,7 +41,7 @@ FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen] public export FromParserIO : List (Type -> Type) -FromParserIO = LoadFile :: FromParserPure +FromParserIO = FromParserPure ++ [LoadFile] export @@ -66,11 +66,11 @@ fromParserIO : (MonadRec io, HasIO io) => Eff FromParserIO a -> io (Either Error a) fromParserIO inc seen suf defs act = liftIO $ fromIOErr $ runEff act $ with Union.(::) - [handleLoadFileIOE LoadError WrapParseError seen inc, - handleExcept (\e => ioLeft e), + [handleExcept (\e => ioLeft e), handleStateIORef defs, handleStateIORef !(newIORef [<]), - handleStateIORef suf] + handleStateIORef suf, + handleLoadFileIOE LoadError WrapParseError seen inc] parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a) From b6fd1e921e96d36b3ca484b273a19b701a2673c7 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 17:47:01 +0100 Subject: [PATCH 026/133] pretty printing improvements --- lib/Quox/Definition.idr | 2 +- lib/Quox/Pretty.idr | 8 ++++++++ lib/Quox/Syntax/Term/Pretty.idr | 23 ++++++++++++++--------- 3 files changed, 23 insertions(+), 10 deletions(-) diff --git a/lib/Quox/Definition.idr b/lib/Quox/Definition.idr index 8bd2fa9..4842c29 100644 --- a/lib/Quox/Definition.idr +++ b/lib/Quox/Definition.idr @@ -114,4 +114,4 @@ prettyDef name (MkDef qty type _ _) = withPrec Outer $ do name <- prettyFree name colon <- colonD type <- prettyTerm [<] [<] type - pure $ sep [hsep [hcat [qty, dot, name], colon], type] + hangDSingle (hsep [hcat [qty, dot, name], colon]) type diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index 4753d76..73357ee 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -191,6 +191,14 @@ parameters {opts : LayoutOpts} {auto _ : Foldable t} separateTight : Doc opts -> t (Doc opts) -> Doc opts separateTight d = sep . exceptLast (<+> d) . toList + export + hseparateTight : Doc opts -> t (Doc opts) -> Doc opts + hseparateTight d = hsep . exceptLast (<+> d) . toList + + export + vseparateTight : Doc opts -> t (Doc opts) -> Doc opts + vseparateTight d = vsep . exceptLast (<+> d) . toList + export fillSeparateTight : Doc opts -> t (Doc opts) -> Doc opts fillSeparateTight d = fillSep . exceptLast (<+> d) . toList diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index 691cfd6..a14974c 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -251,12 +251,11 @@ parameters {opts : LayoutOpts} (dnames : BContext d) (tnames : BContext n) body <- withPrec Outer $ assert_total prettyTerm (dnames . dbinds) (tnames . tbinds) body header <- (pat <++>) <$> darrowD - pure $ hsep [header, body] <|> vsep [header, !(indentD body)] + pure $ ifMultiline (header <++> body) (vsep [header, !(indentD body)]) private - prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (Doc opts) - prettyCaseBody xs = - braces . separateTight !semiD =<< traverse prettyCaseArm xs + prettyCaseBody : List (CaseArm opts d n) -> Eff Pretty (List (Doc opts)) + prettyCaseBody xs = traverse prettyCaseArm xs private prettyCompPat : {opts : _} -> DimConst -> BindName -> Eff Pretty (Doc opts) @@ -299,7 +298,7 @@ prettyCaseRet dnames tnames body = withPrec Outer $ case body of S [< x] (Y tm) => do header <- [|prettyTBind x <++> darrowD|] body <- assert_total prettyTerm dnames (tnames :< x) tm - pure $ hsep [header, body] <|> vsep [header, !(indentD body)] + hangDSingle header body private prettyCase_ : {opts : _} -> @@ -307,10 +306,16 @@ prettyCase_ : {opts : _} -> Doc opts -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) -> Eff Pretty (Doc opts) prettyCase_ dnames tnames intro head ret body = do - head <- assert_total prettyElim dnames tnames head - ret <- prettyCaseRet dnames tnames ret - body <- prettyCaseBody dnames tnames body - parensIfM Outer $ sep [intro <++> head, !returnD <++> ret, !ofD <++> body] + head <- assert_total prettyElim dnames tnames head + ret <- prettyCaseRet dnames tnames ret + bodys <- prettyCaseBody dnames tnames body + return <- returnD; of_ <- ofD + lb <- hl Delim "{"; rb <- hl Delim "}"; semi <- semiD + ind <- askAt INDENT + parensIfM Outer $ ifMultiline + (hsep [intro, head, return, ret, of_, lb, hseparateTight semi bodys, rb]) + (vsep [intro <++> head, return <++> ret, of_ <++> lb, + indent ind $ vseparateTight semi bodys, rb]) private prettyCase : {opts : _} -> From 6ab9637ab5383ebcc746d39f10bf7ebffe6852f2 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 17:47:55 +0100 Subject: [PATCH 027/133] don't keep erased applications actually --- lib/Quox/Untyped/Erase.idr | 22 ++++++++++++---------- 1 file changed, 12 insertions(+), 10 deletions(-) diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 8118920..d5e4300 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -144,18 +144,20 @@ eraseTerm ctx _ s@(TYPE {}) = eraseTerm ctx _ s@(Pi {}) = throw $ CompileTimeOnly ctx s --- x : A | π.x ⊢ s ⤋ s' ⇐ B +-- x : A | 0.x ⊢ s ⤋ s' ⇐ B +-- ------------------------------------- +-- (λ x ⇒ s) ⤋ s'[⌷/x] ⇐ 0.(x : A) → B +-- +-- x : A | π.x ⊢ s ⤋ s' ⇐ B π ≠ 0 -- ---------------------------------------- -- (λ x ⇒ s) ⤋ (λ x ⇒ s') ⇐ π.(x : A) → B --- --- becomes a lambda even when π = 0, --- to preserve expected evaluation order eraseTerm ctx ty (Lam body loc) = do + let x = body.name (qty, arg, res) <- wrapExpect `(expectPi) ctx loc ty - let x = case isErased qty of Kept => body.name - Erased => BN Unused body.name.loc - body <- eraseTerm (extendTy qty x arg ctx) res.term body.term - pure $ U.Lam x body loc + body <- eraseTerm (extendTy qty x arg ctx) res.term body.term + pure $ case isErased qty of + Kept => U.Lam x body loc + Erased => sub1 (Erased loc) body eraseTerm ctx _ s@(Sig {}) = throw $ CompileTimeOnly ctx s @@ -251,13 +253,13 @@ eraseElim ctx e@(B i loc) = do -- -- f ⤋ f' ⇒ 0.(x : A) → B -- ------------------------- --- f s ⤋ f' ⌷ ⇒ B[s/x] +-- f s ⤋ f' ⇒ B[s/x] eraseElim ctx (App fun arg loc) = do efun <- eraseElim ctx fun (qty, targ, tres) <- wrapExpect `(expectPi) ctx loc efun.type let ty = sub1 tres (Ann arg targ arg.loc) case isErased qty of - Erased => pure $ EraRes ty $ App efun.term (Erased arg.loc) loc + Erased => pure $ EraRes ty efun.term Kept => do arg <- eraseTerm ctx targ arg pure $ EraRes ty $ App efun.term arg loc From 314e7f036d508aafbab305f5de3958857d6895ef Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 17:48:12 +0100 Subject: [PATCH 028/133] make nat elimination with erased IH non-recursive at runtime --- lib/Quox/Untyped/Erase.idr | 19 +++++++--- lib/Quox/Untyped/Syntax.idr | 76 ++++++++++++++++++++++++------------- 2 files changed, 64 insertions(+), 31 deletions(-) diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index d5e4300..a79e297 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -324,24 +324,33 @@ eraseElim ctx e@(CaseEnum qty tag ret arms loc) = pure (t, rhs') pure $ EraRes ty $ CaseEnum etag.term arms loc --- n ⤋ n' ⇒ ℕ z ⤋ z' ⇐ R[zero∷ℕ/z] +-- n ⤋ n' ⇒ ℕ z ⤋ z' ⇐ R[zero∷ℕ/z] ς ≠ 0 -- m : ℕ, ih : R[m/z] | ρ.m, ς.ih ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z] -- ----------------------------------------------------------- -- caseρ n return z ⇒ R of {0 ⇒ z; succ m, ς.ih ⇒ s} -- ⤋ --- case n' of {0 ⇒ z'; succ m, ih ⇒ s'} --- ⇒ R[n/z] +-- case n' of {0 ⇒ z'; succ m, ih ⇒ s'} ⇒ R[n/z] +-- +-- n ⤋ n' ⇒ ℕ z ⤋ z' ⇐ R[zero∷ℕ/z] +-- m : ℕ, ih : R[m/z] | ρ.m, 0.ih ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z] +-- ----------------------------------------------------------- +-- caseρ n return z ⇒ R of {0 ⇒ z; succ m, 0.ih ⇒ s} +-- ⤋ +-- case n' of {0 ⇒ z'; succ m ⇒ s'[⌷/ih]} ⇒ R[n/z] eraseElim ctx (CaseNat qty qtyIH nat ret zero succ loc) = do let ty = sub1 ret nat enat <- eraseElim ctx nat zero <- eraseTerm ctx (sub1 ret (Ann (Zero loc) (Nat loc) loc)) zero let [< p, ih] = succ.names - succ <- eraseTerm + succ' <- eraseTerm (extendTyN [< (qty, p, Nat loc), (qtyIH, ih, sub1 (ret // shift 1) (BV 0 loc))] ctx) (sub1 (ret // shift 2) (Ann (Succ (BVT 1 loc) loc) (Nat loc) loc)) succ.term - pure $ EraRes ty $ CaseNat enat.term zero p ih succ loc + let succ = case isErased qtyIH of + Kept => NSRec p ih succ' + Erased => NSNonrec p (sub1 (Erased loc) succ') + pure $ EraRes ty $ CaseNat enat.term zero succ loc -- b ⤋ b' ⇒ [π.A] π ≠ 0 -- x : A | πρ.x ⊢ s ⤋ s' ⇐ R[[x]∷[π.A]/z] diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index e4f67e4..36bbedd 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -18,7 +18,12 @@ import Derive.Prelude public export -data Term : Nat -> Type where +data Term : Nat -> Type + +public export +data CaseNatSuc : Nat -> Type + +data Term where F : (x : Name) -> Loc -> Term n B : (i : Var n) -> Loc -> Term n @@ -38,31 +43,38 @@ data Term : Nat -> Type where Succ : (nat : Term n) -> Loc -> Term n CaseNat : (nat : Term n) -> (zer : Term n) -> - (x, ih : BindName) -> (suc : Term (2 + n)) -> + (suc : CaseNatSuc n) -> Loc -> Term n Erased : Loc -> Term n %name Term s, t, u -%runElab deriveIndexed "Term" [Eq, Ord, Show] + +data CaseNatSuc where + NSRec : (x, ih : BindName) -> Term (2 + n) -> CaseNatSuc n + NSNonrec : (x : BindName) -> Term (S n) -> CaseNatSuc n +%name CaseNatSuc suc + +%runElab deriveParam $ + map (\ty => PI ty allIndices [Eq, Ord, Show]) ["Term", "CaseNatSuc"] export Located (Term n) where - (F x loc).loc = loc - (B i loc).loc = loc - (Lam x body loc).loc = loc - (App fun arg loc).loc = loc - (Pair fst snd loc).loc = loc - (Fst pair loc).loc = loc - (Snd pair loc).loc = loc - (Tag tag loc).loc = loc - (CaseEnum tag cases loc).loc = loc - (Absurd loc).loc = loc - (Zero loc).loc = loc - (Succ nat loc).loc = loc - (CaseNat nat zer x ih suc loc).loc = loc - (Erased loc).loc = loc + (F x loc).loc = loc + (B i loc).loc = loc + (Lam x body loc).loc = loc + (App fun arg loc).loc = loc + (Pair fst snd loc).loc = loc + (Fst pair loc).loc = loc + (Snd pair loc).loc = loc + (Tag tag loc).loc = loc + (CaseEnum tag cases loc).loc = loc + (Absurd loc).loc = loc + (Zero loc).loc = loc + (Succ nat loc).loc = loc + (CaseNat nat zer suc loc).loc = loc + (Erased loc).loc = loc public export @@ -120,6 +132,18 @@ prettyCase xs f head arms = (hsep [header, lb, separateTight sc cases, rb]) (vsep [hsep [header, lb], indent d $ vsep (map (<+> sc) cases), rb]) +private +sucPat : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts) +sucPat x = pure $ !succD <++> !(prettyTBind x) + +private +sucCaseArm : {opts : LayoutOpts} -> + CaseNatSuc n -> Eff Pretty (PrettyCaseArm (Doc opts) n) +sucCaseArm (NSRec x ih s) = pure $ + MkPrettyCaseArm (!(sucPat x) <+> !commaD <++> !(prettyTBind ih)) [x, ih] s +sucCaseArm (NSNonrec x s) = pure $ + MkPrettyCaseArm !(sucPat x) [x] s + prettyTerm _ (F x _) = prettyFree x prettyTerm xs (B i _) = prettyTBind $ xs !!! i prettyTerm xs (Lam x body _) = @@ -141,14 +165,9 @@ prettyTerm xs (CaseEnum tag cases _) = prettyTerm xs (Absurd _) = hl Syntax "absurd" prettyTerm xs (Zero _) = zeroD prettyTerm xs (Succ nat _) = prettyApp' xs !succD nat -prettyTerm xs (CaseNat nat zer x ih suc _) = +prettyTerm xs (CaseNat nat zer suc _) = assert_total - prettyCase xs pure nat - [MkPrettyCaseArm !zeroD [] zer, - MkPrettyCaseArm !sucPat [x, ih] suc] -where - sucPat = pure $ - hsep [!succD, !(prettyTBind x) <+> !commaD, !(prettyTBind ih)] + prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)] prettyTerm _ (Erased _) = hl Syntax =<< ifUnicode "⌷" "[]" @@ -198,11 +217,16 @@ CanSubstSelf Term where Zero loc Succ nat loc => Succ (nat // th) loc - CaseNat nat zer x ih suc loc => + CaseNat nat zer suc loc => CaseNat (nat // th) (zer // th) - x ih (assert_total $ suc // pushN 2 th) loc + (assert_total substSuc suc th) loc Erased loc => Erased loc + where + substSuc : forall from, to. + CaseNatSuc from -> USubst from to -> CaseNatSuc to + substSuc (NSRec x ih t) th = NSRec x ih $ t // pushN 2 th + substSuc (NSNonrec x t) th = NSNonrec x $ t // push th public export subN : SnocVect s (Term n) -> Term (s + n) -> Term n From 1f14e4ab9e7226892745c8afbb7cc46de819b227 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Tue, 24 Oct 2023 18:25:56 +0200 Subject: [PATCH 029/133] automate more option stuff if the elaborator writes it then it will be kept up to date automatically --- exe/Options.idr | 19 +++++++------------ 1 file changed, 7 insertions(+), 12 deletions(-) diff --git a/exe/Options.idr b/exe/Options.idr index 58b545b..7698730 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -7,6 +7,7 @@ import System.File import System.Term import Derive.Prelude +%default total %language ElabReflection public export @@ -63,20 +64,14 @@ toOutFile "" = Ok {outFile := None} toOutFile "-" = Ok {outFile := Stdout} toOutFile f = Ok {outFile := File f} -private -phaseName : Phase -> String -phaseName Parse = "parse" -phaseName Check = "check" -phaseName Erase = "erase" - private toPhase : String -> OptAction -toPhase str = case toLower str of - "parse" => Ok {until := Just Parse} - "check" => Ok {until := Just Check} - "erase" => Ok {until := Just Erase} - _ => Err "unknown phase name \{show str}\nphases: \{phaseNames}" -where phaseNames = joinBy ", " $ map phaseName allPhases +toPhase str = + let lstr = toLower str in + case find (\p => toLower (show p) == lstr) allPhases of + Just p => Ok {until := Just p} + Nothing => Err "unknown phase name \{show str}\nphases: \{phaseNames}" +where phaseNames = joinBy ", " $ map (toLower . show) allPhases private toWidth : String -> OptAction From cd08a0fd984bb8e1d49edd65ff64c5cb6617b294 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Tue, 24 Oct 2023 23:50:28 +0200 Subject: [PATCH 030/133] more erasure --- lib/Quox/Untyped/Erase.idr | 185 +++++++++++++++++++++++++----------- lib/Quox/Untyped/Syntax.idr | 93 +++++++++++++----- 2 files changed, 198 insertions(+), 80 deletions(-) diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index a79e297..ce775f7 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -1,14 +1,15 @@ module Quox.Untyped.Erase import Quox.Definition as Q +import Quox.Pretty import Quox.Syntax.Term.Base as Q import Quox.Syntax.Term.Subst -import Quox.Untyped.Syntax as U import Quox.Typing +import Quox.Untyped.Syntax as U import Quox.Whnf -import Quox.Pretty import Quox.EffExtra +import Data.List1 import Data.Singleton import Data.SnocVect import Language.Reflection @@ -28,12 +29,6 @@ isErased Zero = Erased isErased One = Kept isErased Any = Kept -public export -ifErased : Qty -> Lazy a -> Lazy a -> a -ifErased pi x y = case isErased pi of - Erased => x - Kept => y - public export ErasureContext : Nat -> Nat -> Type @@ -98,23 +93,18 @@ export covering computeElimType : ErasureContext d n -> SQty -> Elim d n -> Eff Erase (Term d n) computeElimType ctx sg e = do defs <- askAt DEFS + let ctx = toWhnfContext ctx liftWhnf $ do - let ctx = toWhnfContext ctx - Element e enf <- whnf defs ctx sg e + Element e _ <- whnf defs ctx sg e computeElimType defs ctx sg e private %macro wrapExpect : TTImp -> Elab (TyContext d n -> Loc -> Term d n -> Eff Erase a) -wrapExpect f {a} = do - f' <- check `(\x => ~(f) x) - pure $ \ctx, loc, s => wrapExpect' f' ctx loc s -where - wrapExpect' : (Q.Definitions -> TyContext d n -> SQty -> Loc -> Term d n -> - Eff [Except TypeError, NameGen] a) -> - TyContext d n -> Loc -> Term d n -> Eff Erase a - wrapExpect' f ctx loc s = liftWhnf $ f !(askAt DEFS) ctx SZero loc s +wrapExpect f_ = do + f <- check `(\x => ~(f_) x) + pure $ \ctx, loc, s => liftWhnf $ f !(askAt DEFS) ctx SZero loc s public export @@ -263,22 +253,42 @@ eraseElim ctx (App fun arg loc) = do Kept => do arg <- eraseTerm ctx targ arg pure $ EraRes ty $ App efun.term arg loc --- e ⤋ e' ⇒ (x : A) × B +-- e ⇒ (x : A) × B -- x : A, y : B | ρ.x, ρ.y ⊢ s ⤋ s' ⇐ R[((x,y) ∷ (x : A) × B)/z] --- x̃ ≔ if ρ = 0 then ⌷ else fst e' ỹ ≔ if ρ = 0 then ⌷ else snd e' -- ------------------------------------------------------------------- --- (caseρ e return z ⇒ R of {(x, y) ⇒ s}) ⤋ s'[x̃/x, ỹ/y] ⇒ R[e/z] +-- (case0 e return z ⇒ R of {(x, y) ⇒ s}) ⤋ s'[⌷/x, ⌷/y] ⇒ R[e/z] +-- +-- e ⤋ e' ⇒ (x : A) × B ρ ≠ 0 +-- x : A, y : B | ρ.x, ρ.y ⊢ s ⤋ s' ⇐ R[((x,y) ∷ (x : A) × B)/z] +-- ---------------------------------------------------------------------------- +-- (caseρ e return z ⇒ R of {(x, y) ⇒ s}) ⤋ +-- ⤋ +-- let xy = e' in let x = fst xy in let y = snd xy in s' ⇒ R[e/z] eraseElim ctx (CasePair qty pair ret body loc) = do - epair <- eraseElim ctx pair - let ty = sub1 (ret // shift 2) $ - Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 epair.type) loc - (tfst, tsnd) <- wrapExpect `(expectSig) ctx loc epair.type let [< x, y] = body.names - let ctx' = extendTyN [< (qty, x, tfst), (qty, y, tsnd.term)] ctx - body' <- eraseTerm ctx' ty body.term - let x' = ifErased qty (Erased loc) (Fst epair.term loc) - y' = ifErased qty (Erased loc) (Snd epair.term loc) - pure $ EraRes (sub1 ret pair) $ body' // fromSnocVect [< x', y'] + case isErased qty of + Kept => do + EraRes ety eterm <- eraseElim ctx pair + let ty = sub1 (ret // shift 2) $ + Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 ety) loc + (tfst, tsnd) <- wrapExpect `(expectSig) ctx loc ety + let ctx' = extendTyN [< (qty, x, tfst), (qty, y, tsnd.term)] ctx + body' <- eraseTerm ctx' ty body.term + p <- mnb "p" loc + pure $ EraRes (sub1 ret pair) $ + Let p eterm + (Let x (Fst (B VZ loc) loc) + (Let y (Snd (B (VS VZ) loc) loc) + (body' // (B VZ loc ::: B (VS VZ) loc ::: shift 3)) + loc) loc) loc + Erased => do + ety <- computeElimType ctx SOne pair + let ty = sub1 (ret // shift 2) $ + Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 ety) loc + (tfst, tsnd) <- wrapExpect `(expectSig) ctx loc ety + let ctx' = extendTyN0 [< (x, tfst), (y, tsnd.term)] ctx + body' <- eraseTerm ctx' ty body.term + pure $ EraRes (sub1 ret pair) $ subN [< Erased loc, Erased loc] body' -- e ⤋ e' ⇒ (x : A) × B -- ---------------------- @@ -296,33 +306,34 @@ eraseElim ctx (Snd pair loc) = do b <- snd <$> wrapExpect `(expectSig) ctx loc epair.type pure $ EraRes (sub1 b (Fst pair loc)) $ Snd epair.term loc --- case0 e return z ⇒ R of {} ⤋ absurd ⇒ R[e/z] +-- caseρ e return z ⇒ R of {} ⤋ absurd ⇒ R[e/z] -- -- s ⤋ s' ⇐ R[𝐚∷{𝐚}/z] -- ----------------------------------------------- -- case0 e return z ⇒ R of {𝐚 ⇒ s} ⤋ s' ⇒ R[e/z] -- --- e ⤋ e' ⇒ A ρ ≠ 0 sᵢ ⤋ s'ᵢ ⇐ R[𝐚ᵢ/z] +-- e ⤋ e' ⇒ A sᵢ ⤋ s'ᵢ ⇐ R[𝐚ᵢ/z] ρ ≠ 0 i ≠ 0 -- ------------------------------------------------------------------- -- caseρ e return z ⇒ R of {𝐚ᵢ ⇒ sᵢ} ⤋ case e of {𝐚ᵢ ⇒ s'ᵢ} ⇒ R[e/z] -eraseElim ctx e@(CaseEnum qty tag ret arms loc) = +eraseElim ctx e@(CaseEnum qty tag ret arms loc) = do + let ty = sub1 ret tag case isErased qty of Erased => case SortedMap.toList arms of - [] => pure $ EraRes (sub1 ret tag) $ Absurd loc - [(t, arm)] => do - let ty = sub1 ret tag - ty' = sub1 ret (Ann (Tag t loc) (enum [t] loc) loc) - arm' <- eraseTerm ctx ty' arm - pure $ EraRes ty arm' - _ => throw $ CompileTimeOnly ctx $ E e - Kept => do - let ty = sub1 ret tag - etag <- eraseElim ctx tag - arms <- for (SortedMap.toList arms) $ \(t, rhs) => do - let ty' = sub1 ret (Ann (Tag t loc) etag.type loc) + [] => pure $ EraRes ty $ Absurd loc + [(t, rhs)] => do + let ty' = sub1 ret (Ann (Tag t loc) (enum [t] loc) loc) rhs' <- eraseTerm ctx ty' rhs - pure (t, rhs') - pure $ EraRes ty $ CaseEnum etag.term arms loc + pure $ EraRes ty rhs' + _ => throw $ CompileTimeOnly ctx $ E e + Kept => case List1.fromList $ SortedMap.toList arms of + Nothing => pure $ EraRes ty $ Absurd loc + Just arms => do + etag <- eraseElim ctx tag + arms <- for arms $ \(t, rhs) => do + let ty' = sub1 ret (Ann (Tag t loc) etag.type loc) + rhs' <- eraseTerm ctx ty' rhs + pure (t, rhs') + pure $ EraRes ty $ CaseEnum etag.term arms loc -- n ⤋ n' ⇒ ℕ z ⤋ z' ⇐ R[zero∷ℕ/z] ς ≠ 0 -- m : ℕ, ih : R[m/z] | ρ.m, ς.ih ⊢ s ⤋ s' ⇐ R[(succ m)∷ℕ/z] @@ -352,25 +363,24 @@ eraseElim ctx (CaseNat qty qtyIH nat ret zero succ loc) = do Erased => NSNonrec p (sub1 (Erased loc) succ') pure $ EraRes ty $ CaseNat enat.term zero succ loc --- b ⤋ b' ⇒ [π.A] π ≠ 0 --- x : A | πρ.x ⊢ s ⤋ s' ⇐ R[[x]∷[π.A]/z] --- ------------------------------------------------------- --- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[b'/x] ⇒ R[b/z] +-- b ⤋ b' ⇒ [π.A] πρ ≠ 0 x : A | πρ.x ⊢ s ⤋ s' ⇐ R[[x]∷[π.A]/z] +-- ------------------------------------------------------------------ +-- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ let x = b' in s' ⇒ R[b/z] -- --- b ⇒ [0.A] x : A | 0.x ⊢ s ⤋ s' ⇐ R[[x]∷[0.A]/z] --- ------------------------------------------------------- --- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[⌷/x] ⇒ R[b/z] +-- b ⇒ [π.A] x : A | 0.x ⊢ s ⤋ s' ⇐ R[[x]∷[0.A]/z] πρ = 0 +-- ------------------------------------------------------------- +-- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[⌷/x] ⇒ R[b/z] eraseElim ctx (CaseBox qty box ret body loc) = do tbox <- computeElimType ctx SOne box -- [fixme] is there any way to avoid this? (pi, tinner) <- wrapExpect `(expectBOX) ctx loc tbox let ctx' = extendTy (pi * qty) body.name tinner ctx bty = sub1 (ret // shift 1) $ Ann (Box (BVT 0 loc) loc) (weakT 1 tbox) loc - case isErased pi of + case isErased $ qty * pi of Kept => do ebox <- eraseElim ctx box ebody <- eraseTerm ctx' bty body.term - pure $ EraRes (sub1 ret box) $ ebody // one ebox.term + pure $ EraRes (sub1 ret box) $ Let body.name ebox.term ebody loc Erased => do body' <- eraseTerm ctx' bty body.term pure $ EraRes (sub1 ret box) $ body' // one (Erased loc) @@ -412,6 +422,67 @@ eraseElim ctx (DCloE (Sub term th)) = eraseElim ctx $ pushSubstsWith' th id term +export +uses : Var n -> Term n -> Nat +uses i (F x _) = 0 +uses i (B j _) = if i == j then 1 else 0 +uses i (Lam x body _) = uses (VS i) body +uses i (App fun arg _) = uses i fun + uses i arg +uses i (Pair fst snd _) = uses i fst + uses i snd +uses i (Fst pair _) = uses i pair +uses i (Snd pair _) = uses i pair +uses i (Tag tag _) = 0 +uses i (CaseEnum tag cases _) = + uses i tag + foldl max 0 (map (assert_total uses i . snd) cases) +uses i (Absurd _) = 0 +uses i (Zero _) = 0 +uses i (Succ nat _) = uses i nat +uses i (CaseNat nat zer suc _) = uses i nat + max (uses i zer) (uses' suc) + where uses' : CaseNatSuc n -> Nat + uses' (NSRec _ _ s) = uses (VS (VS i)) s + uses' (NSNonrec _ s) = uses (VS i) s +uses i (Let x rhs body _) = uses i rhs + uses (VS i) body +uses i (Erased _) = 0 + +export +inlineable : U.Term n -> Bool +inlineable (F {}) = True +inlineable (B {}) = True +inlineable (Tag {}) = True +inlineable (Absurd {}) = True +inlineable (Erased {}) = True +inlineable _ = False + +export +trimLets : U.Term n -> U.Term n +trimLets (F x loc) = F x loc +trimLets (B i loc) = B i loc +trimLets (Lam x body loc) = Lam x (trimLets body) loc +trimLets (App fun arg loc) = App (trimLets fun) (trimLets arg) loc +trimLets (Pair fst snd loc) = Pair (trimLets fst) (trimLets snd) loc +trimLets (Fst pair loc) = Fst (trimLets pair) loc +trimLets (Snd pair loc) = Snd (trimLets pair) loc +trimLets (Tag tag loc) = Tag tag loc +trimLets (CaseEnum tag cases loc) = + CaseEnum (trimLets tag) + (map (map $ \c => trimLets $ assert_smaller cases c) cases) loc +trimLets (Absurd loc) = Absurd loc +trimLets (Zero loc) = Zero loc +trimLets (Succ nat loc) = Succ (trimLets nat) loc +trimLets (CaseNat nat zer suc loc) = + CaseNat (trimLets nat) (trimLets zer) (trimLets' suc) loc + where trimLets' : CaseNatSuc n -> CaseNatSuc n + trimLets' (NSRec x ih s) = NSRec x ih $ trimLets s + trimLets' (NSNonrec x s) = NSNonrec x $ trimLets s +trimLets (Let x rhs body loc) = + let rhs' = trimLets rhs + body' = trimLets body in + if inlineable rhs' || uses VZ body' == 1 + then sub1 rhs' body' + else Let x rhs' body' loc +trimLets (Erased loc) = Erased loc + + export covering eraseDef : Name -> Q.Definition -> Eff Erase U.Definition eraseDef name def@(MkDef qty type body loc) = @@ -420,4 +491,4 @@ eraseDef name def@(MkDef qty type body loc) = Erased => pure ErasedDef Kept => case body of Postulate => throw $ Postulate loc name - Concrete body => KeptDef <$> eraseTerm empty type body + Concrete body => KeptDef . trimLets <$> eraseTerm empty type body diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 36bbedd..a9b6955 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -35,8 +35,8 @@ data Term where Snd : (pair : Term n) -> Loc -> Term n Tag : (tag : String) -> Loc -> Term n - CaseEnum : (tag : Term n) -> (cases : List (String, Term n)) -> Loc -> Term n - ||| empty match with an erased head + CaseEnum : (tag : Term n) -> (cases : List1 (String, Term n)) -> Loc -> Term n + ||| empty match Absurd : Loc -> Term n Zero : Loc -> Term n @@ -47,6 +47,9 @@ data Term where Loc -> Term n + Let : (x : BindName) -> (rhs : Term n) -> (body : Term (S n)) -> Loc -> + Term n + Erased : Loc -> Term n %name Term s, t, u @@ -61,20 +64,21 @@ data CaseNatSuc where export Located (Term n) where - (F x loc).loc = loc - (B i loc).loc = loc - (Lam x body loc).loc = loc - (App fun arg loc).loc = loc - (Pair fst snd loc).loc = loc - (Fst pair loc).loc = loc - (Snd pair loc).loc = loc - (Tag tag loc).loc = loc - (CaseEnum tag cases loc).loc = loc - (Absurd loc).loc = loc - (Zero loc).loc = loc - (Succ nat loc).loc = loc - (CaseNat nat zer suc loc).loc = loc - (Erased loc).loc = loc + (F _ loc).loc = loc + (B _ loc).loc = loc + (Lam _ _ loc).loc = loc + (App _ _ loc).loc = loc + (Pair _ _ loc).loc = loc + (Fst _ loc).loc = loc + (Snd _ loc).loc = loc + (Tag _ loc).loc = loc + (CaseEnum _ _ loc).loc = loc + (Absurd loc).loc = loc + (Zero loc).loc = loc + (Succ _ loc).loc = loc + (CaseNat _ _ _ loc).loc = loc + (Let _ _ _ loc).loc = loc + (Erased loc).loc = loc public export @@ -85,6 +89,11 @@ public export Definitions = SortedMap Name Definition +export +letD, inD : {opts : LayoutOpts} -> Eff Pretty (Doc opts) +letD = hl Syntax "let" +inD = hl Syntax "in" + export prettyTerm : {opts : LayoutOpts} -> BContext n -> Term n -> Eff Pretty (Doc opts) @@ -136,6 +145,33 @@ private sucPat : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts) sucPat x = pure $ !succD <++> !(prettyTBind x) +private +splitLam : Telescope' BindName a b -> Term b -> + Exists $ \c => (Telescope' BindName a c, Term c) +splitLam ys (Lam x body _) = splitLam (ys :< x) body +splitLam ys t = Evidence _ (ys, t) + +private +splitLet : Telescope (\i => (BindName, Term i)) a b -> Term b -> + Exists $ \c => (Telescope (\i => (BindName, Term i)) a c, Term c) +splitLet ys (Let x rhs body _) = splitLet (ys :< (x, rhs)) body +splitLet ys t = Evidence _ (ys, t) + +private +prettyLets : {opts : LayoutOpts} -> + BContext a -> Telescope (\i => (BindName, Term i)) a b -> + Eff Pretty (SnocList (Doc opts)) +prettyLets xs lets = sequence $ snd $ go lets where + go : forall b. Telescope (\i => (BindName, Term i)) a b -> + (BContext b, SnocList (Eff Pretty (Doc opts))) + go [<] = (xs, [<]) + go (lets :< (x, rhs)) = + let (ys, docs) = go lets + doc = hsep <$> sequence + [letD, prettyTBind x, cstD, assert_total prettyTerm ys rhs, inD] + in + (ys :< x, docs :< doc) + private sucCaseArm : {opts : LayoutOpts} -> CaseNatSuc n -> Eff Pretty (PrettyCaseArm (Doc opts) n) @@ -148,9 +184,10 @@ prettyTerm _ (F x _) = prettyFree x prettyTerm xs (B i _) = prettyTBind $ xs !!! i prettyTerm xs (Lam x body _) = parensIfM Outer =<< do - header <- hsep <$> sequence [lamD, prettyTBind x, darrowD] - body <- withPrec Outer $ prettyTerm (xs :< x) body - hangDSingle header body + let Evidence n' (ys, body) = splitLam [< x] body + vars <- hsep . toList' <$> traverse prettyTBind ys + body <- withPrec Outer $ assert_total prettyTerm (xs . ys) body + hangDSingle (hsep [!lamD, vars, !darrowD]) body prettyTerm xs (App fun arg _) = prettyApp xs fun arg prettyTerm xs (Pair fst snd _) = parens =<< separateTight !commaD <$> @@ -161,21 +198,29 @@ prettyTerm xs (Tag tag _) = prettyTag tag prettyTerm xs (CaseEnum tag cases _) = assert_total prettyCase xs prettyTag tag $ - map (\(t, rhs) => MkPrettyCaseArm t [] rhs) cases + map (\(t, rhs) => MkPrettyCaseArm t [] rhs) $ toList cases prettyTerm xs (Absurd _) = hl Syntax "absurd" prettyTerm xs (Zero _) = zeroD prettyTerm xs (Succ nat _) = prettyApp' xs !succD nat prettyTerm xs (CaseNat nat zer suc _) = assert_total prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)] +prettyTerm xs (Let x rhs body _) = + parensIfM Outer =<< do + let Evidence n' (lets, body) = splitLet [< (x, rhs)] body + heads <- prettyLets xs lets + body <- withPrec Outer $ assert_total prettyTerm (xs . map fst lets) body + let lines = toList $ heads :< body + pure $ ifMultiline (hsep lines) (vsep lines) prettyTerm _ (Erased _) = hl Syntax =<< ifUnicode "⌷" "[]" export prettyDef : {opts : LayoutOpts} -> Name -> - Definition -> Eff Pretty (Maybe (Doc opts)) -prettyDef _ ErasedDef = [|Nothing|] -prettyDef name (KeptDef rhs) = map Just $ do + Definition -> Eff Pretty (Doc opts) +prettyDef name ErasedDef = + pure $ hsep [!(prettyFree name), !cstD, !(prettyTerm [<] $ Erased noLoc)] +prettyDef name (KeptDef rhs) = do name <- prettyFree name eq <- cstD rhs <- prettyTerm [<] rhs @@ -220,6 +265,8 @@ CanSubstSelf Term where CaseNat nat zer suc loc => CaseNat (nat // th) (zer // th) (assert_total substSuc suc th) loc + Let x rhs body loc => + Let x (rhs // th) (assert_total $ body // push th) loc Erased loc => Erased loc where From cc0bade747668cd3d6f3f8dc81cc5f6e6c957a1b Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Tue, 24 Oct 2023 23:52:19 +0200 Subject: [PATCH 031/133] scheme output --- exe/Main.idr | 89 ++++++------ exe/Options.idr | 2 +- lib/Quox/Untyped/Scheme.idr | 276 ++++++++++++++++++++++++++++++++++++ lib/quox-lib.ipkg | 3 +- 4 files changed, 326 insertions(+), 44 deletions(-) create mode 100644 lib/Quox/Untyped/Scheme.idr diff --git a/exe/Main.idr b/exe/Main.idr index be03398..f67aaf2 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -6,6 +6,7 @@ import Quox.Definition as Q import Quox.Pretty import Quox.Untyped.Syntax as U import Quox.Untyped.Erase +import Quox.Untyped.Scheme import Options import Data.IORef @@ -20,22 +21,11 @@ import Control.Eff %hide Core.(>>=) -parameters {auto _ : HasIO io} (width : Nat) - private - putDoc : Doc (Opts width) -> io () - putDoc = putStr . render _ - - private - fPutDoc : File -> Doc (Opts width) -> io (Either FileError ()) - fPutDoc h = fPutStr h . render _ - - private - putDocErr : Doc (Opts width) -> io () - putDocErr = ignore . fPutDoc stderr - - private - die : Doc (Opts width) -> io a - die err = do putDocErr err; exitFailure +private +die : HasIO io => (opts : LayoutOpts) -> Doc opts -> io a +die opts err = do + ignore $ fPutStr stderr $ render opts err + exitFailure private runPretty : Options -> Eff Pretty a -> a @@ -82,6 +72,14 @@ private loadError : Loc -> FilePath -> FileError -> Error loadError loc file err = FromParserError $ LoadError loc file err +private +prettyError : {opts : LayoutOpts} -> Error -> Eff Pretty (Doc opts) +prettyError (ParseError file e) = prettyParseError file e +prettyError (FromParserError e) = FromParser.prettyError True e +prettyError (EraseError e) = Erase.prettyError True e +prettyError (WriteError file e) = pure $ + hangSingle 2 (text "couldn't write file \{file}:") (pshow e) + private data CompileTag = OPTS | STATE @@ -125,21 +123,28 @@ FlexDoc = {opts : LayoutOpts} -> Doc opts private -outputDoc : FlexDoc -> Eff Compile () -outputDoc doc = +outputStr : Lazy String -> Eff Compile () +outputStr str = case !(asksAt OPTS outFile) of None => pure () - Stdout => putDoc !(asksAt OPTS width) doc + Stdout => putStr str File f => do - res <- withFile f WriteTruncate pure $ \h => - fPutDoc !(asksAt OPTS width) h doc + res <- withFile f WriteTruncate pure $ \h => fPutStr h str rethrow $ mapFst (WriteError f) res private -outputDocStopIf : Phase -> FlexDoc -> Eff CompileStop () -outputDocStopIf p doc = - when (!(asksAt OPTS until) == Just p) $ do - lift (outputDoc doc) +outputDocs : {opts : LayoutOpts} -> List (Doc opts) -> Eff Compile () +outputDocs {opts = Opts _} doc = + outputStr $ concat $ map (render _) doc + +private +outputDocStopIf : Phase -> + ({opts : LayoutOpts} -> Eff Pretty (List (Doc opts))) -> + Eff CompileStop () +outputDocStopIf p docs = do + opts <- askAt OPTS + when (opts.until == Just p) $ Prelude.do + lift $ outputDocs (runPretty opts docs) {opts = Opts opts.width} stopHere private @@ -160,41 +165,41 @@ liftErase defs act = \case Ask => pure defs, handleStateIORef !(asksAt STATE suf)] +private +liftScheme : Eff Scheme a -> Eff CompileStop a +liftScheme act = runEff act [handleStateIORef !(newIORef empty)] + private processFile : String -> Eff Compile () processFile file = withEarlyStop $ do Just ast <- loadFile noLoc file | Nothing => pure () - putErrLn "checking \{file}" - outputDocStopIf Parse $ dumpDoc ast + -- putErrLn "checking \{file}" + when (!(asksAt OPTS until) == Just Parse) $ do + lift $ outputStr $ show ast + stopHere defList <- liftFromParser $ concat <$> traverse fromPTopLevel ast - outputDocStopIf Check $ runPretty !(askAt OPTS) $ - vsep <$> traverse (uncurry Q.prettyDef) defList + outputDocStopIf Check $ + traverse (uncurry Q.prettyDef) defList let defs = SortedMap.fromList defList erased <- liftErase defs $ traverse (\(x, d) => (x,) <$> eraseDef x d) defList - outputDocStopIf Erase $ runPretty !(askAt OPTS) $ - vsep . catMaybes <$> traverse (uncurry U.prettyDef) erased + outputDocStopIf Erase $ + traverse (uncurry U.prettyDef) erased + scheme <- liftScheme $ map catMaybes $ + traverse (uncurry defToScheme) erased + outputDocStopIf Scheme $ + (text Scheme.prelude ::) <$> traverse prettySexp scheme die "that's all folks" -private -dieError : HasIO io => Options -> Error -> io a -dieError opts e = do - die opts.width $ runPretty opts $ case e of - ParseError file e => prettyParseError file e - FromParserError e => FromParser.prettyError True e - EraseError e => Erase.prettyError True e - WriteError file e => pure $ - hangSingle 2 (text "couldn't write file \{file}:") (pshow e) - export main : IO () main = do (_, opts, files) <- options case !(runCompile opts !newState $ traverse_ processFile files) of Right () => pure () - Left e => dieError opts e + Left e => die (Opts opts.width) $ runPretty opts $ prettyError e ----------------------------------- diff --git a/exe/Options.idr b/exe/Options.idr index 7698730..8707fe3 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -16,7 +16,7 @@ data OutFile = File String | Stdout | None %runElab derive "OutFile" [Eq, Ord, Show] public export -data Phase = Parse | Check | Erase +data Phase = Parse | Check | Erase | Scheme %name Phase p %runElab derive "Phase" [Eq, Ord, Show] diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr new file mode 100644 index 0000000..b68edc3 --- /dev/null +++ b/lib/Quox/Untyped/Scheme.idr @@ -0,0 +1,276 @@ +module Quox.Untyped.Scheme + +import Quox.Name +import Quox.Context +import Quox.Untyped.Syntax +import Quox.Pretty + +import Quox.EffExtra +import Quox.CharExtra +import Data.String +import Data.SortedSet +import Data.Vect +import Data.List1 +import Derive.Prelude + +%default total +%language ElabReflection + +%hide TT.Name + + +public export +data Id = I String Nat +%runElab derive "Id" [Eq, Ord] + +public export +Scheme : List (Type -> Type) +Scheme = [State (SortedSet Id)] + + +public export +data Sexp = + V Id +| L (List Sexp) +| Q Sexp +| N Nat +| Lambda (List Id) Sexp +| Let (List (Id, Sexp)) Sexp +| Case Sexp (List1 (List Sexp, Sexp)) +| Define Id Sexp + +export +FromString Sexp where fromString s = V $ I s 0 + + +private +makeIdBase : Mods -> String -> String +makeIdBase mods str = joinBy "." $ toList $ mods :< str + +export +makeId : Name -> Id +makeId (MakeName mods (UN str)) = I (makeIdBase mods str) 0 +makeId (MakeName mods (MN str k)) = I (makeIdBase mods str) (S k) +makeId (MakeName mods Unused) = I (makeIdBase mods "_") 0 + +export +makeIdB : BindName -> Id +makeIdB (BN name _) = makeId $ MakeName [<] name + +private +bump : Id -> Id +bump (I x i) = I x (S i) + +export covering +getFresh : SortedSet Id -> Id -> Id +getFresh used x = + if contains x used then getFresh used (bump x) else x + +export covering +freshIn : Id -> (Id -> Eff Scheme a) -> Eff Scheme a +freshIn x k = + let x = getFresh !get x in + local (insert x) $ k x + +export covering +freshInB : BindName -> (Id -> Eff Scheme a) -> Eff Scheme a +freshInB x = freshIn (makeIdB x) + +export covering +freshInBN : Vect n BindName -> (Vect n Id -> Eff Scheme a) -> + Eff Scheme a +freshInBN xs act = do + let (xs', used') = go (map makeIdB xs) !get + local_ used' $ act xs' +where + go : forall n. Vect n Id -> SortedSet Id -> (Vect n Id, SortedSet Id) + go [] used = ([], used) + go (x :: xs) used = + let x = getFresh used x + (xs, used) = go xs (insert x used) + in + (x :: xs, used) + +export covering +toScheme : Context' Id n -> Term n -> Eff Scheme Sexp +toScheme xs (F x loc) = pure $ V $ makeId x + +toScheme xs (B i loc) = pure $ V $ xs !!! i + +toScheme xs (Lam x body loc) = + freshInB x $ \x => + pure $ Lambda [x] !(toScheme (xs :< x) body) + +toScheme xs (App fun arg loc) = + pure $ L [!(toScheme xs fun), !(toScheme xs arg)] + +toScheme xs (Pair fst snd loc) = + pure $ L ["cons", !(toScheme xs fst), !(toScheme xs snd)] + +toScheme xs (Fst pair loc) = + pure $ L ["car", !(toScheme xs pair)] + +toScheme xs (Snd pair loc) = + pure $ L ["cdr", !(toScheme xs pair)] + +toScheme xs (Tag tag loc) = + pure $ Q $ fromString tag + +toScheme xs (CaseEnum tag cases loc) = + Case <$> toScheme xs tag + <*> for cases (\(t, rhs) => ([fromString t],) <$> toScheme xs rhs) + +toScheme xs (Absurd loc) = + pure $ Q "absurd" + +toScheme xs (Zero loc) = + pure $ N 0 + +toScheme xs (Succ nat loc) = + case !(toScheme xs nat) of + N n => pure $ N n + s => pure $ L ["1+", s] + +toScheme xs (CaseNat nat zer (NSRec p ih suc) loc) = + freshInBN [p, ih] $ \[p, ih] => + pure $ + L ["case-nat-rec", + Lambda [] !(toScheme xs zer), + Lambda [p, ih] !(toScheme (xs :< p :< ih) suc), + !(toScheme xs nat)] + +toScheme xs (CaseNat nat zer (NSNonrec p suc) loc) = + freshInB p $ \p => + pure $ + L ["case-nat-nonrec", + Lambda [] !(toScheme xs zer), + Lambda [p] !(toScheme (xs :< p) suc), + !(toScheme xs nat)] + +toScheme xs (Let x rhs body loc) = + freshInB x $ \x => + pure $ Let [(x, !(toScheme xs rhs))] !(toScheme (xs :< x) body) + +toScheme xs (Erased loc) = + pure $ Q "erased" + + +export +prelude : String +prelude = """ +(define (case-nat-rec z s n) + (if (= n 0) + (z) + (let* [(p (1- n)) + (ih (case-nat-rec z s p))] + (s p ih)))) + +(define (case-nat-nonrec z s n) + (if (= n 0) (z) (s (1- n)))) + +""" + +export covering +defToScheme : Name -> Definition -> Eff Scheme (Maybe Sexp) +defToScheme x ErasedDef = pure Nothing +defToScheme x (KeptDef def) = do + let x = makeId x + modify $ insert x + pure $ Just $ Define x !(toScheme [<] def) + + +export +isSchemeInitial : Char -> Bool +isSchemeInitial c = + let gc = genCat c in + isLetter gc || isSymbol gc && c /= '|' || + gc == Number Letter || + gc == Number Other || + gc == Mark NonSpacing || + gc == Punctuation Dash || + gc == Punctuation Connector || + gc == Punctuation Other && c /= '\'' && c /= '\\' || + gc == Other PrivateUse || + (c `elem` unpack "!$%&*/:<=>?~_^") + +export +isSchemeSubsequent : Char -> Bool +isSchemeSubsequent c = + let gc = genCat c in + isSchemeInitial c || + isNumber gc || + isMark gc || + (c `elem` unpack ".+-@") + +export +isSchemeId : String -> Bool +isSchemeId str = + str == "1+" || str == "1-" || + case unpack str of + [] => False + c :: cs => isSchemeInitial c && all isSchemeSubsequent cs + +export +escId : String -> String +escId str = + let str' = concatMap doEsc $ unpack str in + if isSchemeId str' then str' else "|\{str}|" +where + doEsc : Char -> String + doEsc '\\' = "\\\\" + doEsc '|' = "\\|" + doEsc '\'' = "^" + doEsc c = singleton c + +prettyId' : {opts : LayoutOpts} -> Id -> Doc opts +prettyId' (I str 0) = text $ escId str +prettyId' (I str k) = text $ escId "\{str}:\{show k}" + +prettyId : {opts : LayoutOpts} -> Id -> Eff Pretty (Doc opts) +prettyId x = hl TVar $ prettyId' x + +orIndent : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Doc opts +orIndent a b = + parens $ ifMultiline (a <++> b) (a `vappend` indent 2 b) + +export covering +prettySexp : {opts : LayoutOpts} -> Sexp -> Eff Pretty (Doc opts) +prettySexp (V x) = prettyId x +prettySexp (L []) = hl Delim "()" +prettySexp (L (x :: xs)) = do + d <- prettySexp x + ds <- Prelude.traverse prettySexp xs + parens $ ifMultiline (hsep $ d :: ds) (vsep $ d :: map (indent 2) ds) +prettySexp (Q (V x)) = hl Tag $ "'" <+> prettyId' x +prettySexp (Q x) = pure $ hcat [!(hl Tag "'"), !(prettySexp x)] +prettySexp (N n) = hl Tag $ pshow n +prettySexp (Lambda xs e) = + pure $ orIndent + (hsep [!(hl Syntax "lambda"), !(prettySexp $ L $ map V xs)]) + !(prettySexp e) +prettySexp (Let ps e) = + pure $ orIndent + (hsep [!(hl Syntax "let"), !(bracks . sep =<< traverse prettyBind ps)]) + !(prettySexp e) +where + prettyBind : (Id, Sexp) -> Eff Pretty (Doc opts) + prettyBind (x, e) = pure $ sep [!(prettyId x), !(prettySexp e)] +prettySexp (Case h as) = do + header' <- prettySexp h + case_ <- caseD + let header = ifMultiline (case_ <++> header') + (case_ `vappend` indent 2 header') + bodys <- traverse prettyCase $ toList as + pure $ ifMultiline + (parens $ header <++> hsep bodys) + (parens $ header `vappend` indent 2 (vsep bodys)) +where + prettyCase : (List Sexp, Sexp) -> Eff Pretty (Doc opts) + prettyCase (ps, e) = bracks $ + ifMultiline + (hsep [!(parens . hsep =<< traverse prettySexp ps), !(prettySexp e)]) + (vsep [!(parens . sep =<< traverse prettySexp ps), !(prettySexp e)]) +prettySexp (Define x e) = + pure $ orIndent + (hsep [!(hl Syntax "define"), !(prettyId x)]) + !(prettySexp e) diff --git a/lib/quox-lib.ipkg b/lib/quox-lib.ipkg index 27063b1..f5d188a 100644 --- a/lib/quox-lib.ipkg +++ b/lib/quox-lib.ipkg @@ -61,4 +61,5 @@ modules = Quox.Parser.FromParser.Error, Quox.Parser, Quox.Untyped.Syntax, - Quox.Untyped.Erase + Quox.Untyped.Erase, + Quox.Untyped.Scheme From 050346e344718250d77d5c813ac50ee19c6f9ddb Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Wed, 1 Nov 2023 12:56:27 +0100 Subject: [PATCH 032/133] add postulate, #[compile-scheme], #[main] --- exe/Main.idr | 50 ++- lib/Quox/Definition.idr | 28 +- lib/Quox/Parser/FromParser.idr | 83 +++-- lib/Quox/Parser/FromParser/Error.idr | 20 +- lib/Quox/Parser/Lexer.idr | 3 + lib/Quox/Parser/Parser.idr | 54 +++- lib/Quox/Parser/Syntax.idr | 13 +- lib/Quox/Untyped/Erase.idr | 24 +- lib/Quox/Untyped/Scheme.idr | 453 ++++++++++++++++----------- lib/Quox/Untyped/Syntax.idr | 97 ++++-- tests/Tests/Equal.idr | 2 +- tests/Tests/Parser.idr | 65 ++-- tests/Tests/Reduce.idr | 6 +- tests/Tests/Typechecker.idr | 2 +- 14 files changed, 579 insertions(+), 321 deletions(-) diff --git a/exe/Main.idr b/exe/Main.idr index f67aaf2..f8b29ae 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -58,16 +58,19 @@ newState = pure $ MkState { } private -data Error - = ParseError String Parser.Error - | FromParserError FromParser.Error - | EraseError Erase.Error - | WriteError FilePath FileError +data Error = + ParseError String Parser.Error +| FromParserError FromParser.Error +| EraseError Erase.Error +| WriteError FilePath FileError +| NoMain +| MultipleMains (List Id) %hide FromParser.Error %hide Erase.Error %hide Lexer.Error %hide Parser.Error + private loadError : Loc -> FilePath -> FileError -> Error loadError loc file err = FromParserError $ LoadError loc file err @@ -77,6 +80,10 @@ prettyError : {opts : LayoutOpts} -> Error -> Eff Pretty (Doc opts) prettyError (ParseError file e) = prettyParseError file e prettyError (FromParserError e) = FromParser.prettyError True e prettyError (EraseError e) = Erase.prettyError True e +prettyError NoMain = pure "no #[main] function given" +prettyError (MultipleMains xs) = + pure $ sep ["multiple #[main] functions given:", + separateLoose "," !(traverse prettyId xs)] prettyError (WriteError file e) = pure $ hangSingle 2 (text "couldn't write file \{file}:") (pshow e) @@ -133,9 +140,10 @@ outputStr str = rethrow $ mapFst (WriteError f) res private -outputDocs : {opts : LayoutOpts} -> List (Doc opts) -> Eff Compile () -outputDocs {opts = Opts _} doc = - outputStr $ concat $ map (render _) doc +outputDocs : (opts : Options) -> + ({opts : LayoutOpts} -> List (Doc opts)) -> Eff Compile () +outputDocs opts doc = + outputStr $ concat $ map (render (Opts opts.width)) doc private outputDocStopIf : Phase -> @@ -144,7 +152,7 @@ outputDocStopIf : Phase -> outputDocStopIf p docs = do opts <- askAt OPTS when (opts.until == Just p) $ Prelude.do - lift $ outputDocs (runPretty opts docs) {opts = Opts opts.width} + lift $ outputDocs !(askAt OPTS) (runPretty opts docs) stopHere private @@ -166,10 +174,19 @@ liftErase defs act = handleStateIORef !(asksAt STATE suf)] private -liftScheme : Eff Scheme a -> Eff CompileStop a -liftScheme act = runEff act [handleStateIORef !(newIORef empty)] +liftScheme : Eff Scheme a -> Eff CompileStop (a, List Id) +liftScheme act = do + runEff [|MkPair act (getAt MAIN)|] + [handleStateIORef !(newIORef empty), + handleStateIORef !(newIORef [])] +private +oneMain : Has (Except Error) fs => List Id -> Eff fs Id +oneMain [] = throw NoMain +oneMain [x] = pure x +oneMain mains = throw $ MultipleMains mains + private processFile : String -> Eff Compile () processFile file = withEarlyStop $ do @@ -187,11 +204,16 @@ processFile file = withEarlyStop $ do traverse (\(x, d) => (x,) <$> eraseDef x d) defList outputDocStopIf Erase $ traverse (uncurry U.prettyDef) erased - scheme <- liftScheme $ map catMaybes $ + (scheme, mains) <- liftScheme $ map catMaybes $ traverse (uncurry defToScheme) erased outputDocStopIf Scheme $ - (text Scheme.prelude ::) <$> traverse prettySexp scheme - die "that's all folks" + intersperse empty <$> traverse prettySexp scheme + opts <- askAt OPTS + main <- oneMain mains + lift $ outputDocs opts $ intersperse empty $ runPretty opts $ do + res <- traverse prettySexp scheme + runner <- makeRunMain main + pure $ text Scheme.prelude :: res ++ [runner] export main : IO () diff --git a/lib/Quox/Definition.idr b/lib/Quox/Definition.idr index 4842c29..1fc19aa 100644 --- a/lib/Quox/Definition.idr +++ b/lib/Quox/Definition.idr @@ -26,18 +26,24 @@ namespace DefBody public export record Definition where constructor MkDef - qty : GQty - type0 : Term 0 0 - body0 : DefBody - loc_ : Loc + qty : GQty + type0 : Term 0 0 + body0 : DefBody + scheme : Maybe String + isMain : Bool + loc_ : Loc public export %inline -mkPostulate : GQty -> (type0 : Term 0 0) -> Loc -> Definition -mkPostulate qty type0 loc_ = MkDef {qty, type0, body0 = Postulate, loc_} +mkPostulate : GQty -> (type0 : Term 0 0) -> Maybe String -> Bool -> Loc -> + Definition +mkPostulate qty type0 scheme isMain loc_ = + MkDef {qty, type0, body0 = Postulate, scheme, isMain, loc_} public export %inline -mkDef : GQty -> (type0, term0 : Term 0 0) -> Loc -> Definition -mkDef qty type0 term0 loc_ = MkDef {qty, type0, body0 = Concrete term0, loc_} +mkDef : GQty -> (type0, term0 : Term 0 0) -> Maybe String -> Bool -> Loc -> + Definition +mkDef qty type0 term0 scheme isMain loc_ = + MkDef {qty, type0, body0 = Concrete term0, scheme, isMain, loc_} export Located Definition where def.loc = def.loc_ export Relocatable Definition where setLoc loc = {loc_ := loc} @@ -108,10 +114,10 @@ lookupElim0 = lookupElim export prettyDef : {opts : LayoutOpts} -> Name -> Definition -> Eff Pretty (Doc opts) -prettyDef name (MkDef qty type _ _) = withPrec Outer $ do - qty <- prettyQty qty.qty +prettyDef name def = withPrec Outer $ do + qty <- prettyQty def.qty.qty dot <- dotD name <- prettyFree name colon <- colonD - type <- prettyTerm [<] [<] type + type <- prettyTerm [<] [<] def.type hangDSingle (hsep [hcat [qty, dot, name], colon]) type diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 84eaed9..e2f2444 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -323,35 +323,39 @@ liftTC tc = runEff tc $ with Union.(::) \g => send g] private -addDef : Has DefsState fs => Name -> GQty -> Term 0 0 -> Term 0 0 -> Loc -> - Eff fs NDefinition -addDef name gqty type term loc = do - let def = mkDef gqty type term loc +addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition +addDef name def = do modifyAt DEFS $ insert name def pure (name, def) export covering -fromPDef : PDefinition -> Eff FromParserPure NDefinition -fromPDef (MkPDef qty pname ptype pterm defLoc) = do +fromPDef : PDefinition -> Maybe String -> Bool -> + Eff FromParserPure NDefinition +fromPDef (MkPDef qty pname pbody defLoc) scheme isMain = do name <- fromPBaseNameNS pname when !(getsAt DEFS $ isJust . lookup name) $ do throw $ AlreadyExists defLoc name gqty <- globalPQty qty.val qty.loc let sqty = globalToSubj gqty - type <- traverse fromPTerm ptype - term <- fromPTerm pterm - case type of - Just type => do - ignore $ liftTC $ do - checkTypeC empty type Nothing - checkC empty sqty term type - addDef name gqty type term defLoc - Nothing => do - let E elim = term - | _ => throw $ AnnotationNeeded term.loc empty term - res <- liftTC $ inferC empty sqty elim - addDef name gqty res.type term defLoc + case pbody of + PConcrete ptype pterm => do + type <- traverse fromPTerm ptype + term <- fromPTerm pterm + case type of + Just type => do + ignore $ liftTC $ do + checkTypeC empty type Nothing + checkC empty sqty term type + addDef name $ mkDef gqty type term scheme isMain defLoc + Nothing => do + let E elim = term + | _ => throw $ AnnotationNeeded term.loc empty term + res <- liftTC $ inferC empty sqty elim + addDef name $ mkDef gqty res.type term scheme isMain defLoc + PPostulate ptype => do + type <- fromPTerm ptype + addDef name $ mkPostulate gqty type scheme isMain defLoc public export @@ -359,31 +363,50 @@ data HasFail = NoFail | AnyFail | FailWith String export hasFail : List PDeclMod -> HasFail -hasFail [] = NoFail -hasFail (PFail str _ :: _) = maybe AnyFail FailWith str +hasFail [] = NoFail +hasFail (PFail str :: _) = maybe AnyFail FailWith str +hasFail (_ :: rest) = hasFail rest + +export +getScheme : List PDeclMod -> Maybe String +getScheme [] = Nothing +getScheme (PCompileScheme str :: _) = Just str +getScheme (_ :: rest) = getScheme rest + +export +isMain : List PDeclMod -> Bool +isMain [] = False +isMain (PMain :: _) = True +isMain (_ :: rest) = isMain rest export covering fromPDecl : PDecl -> Eff FromParserPure (List NDefinition) export covering -fromPDeclBody : PDeclBody -> Eff FromParserPure (List NDefinition) -fromPDeclBody (PDef def) = singleton <$> fromPDef def -fromPDeclBody (PNs ns) = +fromPDeclBody : PDeclBody -> Maybe String -> Bool -> Loc -> + Eff FromParserPure (List NDefinition) +fromPDeclBody (PDef def) scheme isMain loc = + singleton <$> fromPDef def scheme isMain +fromPDeclBody (PNs ns) scheme isMain loc = do + when (isJust scheme) $ throw $ SchemeOnNamespace loc ns.name + when isMain $ throw $ MainOnNamespace loc ns.name localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls export covering -expectFail : PDeclBody -> Eff FromParserPure Error -expectFail body = - case fromParserPure !(getAt GEN) !(getAt DEFS) $ fromPDeclBody body of +expectFail : PDeclBody -> Loc -> Eff FromParserPure Error +expectFail body loc = + let res = fromParserPure !(getAt GEN) !(getAt DEFS) $ + fromPDeclBody body Nothing False loc in + case res of Left err => pure err Right _ => throw $ ExpectedFail body.loc fromPDecl (MkPDecl mods decl loc) = case hasFail mods of - NoFail => fromPDeclBody decl - AnyFail => expectFail decl $> [] + NoFail => fromPDeclBody decl (getScheme mods) (isMain mods) loc + AnyFail => expectFail decl loc $> [] FailWith str => do - err <- expectFail decl + err <- expectFail decl loc let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e if str `isInfixOf` renderInfinite msg then pure [] diff --git a/lib/Quox/Parser/FromParser/Error.idr b/lib/Quox/Parser/FromParser/Error.idr index eee70b5..f1afbff 100644 --- a/lib/Quox/Parser/FromParser/Error.idr +++ b/lib/Quox/Parser/FromParser/Error.idr @@ -35,6 +35,8 @@ data Error = | AlreadyExists Loc Name | LoadError Loc FilePath FileError | ExpectedFail Loc + | SchemeOnNamespace Loc Mods + | MainOnNamespace Loc Mods | WrongFail String Error Loc | WrapParseError String ParseError @@ -123,12 +125,22 @@ parameters {opts : LayoutOpts} (showContext : Bool) text $ show err] prettyError (ExpectedFail loc) = pure $ - sep [!(prettyLoc loc), "expected error"] + vsep [!(prettyLoc loc), "expected error"] + + prettyError (SchemeOnNamespace loc ns) = pure $ + vsep [!(prettyLoc loc), + hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns), + "cannot have #[compile-scheme] attached"]] + + prettyError (MainOnNamespace loc ns) = pure $ + vsep [!(prettyLoc loc), + hsep ["namespace", !(hl Free $ text $ joinBy "." $ toList ns), + "cannot have #[main] attached"]] prettyError (WrongFail str err loc) = pure $ - sep [!(prettyLoc loc), - "wrong error, expected to match", !(hl Tag $ text "\"\{str}\""), - "but got", !(prettyError err)] + vsep [!(prettyLoc loc), + "wrong error, expected to match", !(hl Tag $ text "\"\{str}\""), + "but got", !(prettyError err)] prettyError (WrapParseError file err) = prettyParseError file err diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index 3780809..3db9736 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -227,6 +227,9 @@ reserved = Word1 "def", Word1 "def0", Word "defω" `Or` Word "def#", + Word1 "postulate", + Word1 "postulate0", + Word "postulateω" `Or` Word "postulate#", Sym1 "=", Word1 "load", Word1 "namespace"] diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index a5ed716..fb16aaf 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -587,32 +587,60 @@ pragma : Grammar True a -> Grammar True a pragma p = resC "#[" *> p <* mustWork (resC "]") export -declMod : FileName -> Grammar True PDeclMod -declMod fname = withLoc fname $ pragma $ - exactName "fail" *> [|PFail $ optional strLit|] +declMod : Grammar True PDeclMod +declMod = pragma $ + exactName "fail" *> [|PFail $ optional strLit|] + <|> exactName "compile-scheme" *> [|PCompileScheme strLit|] + <|> exactName "main" $> PMain + <|> do other <- qname + fatalError "unknown declaration flag \{show other}" {c = False} export decl : FileName -> Grammar True PDecl -||| `def` alone means `defω` +||| `def` alone means `defω`; same for `postulate` export -defIntro : FileName -> Grammar True PQty -defIntro fname = - withLoc fname (PQ Zero <$ resC "def0") - <|> withLoc fname (PQ Any <$ resC "defω") - <|> do pos <- bounds $ resC "def" +defIntro' : (bare, zero, omega : String) -> + (0 _ : IsReserved bare) => + (0 _ : IsReserved zero) => + (0 _ : IsReserved omega) => + FileName -> Grammar True PQty +defIntro' bare zero omega fname = + withLoc fname (PQ Zero <$ resC zero) + <|> withLoc fname (PQ Any <$ resC omega) + <|> do pos <- bounds $ resC bare let any = PQ Any $ makeLoc fname pos.bounds option any $ qty fname <* needRes "." export -definition : FileName -> Grammar True PDefinition -definition fname = withLoc fname $ do +defIntro : FileName -> Grammar True PQty +defIntro = defIntro' "def" "def0" "defω" + +export +postulateIntro : FileName -> Grammar True PQty +postulateIntro = defIntro' "postulate" "postulate0" "postulateω" + +export +postulate : FileName -> Grammar True PDefinition +postulate fname = withLoc fname $ Core.do + qty <- postulateIntro fname + name <- baseName + type <- resC ":" *> mustWork (term fname) + pure $ MkPDef qty name $ PPostulate type + +export +concrete : FileName -> Grammar True PDefinition +concrete fname = withLoc fname $ do qty <- defIntro fname name <- baseName type <- optional $ resC ":" *> mustWork (term fname) term <- needRes "=" *> mustWork (term fname) optRes ";" - pure $ MkPDef qty name type term + pure $ MkPDef qty name $ PConcrete type term + +export +definition : FileName -> Grammar True PDefinition +definition fname = try (postulate fname) <|> concrete fname export namespace_ : FileName -> Grammar True PNamespace @@ -629,7 +657,7 @@ export declBody : FileName -> Grammar True PDeclBody declBody fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|] -decl fname = withLoc fname [|MkPDecl (many $ declMod fname) (declBody fname)|] +decl fname = withLoc fname [|MkPDecl (many declMod) (declBody fname)|] export load : FileName -> Grammar True PTopLevel diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index 8edf657..55cfc6a 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -141,13 +141,18 @@ Located PCaseBody where (CaseBox _ _ loc).loc = loc +public export +data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm +%name PBody body +%runElab derive "PBody" [Eq, Ord, Show, PrettyVal] + + public export record PDefinition where constructor MkPDef qty : PQty name : PBaseName - type : Maybe PTerm - term : PTerm + body : PBody loc_ : Loc %name PDefinition def %runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal] @@ -156,7 +161,9 @@ export Located PDefinition where def.loc = def.loc_ public export data PDeclMod = - PFail (Maybe String) Loc + PFail (Maybe String) + | PCompileScheme String + | PMain %name PDeclMod mod %runElab derive "PDeclMod" [Eq, Ord, Show, PrettyVal] diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index ce775f7..4161ecf 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -46,6 +46,7 @@ data Error = | WrapTypeError TypeError | Postulate Loc Name | WhileErasing Name Q.Definition Error +| MainIsErased Loc Name %name Error err private %inline @@ -58,6 +59,7 @@ Located Error where (WrapTypeError err).loc = err.loc (Postulate loc _).loc = loc (WhileErasing _ def e).loc = e.loc `or` def.loc + (MainIsErased loc _).loc = loc parameters {opts : LayoutOpts} (showContext : Bool) @@ -71,9 +73,11 @@ parameters {opts : LayoutOpts} (showContext : Bool) prettyErrorNoLoc showContext err prettyErrorNoLoc (Postulate _ x) = pure $ sep [!(prettyFree x), "is a postulate with no definition"] - prettyErrorNoLoc (WhileErasing name def err) = pure $ - vsep [hsep ["while erasing the definition", !(prettyFree name)], + prettyErrorNoLoc (WhileErasing x def err) = pure $ + vsep [hsep ["while erasing the definition", !(prettyFree x)], !(prettyErrorNoLoc err)] + prettyErrorNoLoc (MainIsErased _ x) = + pure $ hsep [!(prettyFree x), "is marked #[main] but is erased"] export prettyError : Error -> Eff Pretty (Doc opts) @@ -485,10 +489,16 @@ trimLets (Erased loc) = Erased loc export covering eraseDef : Name -> Q.Definition -> Eff Erase U.Definition -eraseDef name def@(MkDef qty type body loc) = +eraseDef name def@(MkDef qty type body scheme isMain loc) = wrapErr (WhileErasing name def) $ case isErased qty.qty of - Erased => pure ErasedDef - Kept => case body of - Postulate => throw $ Postulate loc name - Concrete body => KeptDef . trimLets <$> eraseTerm empty type body + Erased => do + when isMain $ throw $ MainIsErased loc name + pure ErasedDef + Kept => + case scheme of + Just str => pure $ SchemeDef isMain str + Nothing => case body of + Postulate => throw $ Postulate loc name + Concrete body => KeptDef isMain . trimLets <$> + eraseTerm empty type body diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index b68edc3..db69712 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -7,10 +7,11 @@ import Quox.Pretty import Quox.EffExtra import Quox.CharExtra +import Data.DPair +import Data.List1 import Data.String import Data.SortedSet import Data.Vect -import Data.List1 import Derive.Prelude %default total @@ -19,165 +20,6 @@ import Derive.Prelude %hide TT.Name -public export -data Id = I String Nat -%runElab derive "Id" [Eq, Ord] - -public export -Scheme : List (Type -> Type) -Scheme = [State (SortedSet Id)] - - -public export -data Sexp = - V Id -| L (List Sexp) -| Q Sexp -| N Nat -| Lambda (List Id) Sexp -| Let (List (Id, Sexp)) Sexp -| Case Sexp (List1 (List Sexp, Sexp)) -| Define Id Sexp - -export -FromString Sexp where fromString s = V $ I s 0 - - -private -makeIdBase : Mods -> String -> String -makeIdBase mods str = joinBy "." $ toList $ mods :< str - -export -makeId : Name -> Id -makeId (MakeName mods (UN str)) = I (makeIdBase mods str) 0 -makeId (MakeName mods (MN str k)) = I (makeIdBase mods str) (S k) -makeId (MakeName mods Unused) = I (makeIdBase mods "_") 0 - -export -makeIdB : BindName -> Id -makeIdB (BN name _) = makeId $ MakeName [<] name - -private -bump : Id -> Id -bump (I x i) = I x (S i) - -export covering -getFresh : SortedSet Id -> Id -> Id -getFresh used x = - if contains x used then getFresh used (bump x) else x - -export covering -freshIn : Id -> (Id -> Eff Scheme a) -> Eff Scheme a -freshIn x k = - let x = getFresh !get x in - local (insert x) $ k x - -export covering -freshInB : BindName -> (Id -> Eff Scheme a) -> Eff Scheme a -freshInB x = freshIn (makeIdB x) - -export covering -freshInBN : Vect n BindName -> (Vect n Id -> Eff Scheme a) -> - Eff Scheme a -freshInBN xs act = do - let (xs', used') = go (map makeIdB xs) !get - local_ used' $ act xs' -where - go : forall n. Vect n Id -> SortedSet Id -> (Vect n Id, SortedSet Id) - go [] used = ([], used) - go (x :: xs) used = - let x = getFresh used x - (xs, used) = go xs (insert x used) - in - (x :: xs, used) - -export covering -toScheme : Context' Id n -> Term n -> Eff Scheme Sexp -toScheme xs (F x loc) = pure $ V $ makeId x - -toScheme xs (B i loc) = pure $ V $ xs !!! i - -toScheme xs (Lam x body loc) = - freshInB x $ \x => - pure $ Lambda [x] !(toScheme (xs :< x) body) - -toScheme xs (App fun arg loc) = - pure $ L [!(toScheme xs fun), !(toScheme xs arg)] - -toScheme xs (Pair fst snd loc) = - pure $ L ["cons", !(toScheme xs fst), !(toScheme xs snd)] - -toScheme xs (Fst pair loc) = - pure $ L ["car", !(toScheme xs pair)] - -toScheme xs (Snd pair loc) = - pure $ L ["cdr", !(toScheme xs pair)] - -toScheme xs (Tag tag loc) = - pure $ Q $ fromString tag - -toScheme xs (CaseEnum tag cases loc) = - Case <$> toScheme xs tag - <*> for cases (\(t, rhs) => ([fromString t],) <$> toScheme xs rhs) - -toScheme xs (Absurd loc) = - pure $ Q "absurd" - -toScheme xs (Zero loc) = - pure $ N 0 - -toScheme xs (Succ nat loc) = - case !(toScheme xs nat) of - N n => pure $ N n - s => pure $ L ["1+", s] - -toScheme xs (CaseNat nat zer (NSRec p ih suc) loc) = - freshInBN [p, ih] $ \[p, ih] => - pure $ - L ["case-nat-rec", - Lambda [] !(toScheme xs zer), - Lambda [p, ih] !(toScheme (xs :< p :< ih) suc), - !(toScheme xs nat)] - -toScheme xs (CaseNat nat zer (NSNonrec p suc) loc) = - freshInB p $ \p => - pure $ - L ["case-nat-nonrec", - Lambda [] !(toScheme xs zer), - Lambda [p] !(toScheme (xs :< p) suc), - !(toScheme xs nat)] - -toScheme xs (Let x rhs body loc) = - freshInB x $ \x => - pure $ Let [(x, !(toScheme xs rhs))] !(toScheme (xs :< x) body) - -toScheme xs (Erased loc) = - pure $ Q "erased" - - -export -prelude : String -prelude = """ -(define (case-nat-rec z s n) - (if (= n 0) - (z) - (let* [(p (1- n)) - (ih (case-nat-rec z s p))] - (s p ih)))) - -(define (case-nat-nonrec z s n) - (if (= n 0) (z) (s (1- n)))) - -""" - -export covering -defToScheme : Name -> Definition -> Eff Scheme (Maybe Sexp) -defToScheme x ErasedDef = pure Nothing -defToScheme x (KeptDef def) = do - let x = makeId x - modify $ insert x - pure $ Just $ Define x !(toScheme [<] def) - export isSchemeInitial : Char -> Bool @@ -222,55 +64,306 @@ where doEsc '\'' = "^" doEsc c = singleton c + +public export +data Id = I String Nat +%runElab derive "Id" [Eq, Ord] + +private prettyId' : {opts : LayoutOpts} -> Id -> Doc opts prettyId' (I str 0) = text $ escId str prettyId' (I str k) = text $ escId "\{str}:\{show k}" +export prettyId : {opts : LayoutOpts} -> Id -> Eff Pretty (Doc opts) prettyId x = hl TVar $ prettyId' x + +public export +data StateTag = AVOID | MAIN + +public export +Scheme : List (Type -> Type) +Scheme = [StateL AVOID (SortedSet Id), StateL MAIN (List Id)] + -- names to avoid, and functions with #[main] (should only be one) + + +public export +data Sexp = + V Id +| L (List Sexp) +| Q Sexp +| N Nat +| Lambda (List Id) Sexp +| LambdaC (List Id) Sexp -- curried lambda +| Let Id Sexp Sexp +| Case Sexp (List1 (List Sexp, Sexp)) +| Define Id Sexp +| Literal String + +export +FromString Sexp where fromString s = V $ I s 0 + + +private +makeIdBase : Mods -> String -> String +makeIdBase mods str = joinBy "." $ toList $ mods :< str + +export +makeId : Name -> Id +makeId (MakeName mods (UN str)) = I (makeIdBase mods str) 0 +makeId (MakeName mods (MN str k)) = I (makeIdBase mods str) 0 +makeId (MakeName mods Unused) = I (makeIdBase mods "_") 0 + +export +makeIdB : BindName -> Id +makeIdB (BN name _) = makeId $ MakeName [<] name + +private +bump : Id -> Id +bump (I x i) = I x (S i) + +export covering +getFresh : SortedSet Id -> Id -> Id +getFresh used x = + if contains x used then getFresh used (bump x) else x + +export covering +freshIn : Id -> (Id -> Eff Scheme a) -> Eff Scheme a +freshIn x k = + let x = getFresh !(getAt AVOID) x in + localAt AVOID (insert x) $ k x + +export covering +freshInB : BindName -> (Id -> Eff Scheme a) -> Eff Scheme a +freshInB x = freshIn (makeIdB x) + +export covering +freshInBT : Telescope' BindName m n -> + (Telescope' Id m n -> Eff Scheme a) -> + Eff Scheme a +freshInBT xs act = do + let (xs', used') = go (map makeIdB xs) !(getAt AVOID) + localAt_ AVOID used' $ act xs' +where + go : forall n. Telescope' Id m n -> + SortedSet Id -> (Telescope' Id m n, SortedSet Id) + go [<] used = ([<], used) + go (xs :< x) used = + let x = getFresh used x + (xs, used) = go xs (insert x used) + in + (xs :< x, used) + +export covering +freshInBC : Context' BindName n -> (Context' Id n -> Eff Scheme a) -> + Eff Scheme a +freshInBC = freshInBT + +export covering +toScheme : Context' Id n -> Term n -> Eff Scheme Sexp +toScheme xs (F x loc) = pure $ V $ makeId x + +toScheme xs (B i loc) = pure $ V $ xs !!! i + +toScheme xs (Lam x body loc) = + let Evidence n' (ys, body) = splitLam [< x] body in + freshInBT ys $ \ys => do + pure $ LambdaC (toList' ys) !(toScheme (xs . ys) body) + +toScheme xs (App fun arg loc) = do + let (fun, args) = splitApp fun + fun <- toScheme xs fun + args <- traverse (toScheme xs) args + arg <- toScheme xs arg + pure $ if null args + then L [fun, arg] + else L $ "%" :: fun :: toList (args :< arg) + +toScheme xs (Pair fst snd loc) = + pure $ L ["cons", !(toScheme xs fst), !(toScheme xs snd)] + +toScheme xs (Fst pair loc) = + pure $ L ["car", !(toScheme xs pair)] + +toScheme xs (Snd pair loc) = + pure $ L ["cdr", !(toScheme xs pair)] + +toScheme xs (Tag tag loc) = + pure $ Q $ fromString tag + +toScheme xs (CaseEnum tag cases loc) = + Case <$> toScheme xs tag + <*> for cases (\(t, rhs) => ([fromString t],) <$> toScheme xs rhs) + +toScheme xs (Absurd loc) = + pure $ Q "absurd" + +toScheme xs (Zero loc) = + pure $ N 0 + +toScheme xs (Succ nat loc) = + case !(toScheme xs nat) of + N n => pure $ N $ S n + s => pure $ L ["+", s, N 1] + +toScheme xs (CaseNat nat zer (NSRec p ih suc) loc) = + freshInBC [< p, ih] $ \[< p, ih] => + pure $ + L ["case-nat-rec", + Lambda [] !(toScheme xs zer), + Lambda [p, ih] !(toScheme (xs :< p :< ih) suc), + !(toScheme xs nat)] + +toScheme xs (CaseNat nat zer (NSNonrec p suc) loc) = + freshInB p $ \p => + pure $ + L ["case-nat-nonrec", + Lambda [] !(toScheme xs zer), + Lambda [p] !(toScheme (xs :< p) suc), + !(toScheme xs nat)] + +toScheme xs (Let x rhs body loc) = + freshInB x $ \x => + pure $ Let x !(toScheme xs rhs) !(toScheme (xs :< x) body) + +toScheme xs (Erased loc) = + pure $ Q "erased" + + +export +prelude : String +prelude = """ +#!r6rs + +; curried lambda +(define-syntax lambda% + (syntax-rules () + [(_ (x0 x1 ...) body ...) + (lambda (x0) (lambda% (x1 ...) body ...))] + [(_ () body ...) + (begin body ...)])) + +; curried application +(define-syntax % + (syntax-rules () + [(_ e0 e1 e2 ...) + (% (e0 e1) e2 ...)] + [(_ e) e])) + +; curried function definition +(define-syntax define% + (syntax-rules () + [(_ (f x ...) body ...) + (define f (lambda% (x ...) body ...))] + [(_ x body ...) + (define x body ...)])) + +(define-syntax builtin-io + (syntax-rules () + [(_ body ...) + (lambda (s) + (let [(res (begin body ...))] + (cons res s)))])) + +(define (case-nat-rec z s n) + (let go [(acc (z)) (i 0)] + (if (= i n) acc (go (s i acc) (+ i 1))))) + +(define (case-nat-nonrec z s n) + (if (= n 0) (z) (s (- n 1)))) + +(define (run-main f) (f 'io-state) (void)) +;;;;;; +""" + +export covering +defToScheme : Name -> Definition -> Eff Scheme (Maybe Sexp) +defToScheme x ErasedDef = pure Nothing +defToScheme x (KeptDef isMain def) = do + let x = makeId x + when isMain $ modifyAt MAIN (x ::) + modifyAt AVOID $ insert x + pure $ Just $ Define x !(toScheme [<] def) +defToScheme x (SchemeDef isMain str) = do + let x = makeId x + when isMain $ modifyAt MAIN (x ::) + modifyAt AVOID $ insert x + pure $ Just $ Define x $ Literal str + orIndent : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Doc opts orIndent a b = parens $ ifMultiline (a <++> b) (a `vappend` indent 2 b) export covering prettySexp : {opts : LayoutOpts} -> Sexp -> Eff Pretty (Doc opts) + +private covering +prettyLambda : {opts : LayoutOpts} -> + String -> List Id -> Sexp -> Eff Pretty (Doc opts) +prettyLambda lam xs e = + pure $ orIndent + (hsep [!(hl Syntax $ text lam), !(prettySexp $ L $ map V xs)]) + !(prettySexp e) + +private covering +prettyBind : {opts : LayoutOpts} -> (Id, Sexp) -> Eff Pretty (Doc opts) +prettyBind (x, e) = parens $ sep [!(prettyId x), !(prettySexp e)] + +private covering +prettyLet : {opts : LayoutOpts} -> + SnocList (Id, Sexp) -> Sexp -> Eff Pretty (Doc opts) +prettyLet ps (Let x rhs body) = prettyLet (ps :< (x, rhs)) body +prettyLet ps e = + pure $ orIndent + (hsep [!(hl Syntax "let*"), + !(bracks . sep . toList =<< traverse prettyBind ps)]) + !(prettySexp e) + +private covering +prettyDefine : {opts : LayoutOpts} -> + String -> Either Id (List Id) -> Sexp -> Eff Pretty (Doc opts) +prettyDefine def xs body = + parens $ vappend + (hsep [!(hl Syntax $ text def), + !(either prettyId (prettySexp . L . map V) xs)]) + (indent 2 !(prettySexp body)) + prettySexp (V x) = prettyId x prettySexp (L []) = hl Delim "()" prettySexp (L (x :: xs)) = do d <- prettySexp x - ds <- Prelude.traverse prettySexp xs - parens $ ifMultiline (hsep $ d :: ds) (vsep $ d :: map (indent 2) ds) + ds <- traverse prettySexp xs + parens $ (hsep $ d :: ds) <|> (hsep [d, vsep ds]) <|> + (vsep $ d :: map (indent 2) ds) prettySexp (Q (V x)) = hl Tag $ "'" <+> prettyId' x prettySexp (Q x) = pure $ hcat [!(hl Tag "'"), !(prettySexp x)] prettySexp (N n) = hl Tag $ pshow n -prettySexp (Lambda xs e) = - pure $ orIndent - (hsep [!(hl Syntax "lambda"), !(prettySexp $ L $ map V xs)]) - !(prettySexp e) -prettySexp (Let ps e) = - pure $ orIndent - (hsep [!(hl Syntax "let"), !(bracks . sep =<< traverse prettyBind ps)]) - !(prettySexp e) -where - prettyBind : (Id, Sexp) -> Eff Pretty (Doc opts) - prettyBind (x, e) = pure $ sep [!(prettyId x), !(prettySexp e)] +prettySexp (Lambda xs e) = prettyLambda "lambda" xs e +prettySexp (LambdaC xs e) = prettyLambda "lambda%" xs e +prettySexp (Let x rhs e) = prettyLet [< (x, rhs)] e prettySexp (Case h as) = do header' <- prettySexp h case_ <- caseD let header = ifMultiline (case_ <++> header') (case_ `vappend` indent 2 header') - bodys <- traverse prettyCase $ toList as + arms <- traverse prettyCase $ toList as pure $ ifMultiline - (parens $ header <++> hsep bodys) - (parens $ header `vappend` indent 2 (vsep bodys)) + (parens $ header <++> hsep arms) + (parens $ vsep $ header :: map (indent 2) arms) where prettyCase : (List Sexp, Sexp) -> Eff Pretty (Doc opts) prettyCase (ps, e) = bracks $ ifMultiline (hsep [!(parens . hsep =<< traverse prettySexp ps), !(prettySexp e)]) (vsep [!(parens . sep =<< traverse prettySexp ps), !(prettySexp e)]) -prettySexp (Define x e) = - pure $ orIndent - (hsep [!(hl Syntax "define"), !(prettyId x)]) - !(prettySexp e) +prettySexp (Define x e) = case e of + LambdaC xs e => prettyDefine "define%" (Right $ x :: xs) e + Lambda xs e => prettyDefine "define" (Right $ x :: xs) e + _ => prettyDefine "define" (Left x) e +prettySexp (Literal sexp) = + pure $ text sexp + +export covering +makeRunMain : {opts : LayoutOpts} -> Id -> Eff Pretty (Doc opts) +makeRunMain x = prettySexp $ L ["run-main", V x] diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index a9b6955..2c4b1e0 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -82,7 +82,11 @@ Located (Term n) where public export -data Definition = ErasedDef | KeptDef (Term 0) +data Definition = + ErasedDef +| KeptDef Bool (Term 0) +| SchemeDef Bool String + -- bools are presence of #[main] flag public export 0 Definitions : Type @@ -94,27 +98,33 @@ letD, inD : {opts : LayoutOpts} -> Eff Pretty (Doc opts) letD = hl Syntax "let" inD = hl Syntax "in" -export +export covering prettyTerm : {opts : LayoutOpts} -> BContext n -> Term n -> Eff Pretty (Doc opts) -export +export covering prettyArg : {opts : LayoutOpts} -> BContext n -> Term n -> Eff Pretty (Doc opts) prettyArg xs arg = withPrec Arg $ prettyTerm xs arg -export -prettyApp' : {opts : LayoutOpts} -> BContext n -> Doc opts -> - Term n -> Eff Pretty (Doc opts) -prettyApp' xs fun arg = - parensIfM App =<< do - arg <- prettyArg xs arg - pure $ sep [fun, arg] +export covering +prettyAppHead : {opts : LayoutOpts} -> BContext n -> + Term n -> Eff Pretty (Doc opts) +prettyAppHead xs fun = parensIfM App =<< prettyTerm xs fun export +prettyApp' : {opts : LayoutOpts} -> + Doc opts -> SnocList (Doc opts) -> Eff Pretty (Doc opts) +prettyApp' fun args = do + d <- askAt INDENT + let args = toList args + pure $ hsep (fun :: args) + <|> hsep [fun, vsep args] + <|> vsep (fun :: map (indent d) args) + +export covering prettyApp : {opts : LayoutOpts} -> BContext n -> - Term n -> Term n -> Eff Pretty (Doc opts) -prettyApp xs fun arg = - prettyApp' xs !(withPrec App $ prettyTerm xs fun) arg + Doc opts -> SnocList (Term n) -> Eff Pretty (Doc opts) +prettyApp xs fun args = prettyApp' fun =<< traverse (prettyTerm xs) args public export record PrettyCaseArm a n where @@ -124,7 +134,7 @@ record PrettyCaseArm a n where vars : Vect len BindName rhs : Term (len + n) -export +export covering prettyCase : {opts : LayoutOpts} -> BContext n -> (a -> Eff Pretty (Doc opts)) -> Term n -> List (PrettyCaseArm a n) -> @@ -145,19 +155,24 @@ private sucPat : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts) sucPat x = pure $ !succD <++> !(prettyTBind x) -private +export +splitApp : Term b -> (Term b, SnocList (Term b)) +splitApp (App f x _) = mapSnd (:< x) $ splitApp f +splitApp f = (f, [<]) + +export splitLam : Telescope' BindName a b -> Term b -> Exists $ \c => (Telescope' BindName a c, Term c) splitLam ys (Lam x body _) = splitLam (ys :< x) body splitLam ys t = Evidence _ (ys, t) -private +export splitLet : Telescope (\i => (BindName, Term i)) a b -> Term b -> Exists $ \c => (Telescope (\i => (BindName, Term i)) a c, Term c) splitLet ys (Let x rhs body _) = splitLet (ys :< (x, rhs)) body splitLet ys t = Evidence _ (ys, t) -private +private covering prettyLets : {opts : LayoutOpts} -> BContext a -> Telescope (\i => (BindName, Term i)) a b -> Eff Pretty (SnocList (Doc opts)) @@ -168,7 +183,7 @@ prettyLets xs lets = sequence $ snd $ go lets where go (lets :< (x, rhs)) = let (ys, docs) = go lets doc = hsep <$> sequence - [letD, prettyTBind x, cstD, assert_total prettyTerm ys rhs, inD] + [letD, prettyTBind x, cstD, prettyTerm ys rhs, inD] in (ys :< x, docs :< doc) @@ -180,51 +195,71 @@ sucCaseArm (NSRec x ih s) = pure $ sucCaseArm (NSNonrec x s) = pure $ MkPrettyCaseArm !(sucPat x) [x] s +private covering +prettyNat : {opts : LayoutOpts} -> + BContext n -> Term n -> Eff Pretty (Either Nat (Doc opts)) +prettyNat xs (Zero _) = pure $ Left 0 +prettyNat xs (Succ n _) = + case !(withPrec Arg $ prettyNat xs n) of + Left n => pure $ Left $ S n + Right doc => map Right $ parensIfM App $ sep [!succD, doc] +prettyNat xs s = map Right $ prettyTerm xs s + prettyTerm _ (F x _) = prettyFree x prettyTerm xs (B i _) = prettyTBind $ xs !!! i prettyTerm xs (Lam x body _) = parensIfM Outer =<< do let Evidence n' (ys, body) = splitLam [< x] body vars <- hsep . toList' <$> traverse prettyTBind ys - body <- withPrec Outer $ assert_total prettyTerm (xs . ys) body + body <- withPrec Outer $ prettyTerm (xs . ys) body hangDSingle (hsep [!lamD, vars, !darrowD]) body -prettyTerm xs (App fun arg _) = prettyApp xs fun arg +prettyTerm xs (App fun arg _) = + let (fun, args) = splitApp fun in + prettyApp xs !(prettyAppHead xs fun) (args :< arg) prettyTerm xs (Pair fst snd _) = parens =<< separateTight !commaD <$> sequence {t = List} [prettyTerm xs fst, prettyTerm xs snd] -prettyTerm xs (Fst pair _) = prettyApp' xs !fstD pair -prettyTerm xs (Snd pair _) = prettyApp' xs !sndD pair +prettyTerm xs (Fst pair _) = prettyApp xs !fstD [< pair] +prettyTerm xs (Snd pair _) = prettyApp xs !sndD [< pair] prettyTerm xs (Tag tag _) = prettyTag tag prettyTerm xs (CaseEnum tag cases _) = - assert_total prettyCase xs prettyTag tag $ map (\(t, rhs) => MkPrettyCaseArm t [] rhs) $ toList cases prettyTerm xs (Absurd _) = hl Syntax "absurd" -prettyTerm xs (Zero _) = zeroD -prettyTerm xs (Succ nat _) = prettyApp' xs !succD nat +prettyTerm xs (Zero _) = hl Tag "0" +prettyTerm xs (Succ nat _) = + case !(prettyNat xs nat) of + Left n => hl Tag $ pshow $ S n + Right doc => prettyApp' !succD [< doc] prettyTerm xs (CaseNat nat zer suc _) = - assert_total prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)] prettyTerm xs (Let x rhs body _) = parensIfM Outer =<< do let Evidence n' (lets, body) = splitLet [< (x, rhs)] body heads <- prettyLets xs lets - body <- withPrec Outer $ assert_total prettyTerm (xs . map fst lets) body + body <- withPrec Outer $ prettyTerm (xs . map fst lets) body let lines = toList $ heads :< body pure $ ifMultiline (hsep lines) (vsep lines) prettyTerm _ (Erased _) = hl Syntax =<< ifUnicode "⌷" "[]" -export +export covering prettyDef : {opts : LayoutOpts} -> Name -> Definition -> Eff Pretty (Doc opts) prettyDef name ErasedDef = pure $ hsep [!(prettyFree name), !cstD, !(prettyTerm [<] $ Erased noLoc)] -prettyDef name (KeptDef rhs) = do - name <- prettyFree name +prettyDef name (KeptDef isMain rhs) = do + name <- prettyFree name {opts} eq <- cstD rhs <- prettyTerm [<] rhs - hangDSingle (name <++> eq) rhs + let header = if isMain then text "#[main]" <++> name else name + hangDSingle (header <++> eq) rhs +prettyDef name (SchemeDef isMain str) = do + name <- prettyFree name {opts} + eq <- cstD + let rhs = text $ "scheme:" ++ str + let header = if isMain then text "#[main]" <++> name else name + hangDSingle (header <++> eq) rhs public export diff --git a/tests/Tests/Equal.idr b/tests/Tests/Equal.idr index 19568f4..3b0f212 100644 --- a/tests/Tests/Equal.idr +++ b/tests/Tests/Equal.idr @@ -2,7 +2,7 @@ module Tests.Equal import Quox.Equal import Quox.Typechecker -import Quox.ST +import Control.Monad.ST import public TypingImpls import TAP import Quox.EffExtra diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index 47b9cab..3884ff6 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -403,36 +403,53 @@ tests = "parser" :- [ "definitions" :- [ parseMatch definition "defω x : {a} × {b} = ('a, 'b);" `(MkPDef (PQ Any _) "x" - (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) - (Pair (Tag "a" _) (Tag "b" _) _) _), + (PConcrete + (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) + (Pair (Tag "a" _) (Tag "b" _) _)) _), parseMatch definition "def# x : {a} ** {b} = ('a, 'b)" `(MkPDef (PQ Any _) "x" - (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) - (Pair (Tag "a" _) (Tag "b" _) _) _), + (PConcrete + (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) + (Pair (Tag "a" _) (Tag "b" _) _)) _), parseMatch definition "def ω.x : {a} × {b} = ('a, 'b)" `(MkPDef (PQ Any _) "x" - (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) - (Pair (Tag "a" _) (Tag "b" _) _) _), + (PConcrete + (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) + (Pair (Tag "a" _) (Tag "b" _) _)) _), parseMatch definition "def x : {a} × {b} = ('a, 'b)" `(MkPDef (PQ Any _) "x" - (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) - (Pair (Tag "a" _) (Tag "b" _) _) _), + (PConcrete + (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) + (Pair (Tag "a" _) (Tag "b" _) _)) _), parseMatch definition "def0 A : ★⁰ = {a, b, c}" - `(MkPDef (PQ Zero _) "A" (Just $ TYPE 0 _) - (Enum ["a", "b", "c"] _) _) + `(MkPDef (PQ Zero _) "A" + (PConcrete (Just $ TYPE 0 _) (Enum ["a", "b", "c"] _)) _), + parseMatch definition "postulate yeah : ℕ" + `(MkPDef (PQ Any _) "yeah" (PPostulate (Nat _)) _), + parseMatch definition "postulateω yeah : ℕ" + `(MkPDef (PQ Any _) "yeah" (PPostulate (Nat _)) _), + parseMatch definition "postulate0 FileHandle : ★" + `(MkPDef (PQ Zero _) "FileHandle" (PPostulate (TYPE 0 _)) _), + parseFails definition "postulate not-a-postulate : ℕ = 69", + parseFails definition "postulate not-a-postulate = 69", + parseFails definition "def not-a-def : ℕ" ], "top level" :- [ parseMatch input "def0 A : ★⁰ = {}; def0 B : ★¹ = A;" `([PD $ MkPDecl [] - (PDef $ MkPDef (PQ Zero _) "A" (Just $ TYPE 0 _) (Enum [] _) _) _, + (PDef $ MkPDef (PQ Zero _) "A" + (PConcrete (Just $ TYPE 0 _) (Enum [] _)) _) _, PD $ MkPDecl [] - (PDef $ MkPDef (PQ Zero _) "B" (Just $ TYPE 1 _) (V "A" {}) _) _]), + (PDef $ MkPDef (PQ Zero _) "B" + (PConcrete (Just $ TYPE 1 _) (V "A" {})) _) _]), parseMatch input "def0 A : ★⁰ = {} def0 B : ★¹ = A" $ `([PD $ MkPDecl [] - (PDef $ MkPDef (PQ Zero _) "A" (Just $ TYPE 0 _) (Enum [] _) _) _, + (PDef $ MkPDef (PQ Zero _) "A" + (PConcrete (Just $ TYPE 0 _) (Enum [] _)) _) _, PD $ MkPDecl [] - (PDef $ MkPDef (PQ Zero _) "B" (Just $ TYPE 1 _) (V "A" {}) _) _]), + (PDef $ MkPDef (PQ Zero _) "B" + (PConcrete (Just $ TYPE 1 _) (V "A" {})) _) _]), note "empty input", parsesAs input "" [], parseFails input ";;;;;;;;;;;;;;;;;;;;;;;;;;", @@ -449,21 +466,23 @@ tests = "parser" :- [ `([PD (MkPDecl [] (PNs $ MkPNamespace [< "a"] [MkPDecl [] - (PDef $ MkPDef (PQ Any _) "x" Nothing - (Ann (Tag "t" _) (Enum ["t"] _) _) _) _] _) _)]), - parseMatch input "namespace a {def x = 't ∷ {t}} def y = a.x" + (PDef $ MkPDef (PQ Any _) "x" + (PConcrete Nothing + (Ann (Tag "t" _) (Enum ["t"] _) _)) _) _] _) _)]), + parseMatch input "namespace a {def x : {t} = 't} def y = a.x" `([PD (MkPDecl [] (PNs $ MkPNamespace [< "a"] [MkPDecl [] - (PDef $ MkPDef (PQ Any _) "x" Nothing - (Ann (Tag "t" _) (Enum ["t"] _) _) _) _] _) _), + (PDef $ MkPDef (PQ Any _) "x" + (PConcrete (Just (Enum ["t"] _)) + (Tag "t" _)) _) _] _) _), PD (MkPDecl [] - (PDef $ MkPDef (PQ Any _) "y" Nothing - (V (MakePName [< "a"] "x") Nothing _) _) _)]), + (PDef $ MkPDef (PQ Any _) "y" + (PConcrete Nothing (V (MakePName [< "a"] "x") Nothing _)) _) _)]), parseMatch input #" load "a.quox"; def b = a.b "# `([PLoad "a.quox" _, PD (MkPDecl [] - (PDef $ MkPDef (PQ Any _) "b" Nothing - (V (MakePName [< "a"] "b") Nothing _) _) _)]) + (PDef $ MkPDef (PQ Any _) "b" + (PConcrete Nothing (V (MakePName [< "a"] "b") Nothing _)) _) _)]) ] ] diff --git a/tests/Tests/Reduce.idr b/tests/Tests/Reduce.idr index b63d498..a27c6f0 100644 --- a/tests/Tests/Reduce.idr +++ b/tests/Tests/Reduce.idr @@ -14,8 +14,8 @@ import Control.Eff runWhnf : Eff Whnf a -> Either Error a runWhnf act = runSTErr $ do - runEff act [handleStateSTRef !(liftST $ newSTRef 0), - handleExcept (\e => stLeft e)] + runEff act [handleExcept (\e => stLeft e), + handleStateSTRef !(liftST $ newSTRef 0)] parameters {0 isRedex : RedexTest tm} {auto _ : CanWhnf tm isRedex} {d, n : Nat} {auto _ : (Eq (tm d n), Show (tm d n))} @@ -32,7 +32,7 @@ parameters {0 isRedex : RedexTest tm} {auto _ : CanWhnf tm isRedex} {d, n : Nat} testNoStep label ctx e = testWhnf label ctx e e private -ctx : Context (\n => (BindName, Term 0 n)) n -> WhnfContext 0 n +ctx : {n : Nat} -> Context (\n => (BindName, Term 0 n)) n -> WhnfContext 0 n ctx xs = let (ns, ts) = unzip xs in MkWhnfContext [<] ns ts diff --git a/tests/Tests/Typechecker.idr b/tests/Tests/Typechecker.idr index 7e44ecd..8a85815 100644 --- a/tests/Tests/Typechecker.idr +++ b/tests/Tests/Typechecker.idr @@ -2,7 +2,7 @@ module Tests.Typechecker import Quox.Syntax import Quox.Typechecker as Lib -import Quox.ST +import Control.Monad.ST import public TypingImpls import TAP import Quox.EffExtra From 4cc50c6bcdf754bf87da2d7ce68c11dad4d3ebb9 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Wed, 1 Nov 2023 14:16:03 +0100 Subject: [PATCH 033/133] highlight errors even if real output is to a file (unless told not to) --- exe/Main.idr | 12 +++++++----- exe/Options.idr | 6 +++--- 2 files changed, 10 insertions(+), 8 deletions(-) diff --git a/exe/Main.idr b/exe/Main.idr index f8b29ae..2ee4c6d 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -30,7 +30,7 @@ die opts err = do private runPretty : Options -> Eff Pretty a -> a runPretty opts act = - let doColor = opts.color && opts.outFile == Stdout + let doColor = opts.color && opts.outFile == Console hl = if doColor then highlightSGR else noHighlight in runPrettyWith Outer opts.flavor hl 2 act @@ -133,9 +133,9 @@ private outputStr : Lazy String -> Eff Compile () outputStr str = case !(asksAt OPTS outFile) of - None => pure () - Stdout => putStr str - File f => do + None => pure () + Console => putStr str + File f => do res <- withFile f WriteTruncate pure $ \h => fPutStr h str rethrow $ mapFst (WriteError f) res @@ -221,7 +221,9 @@ main = do (_, opts, files) <- options case !(runCompile opts !newState $ traverse_ processFile files) of Right () => pure () - Left e => die (Opts opts.width) $ runPretty opts $ prettyError e + Left e => die (Opts opts.width) $ + runPretty ({outFile := Console} opts) $ + prettyError e ----------------------------------- diff --git a/exe/Options.idr b/exe/Options.idr index 8707fe3..299ce98 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -11,7 +11,7 @@ import Derive.Prelude %language ElabReflection public export -data OutFile = File String | Stdout | None +data OutFile = File String | Console | None %name OutFile f %runElab derive "OutFile" [Eq, Ord, Show] @@ -44,7 +44,7 @@ export defaultOpts : IO Options defaultOpts = pure $ MkOpts { color = True, - outFile = Stdout, + outFile = Console, until = Nothing, flavor = Unicode, width = cast !getTermCols, @@ -61,7 +61,7 @@ data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options) private toOutFile : String -> OptAction toOutFile "" = Ok {outFile := None} -toOutFile "-" = Ok {outFile := Stdout} +toOutFile "-" = Ok {outFile := Console} toOutFile f = Ok {outFile := File f} private From e0ed37720f174c1d4e99a5f39d204b1416573df6 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Wed, 1 Nov 2023 15:17:15 +0100 Subject: [PATCH 034/133] always vsep scheme lets, otherwise they are unreadable --- lib/Quox/Displace.idr | 3 + lib/Quox/Equal.idr | 182 +++++++++++++++++------------ lib/Quox/FreeVars.idr | 74 ++++++------ lib/Quox/Parser/FromParser.idr | 6 + lib/Quox/Parser/Lexer.idr | 2 + lib/Quox/Parser/Parser.idr | 3 + lib/Quox/Parser/Syntax.idr | 54 +++++---- lib/Quox/Pretty.idr | 16 ++- lib/Quox/Syntax/Term/Base.idr | 14 +++ lib/Quox/Syntax/Term/Pretty.idr | 8 ++ lib/Quox/Syntax/Term/Subst.idr | 6 + lib/Quox/Syntax/Term/Tighten.idr | 11 ++ lib/Quox/Syntax/Term/TyConKind.idr | 19 +-- lib/Quox/Typechecker.idr | 43 +++---- lib/Quox/Typing.idr | 8 ++ lib/Quox/Typing/Error.idr | 30 +++-- lib/Quox/Untyped/Erase.idr | 14 ++- lib/Quox/Untyped/Scheme.idr | 38 +++--- lib/Quox/Untyped/Syntax.idr | 7 ++ lib/Quox/Whnf/Coercion.idr | 8 ++ lib/Quox/Whnf/Interface.idr | 76 ++++++------ lib/Quox/Whnf/Main.idr | 31 ++--- lib/Quox/Whnf/TypeCase.idr | 9 +- tests/AstExtra.idr | 10 ++ tests/Tests/Equal.idr | 55 +++++---- tests/Tests/FromPTerm.idr | 2 +- tests/Tests/Parser.idr | 4 +- tests/Tests/Reduce.idr | 4 +- tests/Tests/Typechecker.idr | 38 +++--- 29 files changed, 474 insertions(+), 301 deletions(-) diff --git a/lib/Quox/Displace.idr b/lib/Quox/Displace.idr index 8b8c07c..25353a1 100644 --- a/lib/Quox/Displace.idr +++ b/lib/Quox/Displace.idr @@ -16,6 +16,7 @@ parameters (k : Universe) namespace Term doDisplace (TYPE l loc) = TYPE (k + l) loc + doDisplace (IOState loc) = IOState loc doDisplace (Pi qty arg res loc) = Pi qty (doDisplace arg) (doDisplaceS res) loc doDisplace (Lam body loc) = Lam (doDisplaceS body) loc @@ -29,6 +30,8 @@ parameters (k : Universe) doDisplace (Nat loc) = Nat loc doDisplace (Zero loc) = Zero loc doDisplace (Succ p loc) = Succ (doDisplace p) loc + doDisplace (STRING loc) = STRING loc + doDisplace (Str s loc) = Str s loc doDisplace (BOX qty ty loc) = BOX qty (doDisplace ty) loc doDisplace (Box val loc) = Box (doDisplace val) loc doDisplace (E e) = E (doDisplace e) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index bbaa6d5..29084a8 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -45,22 +45,26 @@ public export %inline sameTyCon : (s, t : Term d n) -> (0 ts : So (isTyConE s)) => (0 tt : So (isTyConE t)) => Bool -sameTyCon (TYPE {}) (TYPE {}) = True -sameTyCon (TYPE {}) _ = False -sameTyCon (Pi {}) (Pi {}) = True -sameTyCon (Pi {}) _ = False -sameTyCon (Sig {}) (Sig {}) = True -sameTyCon (Sig {}) _ = False -sameTyCon (Enum {}) (Enum {}) = True -sameTyCon (Enum {}) _ = False -sameTyCon (Eq {}) (Eq {}) = True -sameTyCon (Eq {}) _ = False -sameTyCon (Nat {}) (Nat {}) = True -sameTyCon (Nat {}) _ = False -sameTyCon (BOX {}) (BOX {}) = True -sameTyCon (BOX {}) _ = False -sameTyCon (E {}) (E {}) = True -sameTyCon (E {}) _ = False +sameTyCon (TYPE {}) (TYPE {}) = True +sameTyCon (TYPE {}) _ = False +sameTyCon (IOState {}) (IOState {}) = True +sameTyCon (IOState {}) _ = False +sameTyCon (Pi {}) (Pi {}) = True +sameTyCon (Pi {}) _ = False +sameTyCon (Sig {}) (Sig {}) = True +sameTyCon (Sig {}) _ = False +sameTyCon (Enum {}) (Enum {}) = True +sameTyCon (Enum {}) _ = False +sameTyCon (Eq {}) (Eq {}) = True +sameTyCon (Eq {}) _ = False +sameTyCon (Nat {}) (Nat {}) = True +sameTyCon (Nat {}) _ = False +sameTyCon (STRING {}) (STRING {}) = True +sameTyCon (STRING {}) _ = False +sameTyCon (BOX {}) (BOX {}) = True +sameTyCon (BOX {}) _ = False +sameTyCon (E {}) (E {}) = True +sameTyCon (E {}) _ = False ||| true if a type is known to be empty. @@ -78,6 +82,7 @@ isEmpty defs ctx sg ty0 = do | Right n => pure False case ty0 of TYPE {} => pure False + IOState {} => pure False Pi {arg, res, _} => pure False Sig {fst, snd, _} => isEmpty defs ctx sg fst `orM` @@ -86,6 +91,7 @@ isEmpty defs ctx sg ty0 = do pure $ null cases Eq {} => pure False Nat {} => pure False + STRING {} => pure False BOX {ty, _} => isEmpty defs ctx sg ty E _ => pure False @@ -108,6 +114,7 @@ isSubSing defs ctx sg ty0 = do | Right n => pure False case ty0 of TYPE {} => pure False + IOState {} => pure False Pi {arg, res, _} => isEmpty defs ctx sg arg `orM` isSubSing defs (extendTy0 res.name arg ctx) sg res.term @@ -118,6 +125,7 @@ isSubSing defs ctx sg ty0 = do pure $ length (SortedSet.toList cases) <= 1 Eq {} => pure True Nat {} => pure False + STRING {} => pure False BOX {ty, _} => isSubSing defs ctx sg ty E _ => pure False @@ -171,21 +179,32 @@ namespace Term Eff EqualInner () compare0' defs ctx sg (TYPE {}) s t = compareType defs ctx s t + compare0' defs ctx sg ty@(IOState {}) s t = + -- Γ ⊢ e = f ⇒ IOState + -- ---------------------- + -- Γ ⊢ e = f ⇐ IOState + -- + -- (no canonical values, ofc) + case (s, t) of + (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f + (E _, _) => wrongType t.loc ctx ty t + _ => wrongType s.loc ctx ty s + compare0' defs ctx sg ty@(Pi {qty, arg, res, _}) s t = local_ Equal $ -- Γ ⊢ A empty -- ------------------------------------------- - -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) : (π·x : A) → B + -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ (π·x : A) → B if !(isEmpty defs ctx sg arg) then pure () else case (s, t) of - -- Γ, x : A ⊢ s = t : B + -- Γ, x : A ⊢ s = t ⇐ B -- ------------------------------------------- - -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) : (π·x : A) → B + -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ (π·x : A) → B (Lam b1 {}, Lam b2 {}) => compare0 defs ctx' sg res.term b1.term b2.term - -- Γ, x : A ⊢ s = e x : B + -- Γ, x : A ⊢ s = e x ⇐ B -- ----------------------------------- - -- Γ ⊢ (λ x ⇒ s) = e : (π·x : A) → B + -- Γ ⊢ (λ x ⇒ s) = e ⇐ (π·x : A) → B (E e, Lam b {}) => eta s.loc e b (Lam b {}, E e) => eta s.loc e b @@ -207,9 +226,9 @@ namespace Term compare0' defs ctx sg ty@(Sig {fst, snd, _}) s t = local_ Equal $ case (s, t) of - -- Γ ⊢ s₁ = t₁ : A Γ ⊢ s₂ = t₂ : B{s₁/x} + -- Γ ⊢ s₁ = t₁ ⇐ A Γ ⊢ s₂ = t₂ ⇐ B{s₁/x} -- -------------------------------------------- - -- Γ ⊢ (s₁, t₁) = (s₂,t₂) : (x : A) × B + -- Γ ⊢ (s₁, t₁) = (s₂,t₂) ⇐ (x : A) × B -- -- [todo] η for π ≥ 0 maybe (Pair sFst sSnd {}, Pair tFst tSnd {}) => do @@ -236,7 +255,7 @@ namespace Term compare0' defs ctx sg ty@(Enum {}) s t = local_ Equal $ case (s, t) of -- -------------------- - -- Γ ⊢ `t = `t : {ts} + -- Γ ⊢ `t = `t ⇐ {ts} -- -- t ∈ ts is in the typechecker, not here, ofc (Tag t1 {}, Tag t2 {}) => @@ -254,18 +273,18 @@ namespace Term -- ✨ uip ✨ -- -- ---------------------------- - -- Γ ⊢ e = f : Eq [i ⇒ A] s t + -- Γ ⊢ e = f ⇐ Eq [i ⇒ A] s t pure () compare0' defs ctx sg nat@(Nat {}) s t = local_ Equal $ case (s, t) of -- --------------- - -- Γ ⊢ 0 = 0 : ℕ + -- Γ ⊢ 0 = 0 ⇐ ℕ (Zero {}, Zero {}) => pure () - -- Γ ⊢ s = t : ℕ + -- Γ ⊢ s = t ⇐ ℕ -- ------------------------- - -- Γ ⊢ succ s = succ t : ℕ + -- Γ ⊢ succ s = succ t ⇐ ℕ (Succ s' {}, Succ t' {}) => compare0 defs ctx sg nat s' t' (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f @@ -282,11 +301,24 @@ namespace Term (E _, t) => wrongType t.loc ctx nat t (s, _) => wrongType s.loc ctx nat s + compare0' defs ctx sg str@(STRING {}) s t = local_ Equal $ + case (s, t) of + (Str x _, Str y _) => unless (x == y) $ clashT s.loc ctx str s t + + (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f + + (Str {}, E _) => clashT s.loc ctx str s t + (E _, Str {}) => clashT s.loc ctx str s t + + (Str {}, _) => wrongType t.loc ctx str t + (E _, _) => wrongType t.loc ctx str t + _ => wrongType s.loc ctx str s + compare0' defs ctx sg bty@(BOX q ty {}) s t = local_ Equal $ case (s, t) of - -- Γ ⊢ s = t : A + -- Γ ⊢ s = t ⇐ A -- ----------------------- - -- Γ ⊢ [s] = [t] : [π.A] + -- Γ ⊢ [s] = [t] ⇐ [π.A] (Box s _, Box t _) => compare0 defs ctx sg ty s t -- Γ ⊢ s = (case1 e return A of {[x] ⇒ x}) ⇐ A @@ -329,6 +361,10 @@ compareType' defs ctx a@(TYPE k {}) (TYPE l {}) = -- Γ ⊢ Type 𝓀 <: Type ℓ expectModeU a.loc !mode k l +compareType' defs ctx a@(IOState {}) (IOState {}) = + -- Γ ⊢ IOState <: IOState + pure () + compareType' defs ctx (Pi {qty = sQty, arg = sArg, res = sRes, loc}) (Pi {qty = tQty, arg = tArg, res = tRes, _}) = do -- Γ ⊢ A₁ :> A₂ Γ, x : A₁ ⊢ B₁ <: B₂ @@ -372,6 +408,11 @@ compareType' defs ctx (Nat {}) (Nat {}) = -- Γ ⊢ ℕ <: ℕ pure () +compareType' defs ctx (STRING {}) (STRING {}) = + -- ------------ + -- Γ ⊢ String <: String + pure () + compareType' defs ctx (BOX pi a loc) (BOX rh b {}) = do expectEqualQ loc pi rh compareType defs ctx a b @@ -392,6 +433,36 @@ lookupFree defs ctx x u loc = Just d => pure $ d.typeWithAt [|Z|] ctx.termLen u +export +typecaseTel : (k : TyConKind) -> BContext (arity k) -> Universe -> + CtxExtension d n (arity k + n) +typecaseTel k xs u = case k of + KTYPE => [<] + KIOState => [<] + -- A : ★ᵤ, B : 0.A → ★ᵤ + KPi => + let [< a, b] = xs in + [< (Zero, a, TYPE u a.loc), + (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] + KSig => + let [< a, b] = xs in + [< (Zero, a, TYPE u a.loc), + (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] + KEnum => [<] + -- A₀ : ★ᵤ, A₁ : ★ᵤ, A : (A₀ ≡ A₁ : ★ᵤ), L : A₀, R : A₀ + KEq => + let [< a0, a1, a, l, r] = xs in + [< (Zero, a0, TYPE u a0.loc), + (Zero, a1, TYPE u a1.loc), + (Zero, a, Eq0 (TYPE u a.loc) (BVT 1 a.loc) (BVT 0 a.loc) a.loc), + (Zero, l, BVT 2 l.loc), + (Zero, r, BVT 2 r.loc)] + KNat => [<] + KString => [<] + -- A : ★ᵤ + KBOX => let [< a] = xs in [< (Zero, a, TYPE u a.loc)] + + namespace Elim private data InnerErr : Type where @@ -437,51 +508,12 @@ namespace Elim (def : Term 0 n) -> Eff EqualElim () compareArm {b1 = Nothing, b2 = Nothing, _} = pure () - compareArm defs ctx k ret u b1 b2 def = - let def = SN def in - compareArm_ defs ctx k ret u (fromMaybe def b1) (fromMaybe def b2) - where - compareArm_ : Definitions -> EqContext n -> (k : TyConKind) -> - (ret : Term 0 n) -> (u : Universe) -> - (b1, b2 : TypeCaseArmBody k 0 n) -> - Eff EqualElim () - compareArm_ defs ctx KTYPE ret u b1 b2 = - try $ Term.compare0 defs ctx SZero ret b1.term b2.term - - compareArm_ defs ctx KPi ret u b1 b2 = do - let [< a, b] = b1.names - ctx = extendTyN0 - [< (a, TYPE u a.loc), - (b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] ctx - try $ Term.compare0 defs ctx SZero (weakT 2 ret) b1.term b2.term - - compareArm_ defs ctx KSig ret u b1 b2 = do - let [< a, b] = b1.names - ctx = extendTyN0 - [< (a, TYPE u a.loc), - (b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] ctx - try $ Term.compare0 defs ctx SZero (weakT 2 ret) b1.term b2.term - - compareArm_ defs ctx KEnum ret u b1 b2 = - try $ Term.compare0 defs ctx SZero ret b1.term b2.term - - compareArm_ defs ctx KEq ret u b1 b2 = do - let [< a0, a1, a, l, r] = b1.names - ctx = extendTyN0 - [< (a0, TYPE u a0.loc), - (a1, TYPE u a1.loc), - (a, Eq0 (TYPE u a.loc) (BVT 1 a0.loc) (BVT 0 a1.loc) a.loc), - (l, BVT 2 a0.loc), - (r, BVT 2 a1.loc)] ctx - try $ Term.compare0 defs ctx SZero (weakT 5 ret) b1.term b2.term - - compareArm_ defs ctx KNat ret u b1 b2 = - try $ Term.compare0 defs ctx SZero ret b1.term b2.term - - compareArm_ defs ctx KBOX ret u b1 b2 = do - let ctx = extendTy0 b1.name (TYPE u b1.name.loc) ctx - try $ Term.compare0 defs ctx SZero (weakT 1 ret) b1.term b1.term - + compareArm defs ctx k ret u b1 b2 def = do + let def = SN def + left = fromMaybe def b1; right = fromMaybe def b2 + names = (fromMaybe def $ b1 <|> b2).names + try $ compare0 defs (extendTyN (typecaseTel k names u) ctx) + SZero (weakT (arity k) ret) left.term right.term private covering compare0Inner : Definitions -> EqContext n -> (sg : SQty) -> diff --git a/lib/Quox/FreeVars.idr b/lib/Quox/FreeVars.idr index ef8c42a..6b73d63 100644 --- a/lib/Quox/FreeVars.idr +++ b/lib/Quox/FreeVars.idr @@ -180,23 +180,26 @@ export HasFreeVars (Elim d) export HasFreeVars (Term d) where - fv (TYPE {}) = none - fv (Pi {arg, res, _}) = fv arg <+> fv res - fv (Lam {body, _}) = fv body - fv (Sig {fst, snd, _}) = fv fst <+> fv snd - fv (Pair {fst, snd, _}) = fv fst <+> fv snd - fv (Enum {}) = none - fv (Tag {}) = none - fv (Eq {ty, l, r, _}) = fvD ty <+> fv l <+> fv r - fv (DLam {body, _}) = fvD body - fv (Nat {}) = none - fv (Zero {}) = none - fv (Succ {p, _}) = fv p - fv (BOX {ty, _}) = fv ty - fv (Box {val, _}) = fv val - fv (E e) = fv e - fv (CloT s) = fv s - fv (DCloT s) = fv s.term + fv (TYPE {}) = none + fv (IOState {}) = none + fv (Pi {arg, res, _}) = fv arg <+> fv res + fv (Lam {body, _}) = fv body + fv (Sig {fst, snd, _}) = fv fst <+> fv snd + fv (Pair {fst, snd, _}) = fv fst <+> fv snd + fv (Enum {}) = none + fv (Tag {}) = none + fv (Eq {ty, l, r, _}) = fvD ty <+> fv l <+> fv r + fv (DLam {body, _}) = fvD body + fv (Nat {}) = none + fv (Zero {}) = none + fv (Succ {p, _}) = fv p + fv (STRING {}) = none + fv (Str {}) = none + fv (BOX {ty, _}) = fv ty + fv (Box {val, _}) = fv val + fv (E e) = fv e + fv (CloT s) = fv s + fv (DCloT s) = fv s.term export HasFreeVars (Elim d) where @@ -255,23 +258,26 @@ export HasFreeDVars Elim export HasFreeDVars Term where - fdv (TYPE {}) = none - fdv (Pi {arg, res, _}) = fdv arg <+> fdvT res - fdv (Lam {body, _}) = fdvT body - fdv (Sig {fst, snd, _}) = fdv fst <+> fdvT snd - fdv (Pair {fst, snd, _}) = fdv fst <+> fdv snd - fdv (Enum {}) = none - fdv (Tag {}) = none - fdv (Eq {ty, l, r, _}) = fdv @{DScope} ty <+> fdv l <+> fdv r - fdv (DLam {body, _}) = fdv @{DScope} body - fdv (Nat {}) = none - fdv (Zero {}) = none - fdv (Succ {p, _}) = fdv p - fdv (BOX {ty, _}) = fdv ty - fdv (Box {val, _}) = fdv val - fdv (E e) = fdv e - fdv (CloT s) = fdv s @{WithSubst} - fdv (DCloT s) = fdvSubst s + fdv (TYPE {}) = none + fdv (IOState {}) = none + fdv (Pi {arg, res, _}) = fdv arg <+> fdvT res + fdv (Lam {body, _}) = fdvT body + fdv (Sig {fst, snd, _}) = fdv fst <+> fdvT snd + fdv (Pair {fst, snd, _}) = fdv fst <+> fdv snd + fdv (Enum {}) = none + fdv (Tag {}) = none + fdv (Eq {ty, l, r, _}) = fdv @{DScope} ty <+> fdv l <+> fdv r + fdv (DLam {body, _}) = fdv @{DScope} body + fdv (Nat {}) = none + fdv (Zero {}) = none + fdv (Succ {p, _}) = fdv p + fdv (STRING {}) = none + fdv (Str {}) = none + fdv (BOX {ty, _}) = fdv ty + fdv (Box {val, _}) = fdv val + fdv (E e) = fdv e + fdv (CloT s) = fdv s @{WithSubst} + fdv (DCloT s) = fdvSubst s export HasFreeDVars Elim where diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index e2f2444..ff2f97b 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -142,6 +142,9 @@ mutual TYPE k loc => pure $ TYPE k loc + IOState loc => + pure $ IOState loc + Pi pi x s t loc => Pi (fromPQty pi) <$> fromPTermWith ds ns s @@ -189,6 +192,9 @@ mutual Zero loc => pure $ Zero loc Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|] + STRING loc => pure $ STRING loc + Str str loc => pure $ Str str loc + Case pi nat (r, ret) (CaseNat zer (s, pi', ih, suc) _) loc => map E $ CaseNat (fromPQty pi) (fromPQty pi') <$> fromPTermElim ds ns nat diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index 3db9736..8702aa2 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -222,6 +222,8 @@ reserved = Word "ω" `Or` Sym "#", Sym "★" `Or` Word "Type", Word "ℕ" `Or` Word "Nat", + Word1 "IOState", + Word1 "String", Word1 "zero", Word1 "succ", Word1 "coe", Word1 "comp", Word1 "def", diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index fb16aaf..043e691 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -292,11 +292,14 @@ export termArg : FileName -> Grammar True PTerm termArg fname = withLoc fname $ [|TYPE universe1|] + <|> IOState <$ res "IOState" <|> [|Enum enumType|] <|> [|Tag tag|] <|> const <$> boxTerm fname <|> Nat <$ res "ℕ" <|> Zero <$ res "zero" + <|> STRING <$ res "String" + <|> [|Str strLit|] <|> [|fromNat nat|] <|> [|V qname displacement|] <|> const <$> tupleTerm fname diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index 55cfc6a..1b60348 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -67,6 +67,8 @@ namespace PTerm data PTerm = TYPE Universe Loc + | IOState Loc + | Pi PQty PatVar PTerm PTerm Loc | Lam PatVar PTerm Loc | App PTerm PTerm Loc @@ -86,6 +88,9 @@ namespace PTerm | Nat Loc | Zero Loc | Succ PTerm Loc + | STRING Loc -- "String" is a reserved word in idris + | Str String Loc + | BOX PQty PTerm Loc | Box PTerm Loc @@ -109,29 +114,32 @@ namespace PTerm export Located PTerm where - (TYPE _ loc).loc = loc - (Pi _ _ _ _ loc).loc = loc - (Lam _ _ loc).loc = loc - (App _ _ loc).loc = loc - (Sig _ _ _ loc).loc = loc - (Pair _ _ loc).loc = loc - (Fst _ loc).loc = loc - (Snd _ loc).loc = loc - (Case _ _ _ _ loc).loc = loc - (Enum _ loc).loc = loc - (Tag _ loc).loc = loc - (Eq _ _ _ loc).loc = loc - (DLam _ _ loc).loc = loc - (DApp _ _ loc).loc = loc - (Nat loc).loc = loc - (Zero loc).loc = loc - (Succ _ loc).loc = loc - (BOX _ _ loc).loc = loc - (Box _ loc).loc = loc - (V _ _ loc).loc = loc - (Ann _ _ loc).loc = loc - (Coe _ _ _ _ loc).loc = loc - (Comp _ _ _ _ _ _ _ loc).loc = loc + (TYPE _ loc).loc = loc + (IOState loc).loc = loc + (Pi _ _ _ _ loc).loc = loc + (Lam _ _ loc).loc = loc + (App _ _ loc).loc = loc + (Sig _ _ _ loc).loc = loc + (Pair _ _ loc).loc = loc + (Fst _ loc).loc = loc + (Snd _ loc).loc = loc + (Case _ _ _ _ loc).loc = loc + (Enum _ loc).loc = loc + (Tag _ loc).loc = loc + (Eq _ _ _ loc).loc = loc + (DLam _ _ loc).loc = loc + (DApp _ _ loc).loc = loc + (Nat loc).loc = loc + (Zero loc).loc = loc + (Succ _ loc).loc = loc + (STRING loc).loc = loc + (Str _ loc).loc = loc + (BOX _ _ loc).loc = loc + (Box _ loc).loc = loc + (V _ _ loc).loc = loc + (Ann _ _ loc).loc = loc + (Coe _ _ _ _ loc).loc = loc + (Comp _ _ _ _ _ _ _ loc).loc = loc export Located PCaseBody where diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index 73357ee..b2ab4b9 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -248,11 +248,12 @@ prettyDBind = hl DVar . prettyBind' export %inline -typeD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD, -eqD, colonD, commaD, semiD, caseD, typecaseD, returnD, +typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD, +stringD, eqD, colonD, commaD, semiD, caseD, typecaseD, returnD, ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD : {opts : LayoutOpts} -> Eff Pretty (Doc opts) typeD = hl Syntax . text =<< ifUnicode "★" "Type" +ioStateD = hl Syntax $ text "IOState" arrowD = hl Delim . text =<< ifUnicode "→" "->" darrowD = hl Delim . text =<< ifUnicode "⇒" "=>" timesD = hl Delim . text =<< ifUnicode "×" "**" @@ -261,6 +262,7 @@ eqndD = hl Delim . text =<< ifUnicode "≡" "==" dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun" annD = hl Delim . text =<< ifUnicode "∷" "::" natD = hl Syntax . text =<< ifUnicode "ℕ" "Nat" +stringD = hl Syntax $ text "String" eqD = hl Syntax $ text "Eq" colonD = hl Delim $ text ":" commaD = hl Delim $ text "," @@ -329,3 +331,13 @@ prettyLoc (L (YesLoc file b)) = export prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts) prettyTag tag = hl Tag $ text $ "'" ++ quoteTag tag + +export +prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts) +prettyStrLit s = + let s = concatMap esc1 $ unpack s in + hl Syntax $ hcat ["\"", text s, "\""] +where + esc1 : Char -> String + esc1 '"' = "\""; esc1 '\\' = "\\" + esc1 c = singleton c diff --git a/lib/Quox/Syntax/Term/Base.idr b/lib/Quox/Syntax/Term/Base.idr index 43c97b3..810d8fe 100644 --- a/lib/Quox/Syntax/Term/Base.idr +++ b/lib/Quox/Syntax/Term/Base.idr @@ -61,6 +61,10 @@ mutual ||| type of types TYPE : (l : Universe) -> (loc : Loc) -> Term d n + ||| IO state token. this is a builtin because otherwise #[main] being a + ||| builtin makes no sense + IOState : (loc : Loc) -> Term d n + ||| function type Pi : (qty : Qty) -> (arg : Term d n) -> (res : ScopeTerm d n) -> (loc : Loc) -> Term d n @@ -88,6 +92,10 @@ mutual Zero : (loc : Loc) -> Term d n Succ : (p : Term d n) -> (loc : Loc) -> Term d n + ||| strings + STRING : (loc : Loc) -> Term d n + Str : (str : String) -> (loc : Loc) -> Term d n + ||| "box" (package a value up with a certain quantity) BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n Box : (val : Term d n) -> (loc : Loc) -> Term d n @@ -361,6 +369,7 @@ Located (Elim d n) where export Located (Term d n) where (TYPE _ loc).loc = loc + (IOState loc).loc = loc (Pi _ _ _ loc).loc = loc (Lam _ loc).loc = loc (Sig _ _ loc).loc = loc @@ -371,6 +380,8 @@ Located (Term d n) where (DLam _ loc).loc = loc (Nat loc).loc = loc (Zero loc).loc = loc + (STRING loc).loc = loc + (Str _ loc).loc = loc (Succ _ loc).loc = loc (BOX _ _ loc).loc = loc (Box _ loc).loc = loc @@ -421,6 +432,7 @@ Relocatable (Elim d n) where export Relocatable (Term d n) where setLoc loc (TYPE l _) = TYPE l loc + setLoc loc (IOState _) = IOState loc setLoc loc (Pi qty arg res _) = Pi qty arg res loc setLoc loc (Lam body _) = Lam body loc setLoc loc (Sig fst snd _) = Sig fst snd loc @@ -432,6 +444,8 @@ Relocatable (Term d n) where setLoc loc (Nat _) = Nat loc setLoc loc (Zero _) = Zero loc setLoc loc (Succ p _) = Succ p loc + setLoc loc (STRING _) = STRING loc + setLoc loc (Str s _) = Str s loc setLoc loc (BOX qty ty _) = BOX qty ty loc setLoc loc (Box val _) = Box val loc setLoc loc (E e) = E $ setLoc loc e diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index a14974c..4559235 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -343,6 +343,7 @@ prettyTyCasePat : {opts : _} -> (k : TyConKind) -> BContext (arity k) -> Eff Pretty (Doc opts) prettyTyCasePat KTYPE [<] = typeD +prettyTyCasePat KIOState [<] = ioStateD prettyTyCasePat KPi [< a, b] = parens . hsep =<< sequence [prettyTBind a, arrowD, prettyTBind b] prettyTyCasePat KSig [< a, b] = @@ -351,6 +352,7 @@ prettyTyCasePat KEnum [<] = hl Syntax $ text "{}" prettyTyCasePat KEq [< a0, a1, a, l, r] = hsep <$> sequence (eqD :: map prettyTBind [a0, a1, a, l, r]) prettyTyCasePat KNat [<] = natD +prettyTyCasePat KString [<] = stringD prettyTyCasePat KBOX [< a] = bracks =<< prettyTBind a @@ -392,6 +394,9 @@ prettyTerm dnames tnames (TYPE l _) = pure $ hcat [star, level] Ascii => [|hl Syntax "Type" <++> hl Universe (text $ show l)|] +prettyTerm dnames tnames (IOState _) = + ioStateD + prettyTerm dnames tnames (Pi qty arg res _) = parensIfM Outer =<< do let MkSplitPi {binds, cod} = splitPi [< (qty, res.name, arg)] res.term @@ -459,6 +464,9 @@ prettyTerm dnames tnames (Succ p _) = do prettyTerm dnames tnames $ assert_smaller s s' either succ (hl Syntax . text . show . S) =<< toNat p +prettyTerm dnames tnames (STRING _) = stringD +prettyTerm dnames tnames (Str s _) = prettyStrLit s + prettyTerm dnames tnames (BOX qty ty _) = bracks . hcat =<< sequence [prettyQty qty, dotD, diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index 4aa3736..584c7b0 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -254,6 +254,8 @@ mutual PushSubsts Term Subst.isCloT where pushSubstsWith th ph (TYPE l loc) = nclo $ TYPE l loc + pushSubstsWith th ph (IOState loc) = + nclo $ IOState loc pushSubstsWith th ph (Pi qty a body loc) = nclo $ Pi qty (a // th // ph) (body // th // ph) loc pushSubstsWith th ph (Lam body loc) = @@ -276,6 +278,10 @@ mutual nclo $ Zero loc pushSubstsWith th ph (Succ n loc) = nclo $ Succ (n // th // ph) loc + pushSubstsWith _ _ (STRING loc) = + nclo $ STRING loc + pushSubstsWith _ _ (Str s loc) = + nclo $ Str s loc pushSubstsWith th ph (BOX pi ty loc) = nclo $ BOX pi (ty // th // ph) loc pushSubstsWith th ph (Box val loc) = diff --git a/lib/Quox/Syntax/Term/Tighten.idr b/lib/Quox/Syntax/Term/Tighten.idr index 0f5a312..46d26c5 100644 --- a/lib/Quox/Syntax/Term/Tighten.idr +++ b/lib/Quox/Syntax/Term/Tighten.idr @@ -44,6 +44,7 @@ mutual tightenT' : OPE n1 n2 -> (t : Term d n2) -> (0 nt : NotClo t) => Maybe (Term d n1) tightenT' p (TYPE l loc) = pure $ TYPE l loc + tightenT' p (IOState loc) = pure $ IOState loc tightenT' p (Pi qty arg res loc) = Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc tightenT' p (Lam body loc) = @@ -66,6 +67,10 @@ mutual pure $ Zero loc tightenT' p (Succ s loc) = Succ <$> tightenT p s <*> pure loc + tightenT' p (STRING loc) = + pure $ STRING loc + tightenT' p (Str s loc) = + pure $ Str s loc tightenT' p (BOX qty ty loc) = BOX qty <$> tightenT p ty <*> pure loc tightenT' p (Box val loc) = @@ -163,6 +168,8 @@ mutual Maybe (Term d1 n) dtightenT' p (TYPE l loc) = pure $ TYPE l loc + dtightenT' p (IOState loc) = + pure $ IOState loc dtightenT' p (Pi qty arg res loc) = Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc dtightenT' p (Lam body loc) = @@ -185,6 +192,10 @@ mutual pure $ Zero loc dtightenT' p (Succ s loc) = Succ <$> dtightenT p s <*> pure loc + dtightenT' p (STRING loc) = + pure $ STRING loc + dtightenT' p (Str s loc) = + pure $ Str s loc dtightenT' p (BOX qty ty loc) = BOX qty <$> dtightenT p ty <*> pure loc dtightenT' p (Box val loc) = diff --git a/lib/Quox/Syntax/Term/TyConKind.idr b/lib/Quox/Syntax/Term/TyConKind.idr index 6bacf77..298173e 100644 --- a/lib/Quox/Syntax/Term/TyConKind.idr +++ b/lib/Quox/Syntax/Term/TyConKind.idr @@ -9,7 +9,8 @@ import Generics.Derive public export -data TyConKind = KTYPE | KPi | KSig | KEnum | KEq | KNat | KBOX +data TyConKind = + KTYPE | KIOState | KPi | KSig | KEnum | KEq | KNat | KString | KBOX %name TyConKind k %runElab derive "TyConKind" [Eq.Eq, Ord.Ord, Show.Show, Generic, Meta, DecEq] @@ -25,10 +26,12 @@ allKinds = %runElab do ||| in `type-case`, how many variables are bound in this branch public export %inline arity : TyConKind -> Nat -arity KTYPE = 0 -arity KPi = 2 -arity KSig = 2 -arity KEnum = 0 -arity KEq = 5 -arity KNat = 0 -arity KBOX = 1 +arity KTYPE = 0 +arity KIOState = 0 +arity KPi = 2 +arity KSig = 2 +arity KEnum = 0 +arity KEq = 5 +arity KNat = 0 +arity KString = 0 +arity KBOX = 1 diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index 563e6df..a0695f6 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -41,34 +41,6 @@ lubs ctx [] = zeroFor ctx lubs ctx (x :: xs) = lubs1 $ x ::: xs -export -typecaseTel : (k : TyConKind) -> BContext (arity k) -> Universe -> - CtxExtension d n (arity k + n) -typecaseTel k xs u = case k of - KTYPE => [<] - -- A : ★ᵤ, B : 0.A → ★ᵤ - KPi => - let [< a, b] = xs in - [< (Zero, a, TYPE u a.loc), - (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] - KSig => - let [< a, b] = xs in - [< (Zero, a, TYPE u a.loc), - (Zero, b, Arr Zero (BVT 0 b.loc) (TYPE u b.loc) b.loc)] - KEnum => [<] - -- A₀ : ★ᵤ, A₁ : ★ᵤ, A : (A₀ ≡ A₁ : ★ᵤ), L : A₀, R : A₀ - KEq => - let [< a0, a1, a, l, r] = xs in - [< (Zero, a0, TYPE u a0.loc), - (Zero, a1, TYPE u a1.loc), - (Zero, a, Eq0 (TYPE u a.loc) (BVT 1 a.loc) (BVT 0 a.loc) a.loc), - (Zero, l, BVT 2 l.loc), - (Zero, r, BVT 2 r.loc)] - KNat => [<] - -- A : ★ᵤ - KBOX => let [< a] = xs in [< (Zero, a, TYPE u a.loc)] - - mutual ||| "Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ" ||| @@ -164,6 +136,8 @@ mutual check' ctx sg t@(TYPE {}) ty = toCheckType ctx sg t ty + check' ctx sg t@(IOState {}) ty = toCheckType ctx sg t ty + check' ctx sg t@(Pi {}) ty = toCheckType ctx sg t ty check' ctx sg (Lam body loc) ty = do @@ -224,6 +198,12 @@ mutual expectNat !(askAt DEFS) ctx SZero ty.loc ty checkC ctx sg n ty + check' ctx sg t@(STRING {}) ty = toCheckType ctx sg t ty + + check' ctx sg t@(Str s {}) ty = do + expectSTRING !(askAt DEFS) ctx SZero ty.loc ty + pure $ zeroFor ctx + check' ctx sg t@(BOX {}) ty = toCheckType ctx sg t ty check' ctx sg (Box val loc) ty = do @@ -252,6 +232,9 @@ mutual Just l => unless (k < l) $ throw $ BadUniverse loc k l Nothing => pure () + checkType' ctx (IOState loc) u = pure () + -- Ψ | Γ ⊢₀ IOState ⇒ Type ℓ + checkType' ctx (Pi qty arg res _) u = do -- if Ψ | Γ ⊢₀ A ⇐ Type ℓ checkTypeC ctx arg u @@ -296,6 +279,10 @@ mutual checkType' ctx t@(Zero {}) u = throw $ NotType t.loc ctx t checkType' ctx t@(Succ {}) u = throw $ NotType t.loc ctx t + checkType' ctx (STRING loc) u = pure () + -- Ψ | Γ ⊢₀ STRING ⇒ Type ℓ + checkType' ctx t@(Str {}) u = throw $ NotType t.loc ctx t + checkType' ctx (BOX q ty _) u = checkType ctx ty u checkType' ctx t@(Box {}) u = throw $ NotType t.loc ctx t diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index cfd402d..9f96291 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -107,6 +107,10 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} expectNat : Term d n -> Eff fs () expectNat = expect ExpectedNat `(Nat {}) `(()) + export covering %inline + expectSTRING : Term d n -> Eff fs () + expectSTRING = expect ExpectedSTRING `(STRING {}) `(()) + export covering %inline expectBOX : Term d n -> Eff fs (Qty, Term d n) expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty)) @@ -154,6 +158,10 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} expectNat : Term 0 n -> Eff fs () expectNat = expect ExpectedNat `(Nat {}) `(()) + export covering %inline + expectSTRING : Term 0 n -> Eff fs () + expectSTRING = expect ExpectedSTRING `(STRING {}) `(()) + export covering %inline expectBOX : Term 0 n -> Eff fs (Qty, Term 0 n) expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty)) diff --git a/lib/Quox/Typing/Error.idr b/lib/Quox/Typing/Error.idr index 1589612..3ac54ba 100644 --- a/lib/Quox/Typing/Error.idr +++ b/lib/Quox/Typing/Error.idr @@ -62,17 +62,18 @@ namespace WhnfContext public export data Error -= ExpectedTYPE Loc (NameContexts d n) (Term d n) -| ExpectedPi Loc (NameContexts d n) (Term d n) -| ExpectedSig Loc (NameContexts d n) (Term d n) -| ExpectedEnum Loc (NameContexts d n) (Term d n) -| ExpectedEq Loc (NameContexts d n) (Term d n) -| ExpectedNat Loc (NameContexts d n) (Term d n) -| ExpectedBOX Loc (NameContexts d n) (Term d n) -| BadUniverse Loc Universe Universe -| TagNotIn Loc TagVal (SortedSet TagVal) -| BadCaseEnum Loc (SortedSet TagVal) (SortedSet TagVal) -| BadQtys Loc String (TyContext d n) (List (QOutput n, Term d n)) += ExpectedTYPE Loc (NameContexts d n) (Term d n) +| ExpectedPi Loc (NameContexts d n) (Term d n) +| ExpectedSig Loc (NameContexts d n) (Term d n) +| ExpectedEnum Loc (NameContexts d n) (Term d n) +| ExpectedEq Loc (NameContexts d n) (Term d n) +| ExpectedNat Loc (NameContexts d n) (Term d n) +| ExpectedSTRING Loc (NameContexts d n) (Term d n) +| ExpectedBOX Loc (NameContexts d n) (Term d n) +| BadUniverse Loc Universe Universe +| TagNotIn Loc TagVal (SortedSet TagVal) +| BadCaseEnum Loc (SortedSet TagVal) (SortedSet TagVal) +| BadQtys Loc String (TyContext d n) (List (QOutput n, Term d n)) -- first term arg of ClashT is the type | ClashT Loc (EqContext n) EqMode (Term 0 n) (Term 0 n) (Term 0 n) @@ -127,6 +128,7 @@ Located Error where (ExpectedEnum loc _ _).loc = loc (ExpectedEq loc _ _).loc = loc (ExpectedNat loc _ _).loc = loc + (ExpectedSTRING loc _ _).loc = loc (ExpectedBOX loc _ _).loc = loc (BadUniverse loc _ _).loc = loc (TagNotIn loc _ _).loc = loc @@ -294,6 +296,12 @@ parameters {opts : LayoutOpts} (showContext : Bool) !(prettyTerm [<] [<] $ Nat noLoc) <+> ", but got") !(prettyTerm ctx.dnames ctx.tnames s) + ExpectedSTRING _ ctx s => + hangDSingle + ("expected the type" <++> + !(prettyTerm [<] [<] $ STRING noLoc) <+> ", but got") + !(prettyTerm ctx.dnames ctx.tnames s) + ExpectedBOX _ ctx s => hangDSingle "expected a box type, but got" !(prettyTerm ctx.dnames ctx.tnames s) diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 4161ecf..98505e9 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -135,6 +135,9 @@ eraseElim : ErasureContext d n -> (tm : Q.Elim d n) -> eraseTerm ctx _ s@(TYPE {}) = throw $ CompileTimeOnly ctx s +eraseTerm ctx _ s@(IOState {}) = + throw $ CompileTimeOnly ctx s + eraseTerm ctx _ s@(Pi {}) = throw $ CompileTimeOnly ctx s @@ -197,6 +200,13 @@ eraseTerm ctx ty (Succ p loc) = do p <- eraseTerm ctx ty p pure $ Succ p loc +eraseTerm ctx ty s@(STRING {}) = + throw $ CompileTimeOnly ctx s + +-- s ⤋ s ⇐ String +eraseTerm _ _ (Str s loc) = + pure $ Str s loc + eraseTerm ctx ty s@(BOX {}) = throw $ CompileTimeOnly ctx s @@ -428,7 +438,7 @@ eraseElim ctx (DCloE (Sub term th)) = export uses : Var n -> Term n -> Nat -uses i (F x _) = 0 +uses i (F _ _) = 0 uses i (B j _) = if i == j then 1 else 0 uses i (Lam x body _) = uses (VS i) body uses i (App fun arg _) = uses i fun + uses i arg @@ -445,6 +455,7 @@ uses i (CaseNat nat zer suc _) = uses i nat + max (uses i zer) (uses' suc) where uses' : CaseNatSuc n -> Nat uses' (NSRec _ _ s) = uses (VS (VS i)) s uses' (NSNonrec _ s) = uses (VS i) s +uses i (Str _ _) = 0 uses i (Let x rhs body _) = uses i rhs + uses (VS i) body uses i (Erased _) = 0 @@ -478,6 +489,7 @@ trimLets (CaseNat nat zer suc loc) = where trimLets' : CaseNatSuc n -> CaseNatSuc n trimLets' (NSRec x ih s) = NSRec x ih $ trimLets s trimLets' (NSNonrec x s) = NSNonrec x $ trimLets s +trimLets (Str s loc) = Str s loc trimLets (Let x rhs body loc) = let rhs' = trimLets rhs body' = trimLets body in diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index db69712..d0fd2de 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -94,6 +94,7 @@ data Sexp = | L (List Sexp) | Q Sexp | N Nat +| S String | Lambda (List Id) Sexp | LambdaC (List Id) Sexp -- curried lambda | Let Id Sexp Sexp @@ -162,16 +163,16 @@ freshInBC = freshInBT export covering toScheme : Context' Id n -> Term n -> Eff Scheme Sexp -toScheme xs (F x loc) = pure $ V $ makeId x +toScheme xs (F x _) = pure $ V $ makeId x -toScheme xs (B i loc) = pure $ V $ xs !!! i +toScheme xs (B i _) = pure $ V $ xs !!! i -toScheme xs (Lam x body loc) = +toScheme xs (Lam x body _) = let Evidence n' (ys, body) = splitLam [< x] body in freshInBT ys $ \ys => do pure $ LambdaC (toList' ys) !(toScheme (xs . ys) body) -toScheme xs (App fun arg loc) = do +toScheme xs (App fun arg _) = do let (fun, args) = splitApp fun fun <- toScheme xs fun args <- traverse (toScheme xs) args @@ -180,34 +181,34 @@ toScheme xs (App fun arg loc) = do then L [fun, arg] else L $ "%" :: fun :: toList (args :< arg) -toScheme xs (Pair fst snd loc) = +toScheme xs (Pair fst snd _) = pure $ L ["cons", !(toScheme xs fst), !(toScheme xs snd)] -toScheme xs (Fst pair loc) = +toScheme xs (Fst pair _) = pure $ L ["car", !(toScheme xs pair)] -toScheme xs (Snd pair loc) = +toScheme xs (Snd pair _) = pure $ L ["cdr", !(toScheme xs pair)] -toScheme xs (Tag tag loc) = +toScheme xs (Tag tag _) = pure $ Q $ fromString tag -toScheme xs (CaseEnum tag cases loc) = +toScheme xs (CaseEnum tag cases _) = Case <$> toScheme xs tag <*> for cases (\(t, rhs) => ([fromString t],) <$> toScheme xs rhs) -toScheme xs (Absurd loc) = +toScheme xs (Absurd _) = pure $ Q "absurd" -toScheme xs (Zero loc) = +toScheme xs (Zero _) = pure $ N 0 -toScheme xs (Succ nat loc) = +toScheme xs (Succ nat _) = case !(toScheme xs nat) of N n => pure $ N $ S n s => pure $ L ["+", s, N 1] -toScheme xs (CaseNat nat zer (NSRec p ih suc) loc) = +toScheme xs (CaseNat nat zer (NSRec p ih suc) _) = freshInBC [< p, ih] $ \[< p, ih] => pure $ L ["case-nat-rec", @@ -215,7 +216,9 @@ toScheme xs (CaseNat nat zer (NSRec p ih suc) loc) = Lambda [p, ih] !(toScheme (xs :< p :< ih) suc), !(toScheme xs nat)] -toScheme xs (CaseNat nat zer (NSNonrec p suc) loc) = +toScheme xs (Str s _) = pure $ S s + +toScheme xs (CaseNat nat zer (NSNonrec p suc) _) = freshInB p $ \p => pure $ L ["case-nat-nonrec", @@ -223,11 +226,11 @@ toScheme xs (CaseNat nat zer (NSNonrec p suc) loc) = Lambda [p] !(toScheme (xs :< p) suc), !(toScheme xs nat)] -toScheme xs (Let x rhs body loc) = +toScheme xs (Let x rhs body _) = freshInB x $ \x => pure $ Let x !(toScheme xs rhs) !(toScheme (xs :< x) body) -toScheme xs (Erased loc) = +toScheme xs (Erased _) = pure $ Q "erased" @@ -317,7 +320,7 @@ prettyLet ps (Let x rhs body) = prettyLet (ps :< (x, rhs)) body prettyLet ps e = pure $ orIndent (hsep [!(hl Syntax "let*"), - !(bracks . sep . toList =<< traverse prettyBind ps)]) + !(bracks . vsep . toList =<< traverse prettyBind ps)]) !(prettySexp e) private covering @@ -339,6 +342,7 @@ prettySexp (L (x :: xs)) = do prettySexp (Q (V x)) = hl Tag $ "'" <+> prettyId' x prettySexp (Q x) = pure $ hcat [!(hl Tag "'"), !(prettySexp x)] prettySexp (N n) = hl Tag $ pshow n +prettySexp (S s) = prettyStrLit s prettySexp (Lambda xs e) = prettyLambda "lambda" xs e prettySexp (LambdaC xs e) = prettyLambda "lambda%" xs e prettySexp (Let x rhs e) = prettyLet [< (x, rhs)] e diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 2c4b1e0..0548293 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -47,6 +47,8 @@ data Term where Loc -> Term n + Str : (str : String) -> Loc -> Term n + Let : (x : BindName) -> (rhs : Term n) -> (body : Term (S n)) -> Loc -> Term n @@ -77,6 +79,7 @@ Located (Term n) where (Zero loc).loc = loc (Succ _ loc).loc = loc (CaseNat _ _ _ loc).loc = loc + (Str _ loc).loc = loc (Let _ _ _ loc).loc = loc (Erased loc).loc = loc @@ -233,6 +236,8 @@ prettyTerm xs (Succ nat _) = Right doc => prettyApp' !succD [< doc] prettyTerm xs (CaseNat nat zer suc _) = prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)] +prettyTerm xs (Str s _) = + prettyStrLit s prettyTerm xs (Let x rhs body _) = parensIfM Outer =<< do let Evidence n' (lets, body) = splitLet [< (x, rhs)] body @@ -300,6 +305,8 @@ CanSubstSelf Term where CaseNat nat zer suc loc => CaseNat (nat // th) (zer // th) (assert_total substSuc suc th) loc + Str s loc => + Str s loc Let x rhs body loc => Let x (rhs // th) (assert_total $ body // push th) loc Erased loc => diff --git a/lib/Quox/Whnf/Coercion.idr b/lib/Quox/Whnf/Coercion.idr index 7ee26cb..f70df4f 100644 --- a/lib/Quox/Whnf/Coercion.idr +++ b/lib/Quox/Whnf/Coercion.idr @@ -158,6 +158,10 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} TYPE l tyLoc => whnf defs ctx sg $ Ann s (TYPE l tyLoc) loc + -- (coe IOState @_ @_ s) ⇝ (s ∷ IOState) + IOState tyLoc => + whnf defs ctx sg $ Ann s (IOState tyLoc) loc + -- η expand it so that whnf for App can deal with it -- -- (coe (𝑖 ⇒ π.(x : A) → B) @p @q s) @@ -210,6 +214,10 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} Nat tyLoc => whnf defs ctx sg $ Ann s (Nat tyLoc) loc + -- (coe String @_ @_ s) ⇝ (s ∷ String) + STRING tyLoc => + whnf defs ctx sg $ Ann s (STRING tyLoc) loc + -- η expand -- -- (coe (𝑖 ⇒ [π. A]) @p @q s) diff --git a/lib/Quox/Whnf/Interface.idr b/lib/Quox/Whnf/Interface.idr index eebdcc9..bbd3f1b 100644 --- a/lib/Quox/Whnf/Interface.idr +++ b/lib/Quox/Whnf/Interface.idr @@ -111,23 +111,26 @@ isAnn _ = False ||| a syntactic type public export %inline isTyCon : Term {} -> Bool -isTyCon (TYPE {}) = True -isTyCon (Pi {}) = True -isTyCon (Lam {}) = False -isTyCon (Sig {}) = True -isTyCon (Pair {}) = False -isTyCon (Enum {}) = True -isTyCon (Tag {}) = False -isTyCon (Eq {}) = True -isTyCon (DLam {}) = False -isTyCon (Nat {}) = True -isTyCon (Zero {}) = False -isTyCon (Succ {}) = False -isTyCon (BOX {}) = True -isTyCon (Box {}) = False -isTyCon (E {}) = False -isTyCon (CloT {}) = False -isTyCon (DCloT {}) = False +isTyCon (TYPE {}) = True +isTyCon (IOState {}) = True +isTyCon (Pi {}) = True +isTyCon (Lam {}) = False +isTyCon (Sig {}) = True +isTyCon (Pair {}) = False +isTyCon (Enum {}) = True +isTyCon (Tag {}) = False +isTyCon (Eq {}) = True +isTyCon (DLam {}) = False +isTyCon (Nat {}) = True +isTyCon (Zero {}) = False +isTyCon (Succ {}) = False +isTyCon (STRING {}) = True +isTyCon (Str {}) = False +isTyCon (BOX {}) = True +isTyCon (Box {}) = False +isTyCon (E {}) = False +isTyCon (CloT {}) = False +isTyCon (DCloT {}) = False ||| a syntactic type, or a neutral public export %inline @@ -154,24 +157,27 @@ isK _ = False ||| - `val` is a constructor form public export %inline canPushCoe : SQty -> (ty, val : Term {}) -> Bool -canPushCoe sg (TYPE {}) _ = True -canPushCoe sg (Pi {}) _ = True -canPushCoe sg (Lam {}) _ = False -canPushCoe sg (Sig {}) (Pair {}) = True -canPushCoe sg (Sig {}) _ = False -canPushCoe sg (Pair {}) _ = False -canPushCoe sg (Enum {}) _ = True -canPushCoe sg (Tag {}) _ = False -canPushCoe sg (Eq {}) _ = True -canPushCoe sg (DLam {}) _ = False -canPushCoe sg (Nat {}) _ = True -canPushCoe sg (Zero {}) _ = False -canPushCoe sg (Succ {}) _ = False -canPushCoe sg (BOX {}) _ = True -canPushCoe sg (Box {}) _ = False -canPushCoe sg (E {}) _ = False -canPushCoe sg (CloT {}) _ = False -canPushCoe sg (DCloT {}) _ = False +canPushCoe sg (TYPE {}) _ = True +canPushCoe sg (IOState {}) _ = True +canPushCoe sg (Pi {}) _ = True +canPushCoe sg (Lam {}) _ = False +canPushCoe sg (Sig {}) (Pair {}) = True +canPushCoe sg (Sig {}) _ = False +canPushCoe sg (Pair {}) _ = False +canPushCoe sg (Enum {}) _ = True +canPushCoe sg (Tag {}) _ = False +canPushCoe sg (Eq {}) _ = True +canPushCoe sg (DLam {}) _ = False +canPushCoe sg (Nat {}) _ = True +canPushCoe sg (Zero {}) _ = False +canPushCoe sg (Succ {}) _ = False +canPushCoe sg (STRING {}) _ = True +canPushCoe sg (Str {}) _ = False +canPushCoe sg (BOX {}) _ = True +canPushCoe sg (Box {}) _ = False +canPushCoe sg (E {}) _ = False +canPushCoe sg (CloT {}) _ = False +canPushCoe sg (DCloT {}) _ = False mutual diff --git a/lib/Quox/Whnf/Main.idr b/lib/Quox/Whnf/Main.idr index 264c61a..ffb82b0 100644 --- a/lib/Quox/Whnf/Main.idr +++ b/lib/Quox/Whnf/Main.idr @@ -225,20 +225,23 @@ CanWhnf Elim Interface.isRedexE where covering CanWhnf Term Interface.isRedexT where - whnf _ _ _ t@(TYPE {}) = pure $ nred t - whnf _ _ _ t@(Pi {}) = pure $ nred t - whnf _ _ _ t@(Lam {}) = pure $ nred t - whnf _ _ _ t@(Sig {}) = pure $ nred t - whnf _ _ _ t@(Pair {}) = pure $ nred t - whnf _ _ _ t@(Enum {}) = pure $ nred t - whnf _ _ _ t@(Tag {}) = pure $ nred t - whnf _ _ _ t@(Eq {}) = pure $ nred t - whnf _ _ _ t@(DLam {}) = pure $ nred t - whnf _ _ _ t@(Nat {}) = pure $ nred t - whnf _ _ _ t@(Zero {}) = pure $ nred t - whnf _ _ _ t@(Succ {}) = pure $ nred t - whnf _ _ _ t@(BOX {}) = pure $ nred t - whnf _ _ _ t@(Box {}) = pure $ nred t + whnf _ _ _ t@(TYPE {}) = pure $ nred t + whnf _ _ _ t@(IOState {}) = pure $ nred t + whnf _ _ _ t@(Pi {}) = pure $ nred t + whnf _ _ _ t@(Lam {}) = pure $ nred t + whnf _ _ _ t@(Sig {}) = pure $ nred t + whnf _ _ _ t@(Pair {}) = pure $ nred t + whnf _ _ _ t@(Enum {}) = pure $ nred t + whnf _ _ _ t@(Tag {}) = pure $ nred t + whnf _ _ _ t@(Eq {}) = pure $ nred t + whnf _ _ _ t@(DLam {}) = pure $ nred t + whnf _ _ _ t@(Nat {}) = pure $ nred t + whnf _ _ _ t@(Zero {}) = pure $ nred t + whnf _ _ _ t@(Succ {}) = pure $ nred t + whnf _ _ _ t@(STRING {}) = pure $ nred t + whnf _ _ _ t@(Str {}) = pure $ nred t + whnf _ _ _ t@(BOX {}) = pure $ nred t + whnf _ _ _ t@(Box {}) = pure $ nred t -- s ∷ A ⇝ s (in term context) whnf defs ctx sg (E e) = do diff --git a/lib/Quox/Whnf/TypeCase.idr b/lib/Quox/Whnf/TypeCase.idr index 0c1f5e1..569a88d 100644 --- a/lib/Quox/Whnf/TypeCase.idr +++ b/lib/Quox/Whnf/TypeCase.idr @@ -99,7 +99,6 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} pure (a0, a1, a, l, r) tycaseEq t = throw $ ExpectedEq t.loc ctx.names t - ||| reduce a type-case applied to a type constructor ||| ||| `reduceTypeCase A i Q arms def _` reduces an expression @@ -114,6 +113,10 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} TYPE {} => whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KTYPE arms) ret loc + -- (type-case IOState ∷ _ return Q of { IOState ⇒ s; ⋯ }) ⇝ s ∷ Q + IOState {} => + whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KIOState arms) ret loc + -- (type-case π.(x : A) → B ∷ ★ᵢ return Q of { (a → b) ⇒ s; ⋯ }) ⇝ -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q Pi {arg, res, loc = piLoc, _} => @@ -156,6 +159,10 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} Nat {} => whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KNat arms) ret loc + -- (type-case String ∷ _ return Q of { String ⇒ s; ⋯ }) ⇝ s ∷ Q + STRING {} => + whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KString arms) ret loc + -- (type-case [π.A] ∷ ★ᵢ return Q of { [a] ⇒ s; ⋯ }) ⇝ s[(A ∷ ★ᵢ)/a] ∷ Q BOX {ty = a, loc = boxLoc, _} => whnf defs ctx SZero $ Ann diff --git a/tests/AstExtra.idr b/tests/AstExtra.idr index 2528d9a..f9cc1fd 100644 --- a/tests/AstExtra.idr +++ b/tests/AstExtra.idr @@ -31,3 +31,13 @@ ctx tel = let (ns, ts) = unzip tel in MkTyContext new [<] ts ns anys ctx01 tel = let (ns, ts) = unzip tel in MkTyContext ZeroIsOne [<] ts ns anys + +export +mkDef : GQty -> Term 0 0 -> Term 0 0 -> Definition +mkDef q ty tm = Definition.mkDef q ty tm Nothing False noLoc +%hide Definition.mkDef + +export +mkPostulate : GQty -> Term 0 0 -> Definition +mkPostulate q ty = Definition.mkPostulate q ty Nothing False noLoc +%hide Definition.mkPostulate diff --git a/tests/Tests/Equal.idr b/tests/Tests/Equal.idr index 3b0f212..818e7c2 100644 --- a/tests/Tests/Equal.idr +++ b/tests/Tests/Equal.idr @@ -9,18 +9,17 @@ import Quox.EffExtra import AstExtra - defGlobals : Definitions defGlobals = fromList - [("A", ^mkPostulate GZero (^TYPE 0)), - ("B", ^mkPostulate GZero (^TYPE 0)), - ("a", ^mkPostulate GAny (^FT "A" 0)), - ("a'", ^mkPostulate GAny (^FT "A" 0)), - ("b", ^mkPostulate GAny (^FT "B" 0)), - ("f", ^mkPostulate GAny (^Arr One (^FT "A" 0) (^FT "A" 0))), - ("id", ^mkDef GAny (^Arr One (^FT "A" 0) (^FT "A" 0)) (^LamY "x" (^BVT 0))), - ("eq-AB", ^mkPostulate GZero (^Eq0 (^TYPE 0) (^FT "A" 0) (^FT "B" 0))), - ("two", ^mkDef GAny (^Nat) (^Succ (^Succ (^Zero))))] + [("A", mkPostulate GZero (^TYPE 0)), + ("B", mkPostulate GZero (^TYPE 0)), + ("a", mkPostulate GAny (^FT "A" 0)), + ("a'", mkPostulate GAny (^FT "A" 0)), + ("b", mkPostulate GAny (^FT "B" 0)), + ("f", mkPostulate GAny (^Arr One (^FT "A" 0) (^FT "A" 0))), + ("id", mkDef GAny (^Arr One (^FT "A" 0) (^FT "A" 0)) (^LamY "x" (^BVT 0))), + ("eq-AB", mkPostulate GZero (^Eq0 (^TYPE 0) (^FT "A" 0) (^FT "B" 0))), + ("two", mkDef GAny (^Nat) (^Succ (^Succ (^Zero))))] parameters (label : String) (act : Eff Equal ()) {default defGlobals globals : Definitions} @@ -156,7 +155,7 @@ tests = "equality & subtyping" :- [ let tm = ^Eq0 (^TYPE 1) (^TYPE 0) (^TYPE 0) in equalT empty (^TYPE 2) tm tm, testEq "A ≔ ★₁ ⊢ (★₀ ≡ ★₀ : ★₁) = (★₀ ≡ ★₀ : A)" - {globals = fromList [("A", ^mkDef GZero (^TYPE 2) (^TYPE 1))]} $ + {globals = fromList [("A", mkDef GZero (^TYPE 2) (^TYPE 1))]} $ equalT empty (^TYPE 2) (^Eq0 (^TYPE 1) (^TYPE 0) (^TYPE 0)) (^Eq0 (^FT "A" 0) (^TYPE 0) (^TYPE 0)), @@ -176,7 +175,7 @@ tests = "equality & subtyping" :- [ testEq "p : (a ≡ a' : A), q : (a ≡ a' : A) ∥ ⊢ p = q (free)" {globals = - let def = ^mkPostulate GZero + let def = mkPostulate GZero (^Eq0 (^FT "A" 0) (^FT "a" 0) (^FT "a'" 0)) in defGlobals `mergeLeft` fromList [("p", def), ("q", def)]} $ equalE empty (^F "p" 0) (^F "q" 0), @@ -195,32 +194,32 @@ tests = "equality & subtyping" :- [ testEq "E ≔ a ≡ a' : A, EE ≔ E ∥ x : EE, y : EE ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", ^mkDef GZero (^TYPE 0) + [("E", mkDef GZero (^TYPE 0) (^Eq0 (^FT "A" 0) (^FT "a" 0) (^FT "a'" 0))), - ("EE", ^mkDef GZero (^TYPE 0) (^FT "E" 0))]} $ + ("EE", mkDef GZero (^TYPE 0) (^FT "E" 0))]} $ equalE (extendTyN [< (Any, "x", ^FT "EE" 0), (Any, "y", ^FT "EE" 0)] empty) (^BV 0) (^BV 1), testEq "E ≔ a ≡ a' : A, EE ≔ E ∥ x : EE, y : E ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", ^mkDef GZero (^TYPE 0) + [("E", mkDef GZero (^TYPE 0) (^Eq0 (^FT "A" 0) (^FT "a" 0) (^FT "a'" 0))), - ("EE", ^mkDef GZero (^TYPE 0) (^FT "E" 0))]} $ + ("EE", mkDef GZero (^TYPE 0) (^FT "E" 0))]} $ equalE (extendTyN [< (Any, "x", ^FT "EE" 0), (Any, "y", ^FT "E" 0)] empty) (^BV 0) (^BV 1), testEq "E ≔ a ≡ a' : A ∥ x : E, y : E ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", ^mkDef GZero (^TYPE 0) + [("E", mkDef GZero (^TYPE 0) (^Eq0 (^FT "A" 0) (^FT "a" 0) (^FT "a'" 0)))]} $ equalE (extendTyN [< (Any, "x", ^FT "E" 0), (Any, "y", ^FT "E" 0)] empty) (^BV 0) (^BV 1), testEq "E ≔ a ≡ a' : A ∥ x : (E×E), y : (E×E) ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", ^mkDef GZero (^TYPE 0) + [("E", mkDef GZero (^TYPE 0) (^Eq0 (^FT "A" 0) (^FT "a" 0) (^FT "a'" 0)))]} $ let ty : forall n. Term 0 n := ^Sig (^FT "E" 0) (SN $ ^FT "E" 0) in equalE (extendTyN [< (Any, "x", ty), (Any, "y", ty)] empty) @@ -228,9 +227,9 @@ tests = "equality & subtyping" :- [ testEq "E ≔ a ≡ a' : A, W ≔ E × E ∥ x : W, y : E×E ⊢ x = y" {globals = defGlobals `mergeLeft` fromList - [("E", ^mkDef GZero (^TYPE 0) + [("E", mkDef GZero (^TYPE 0) (^Eq0 (^FT "A" 0) (^FT "a" 0) (^FT "a'" 0))), - ("W", ^mkDef GZero (^TYPE 0) (^And (^FT "E" 0) (^FT "E" 0)))]} $ + ("W", mkDef GZero (^TYPE 0) (^And (^FT "E" 0) (^FT "E" 0)))]} $ equalE (extendTyN [< (Any, "x", ^FT "W" 0), (Any, "y", ^And (^FT "E" 0) (^FT "E" 0))] empty) @@ -280,11 +279,11 @@ tests = "equality & subtyping" :- [ "free var" :- let au_bu = fromList - [("A", ^mkDef GAny (^TYPE 1) (^TYPE 0)), - ("B", ^mkDef GAny (^TYPE 1) (^TYPE 0))] + [("A", mkDef GAny (^TYPE 1) (^TYPE 0)), + ("B", mkDef GAny (^TYPE 1) (^TYPE 0))] au_ba = fromList - [("A", ^mkDef GAny (^TYPE 1) (^TYPE 0)), - ("B", ^mkDef GAny (^TYPE 1) (^FT "A" 0))] + [("A", mkDef GAny (^TYPE 1) (^TYPE 0)), + ("B", mkDef GAny (^TYPE 1) (^FT "A" 0))] in [ testEq "A = A" $ equalE empty (^F "A" 0) (^F "A" 0), @@ -305,13 +304,13 @@ tests = "equality & subtyping" :- [ testNeq "A ≮: B" $ subE empty (^F "A" 0) (^F "B" 0), testEq "A : ★₃ ≔ ★₀, B : ★₃ ≔ ★₂ ⊢ A <: B" - {globals = fromList [("A", ^mkDef GAny (^TYPE 3) (^TYPE 0)), - ("B", ^mkDef GAny (^TYPE 3) (^TYPE 2))]} $ + {globals = fromList [("A", mkDef GAny (^TYPE 3) (^TYPE 0)), + ("B", mkDef GAny (^TYPE 3) (^TYPE 2))]} $ subE empty (^F "A" 0) (^F "B" 0), note "(A and B in different universes)", testEq "A : ★₁ ≔ ★₀, B : ★₃ ≔ ★₂ ⊢ A <: B" - {globals = fromList [("A", ^mkDef GAny (^TYPE 1) (^TYPE 0)), - ("B", ^mkDef GAny (^TYPE 3) (^TYPE 2))]} $ + {globals = fromList [("A", mkDef GAny (^TYPE 1) (^TYPE 0)), + ("B", mkDef GAny (^TYPE 3) (^TYPE 2))]} $ subE empty (^F "A" 0) (^F "B" 0), testEq "0=1 ⊢ A <: B" $ subE empty01 (^F "A" 0) (^F "B" 0) diff --git a/tests/Tests/FromPTerm.idr b/tests/Tests/FromPTerm.idr index bf8a947..b3451a9 100644 --- a/tests/Tests/FromPTerm.idr +++ b/tests/Tests/FromPTerm.idr @@ -85,7 +85,7 @@ tests = "PTerm → Term" :- [ ], "terms" :- - let defs = fromList [("f", mkDef GAny (Nat noLoc) (Zero noLoc) noLoc)] + let defs = fromList [("f", mkDef GAny (^Nat) (^Zero))] -- doesn't have to be well typed yet, just well scoped fromPTerm = runFromParser {defs} . fromPTermWith [< "𝑖", "𝑗"] [< "A", "x", "y", "z"] diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index 3884ff6..122be48 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -64,8 +64,8 @@ tests = "parser" :- [ "names" :- [ parsesAs (const qname) "x" (MakePName [<] "x"), - parsesAs (const qname) "Data.String.length" - (MakePName [< "Data", "String"] "length"), + parsesAs (const qname) "Data.List.length" + (MakePName [< "Data", "List"] "length"), parseFails (const qname) "_" ], diff --git a/tests/Tests/Reduce.idr b/tests/Tests/Reduce.idr index a27c6f0..7e81a7a 100644 --- a/tests/Tests/Reduce.idr +++ b/tests/Tests/Reduce.idr @@ -73,10 +73,10 @@ tests = "whnf" :- [ "definitions" :- [ testWhnf "a (transparent)" empty - {defs = fromList [("a", ^mkDef GZero (^TYPE 1) (^TYPE 0))]} + {defs = fromList [("a", ^mkDef GZero (^TYPE 1) (^TYPE 0) Nothing False)]} (^F "a" 0) (^Ann (^TYPE 0) (^TYPE 1)), testNoStep "a (opaque)" empty - {defs = fromList [("a", ^mkPostulate GZero (^TYPE 1))]} + {defs = fromList [("a", ^mkPostulate GZero (^TYPE 1) Nothing False)]} (^F "a" 0) ], diff --git a/tests/Tests/Typechecker.idr b/tests/Tests/Typechecker.idr index 8a85815..1418643 100644 --- a/tests/Tests/Typechecker.idr +++ b/tests/Tests/Typechecker.idr @@ -87,28 +87,28 @@ apps = foldl (\f, s => ^App f s) defGlobals : Definitions defGlobals = fromList - [("A", ^mkPostulate GZero (^TYPE 0)), - ("B", ^mkPostulate GZero (^TYPE 0)), - ("C", ^mkPostulate GZero (^TYPE 1)), - ("D", ^mkPostulate GZero (^TYPE 1)), - ("P", ^mkPostulate GZero (^Arr Any (^FT "A" 0) (^TYPE 0))), - ("a", ^mkPostulate GAny (^FT "A" 0)), - ("a'", ^mkPostulate GAny (^FT "A" 0)), - ("b", ^mkPostulate GAny (^FT "B" 0)), - ("c", ^mkPostulate GAny (^FT "C" 0)), - ("d", ^mkPostulate GAny (^FT "D" 0)), - ("f", ^mkPostulate GAny (^Arr One (^FT "A" 0) (^FT "A" 0))), - ("fω", ^mkPostulate GAny (^Arr Any (^FT "A" 0) (^FT "A" 0))), - ("g", ^mkPostulate GAny (^Arr One (^FT "A" 0) (^FT "B" 0))), - ("f2", ^mkPostulate GAny + [("A", mkPostulate GZero (^TYPE 0)), + ("B", mkPostulate GZero (^TYPE 0)), + ("C", mkPostulate GZero (^TYPE 1)), + ("D", mkPostulate GZero (^TYPE 1)), + ("P", mkPostulate GZero (^Arr Any (^FT "A" 0) (^TYPE 0))), + ("a", mkPostulate GAny (^FT "A" 0)), + ("a'", mkPostulate GAny (^FT "A" 0)), + ("b", mkPostulate GAny (^FT "B" 0)), + ("c", mkPostulate GAny (^FT "C" 0)), + ("d", mkPostulate GAny (^FT "D" 0)), + ("f", mkPostulate GAny (^Arr One (^FT "A" 0) (^FT "A" 0))), + ("fω", mkPostulate GAny (^Arr Any (^FT "A" 0) (^FT "A" 0))), + ("g", mkPostulate GAny (^Arr One (^FT "A" 0) (^FT "B" 0))), + ("f2", mkPostulate GAny (^Arr One (^FT "A" 0) (^Arr One (^FT "A" 0) (^FT "B" 0)))), - ("p", ^mkPostulate GAny + ("p", mkPostulate GAny (^PiY One "x" (^FT "A" 0) (E $ ^App (^F "P" 0) (^BVT 0)))), - ("q", ^mkPostulate GAny + ("q", mkPostulate GAny (^PiY One "x" (^FT "A" 0) (E $ ^App (^F "P" 0) (^BVT 0)))), - ("refl", ^mkDef GAny reflTy reflDef), - ("fst", ^mkDef GAny fstTy fstDef), - ("snd", ^mkDef GAny sndTy sndDef)] + ("refl", mkDef GAny reflTy reflDef), + ("fst", mkDef GAny fstTy fstDef), + ("snd", mkDef GAny sndTy sndDef)] parameters (label : String) (act : Lazy (Eff Test ())) {default defGlobals globals : Definitions} From fa7f82ae5a9f61af0302ee3c6c3e64ed786960ff Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 2 Nov 2023 18:14:22 +0100 Subject: [PATCH 035/133] rename Nat to NAT in AST --- lib/Quox/Displace.idr | 2 +- lib/Quox/Equal.idr | 16 +++++++-------- lib/Quox/FreeVars.idr | 4 ++-- lib/Quox/Parser/FromParser.idr | 2 +- lib/Quox/Parser/Parser.idr | 2 +- lib/Quox/Parser/Syntax.idr | 4 ++-- lib/Quox/Syntax/Term/Base.idr | 8 ++++---- lib/Quox/Syntax/Term/Pretty.idr | 2 +- lib/Quox/Syntax/Term/Subst.idr | 4 ++-- lib/Quox/Syntax/Term/Tighten.idr | 10 +++++----- lib/Quox/Typechecker.idr | 12 +++++------ lib/Quox/Typing.idr | 10 +++++----- lib/Quox/Typing/Error.idr | 8 ++++---- lib/Quox/Untyped/Erase.idr | 8 ++++---- lib/Quox/Whnf/Coercion.idr | 4 ++-- lib/Quox/Whnf/Interface.idr | 8 ++++---- lib/Quox/Whnf/Main.idr | 8 ++++---- lib/Quox/Whnf/TypeCase.idr | 2 +- tests/Tests/Equal.idr | 34 ++++++++++++++++---------------- tests/Tests/FromPTerm.idr | 2 +- tests/Tests/Parser.idr | 18 ++++++++--------- tests/Tests/PrettyTerm.idr | 2 +- tests/Tests/Reduce.idr | 12 +++++------ tests/Tests/Typechecker.idr | 2 +- 24 files changed, 92 insertions(+), 92 deletions(-) diff --git a/lib/Quox/Displace.idr b/lib/Quox/Displace.idr index 25353a1..14a3ce5 100644 --- a/lib/Quox/Displace.idr +++ b/lib/Quox/Displace.idr @@ -27,7 +27,7 @@ parameters (k : Universe) doDisplace (Eq ty l r loc) = Eq (doDisplaceDS ty) (doDisplace l) (doDisplace r) loc doDisplace (DLam body loc) = DLam (doDisplaceDS body) loc - doDisplace (Nat loc) = Nat loc + doDisplace (NAT loc) = NAT loc doDisplace (Zero loc) = Zero loc doDisplace (Succ p loc) = Succ (doDisplace p) loc doDisplace (STRING loc) = STRING loc diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 29084a8..33892c1 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -57,8 +57,8 @@ sameTyCon (Enum {}) (Enum {}) = True sameTyCon (Enum {}) _ = False sameTyCon (Eq {}) (Eq {}) = True sameTyCon (Eq {}) _ = False -sameTyCon (Nat {}) (Nat {}) = True -sameTyCon (Nat {}) _ = False +sameTyCon (NAT {}) (NAT {}) = True +sameTyCon (NAT {}) _ = False sameTyCon (STRING {}) (STRING {}) = True sameTyCon (STRING {}) _ = False sameTyCon (BOX {}) (BOX {}) = True @@ -90,7 +90,7 @@ isEmpty defs ctx sg ty0 = do Enum {cases, _} => pure $ null cases Eq {} => pure False - Nat {} => pure False + NAT {} => pure False STRING {} => pure False BOX {ty, _} => isEmpty defs ctx sg ty E _ => pure False @@ -124,7 +124,7 @@ isSubSing defs ctx sg ty0 = do Enum {cases, _} => pure $ length (SortedSet.toList cases) <= 1 Eq {} => pure True - Nat {} => pure False + NAT {} => pure False STRING {} => pure False BOX {ty, _} => isSubSing defs ctx sg ty E _ => pure False @@ -276,7 +276,7 @@ namespace Term -- Γ ⊢ e = f ⇐ Eq [i ⇒ A] s t pure () - compare0' defs ctx sg nat@(Nat {}) s t = local_ Equal $ + compare0' defs ctx sg nat@(NAT {}) s t = local_ Equal $ case (s, t) of -- --------------- -- Γ ⊢ 0 = 0 ⇐ ℕ @@ -403,7 +403,7 @@ compareType' defs ctx s@(Enum tags1 {}) t@(Enum tags2 {}) = do -- a runtime coercion unless (tags1 == tags2) $ clashTy s.loc ctx s t -compareType' defs ctx (Nat {}) (Nat {}) = +compareType' defs ctx (NAT {}) (NAT {}) = -- ------------ -- Γ ⊢ ℕ <: ℕ pure () @@ -626,10 +626,10 @@ namespace Elim try $ do compareType defs (extendTy0 eret.name ety ctx) eret.term fret.term Term.compare0 defs ctx sg - (sub1 eret (Ann (Zero ezer.loc) (Nat ezer.loc) ezer.loc)) + (sub1 eret (Ann (Zero ezer.loc) (NAT ezer.loc) ezer.loc)) ezer fzer Term.compare0 defs - (extendTyN [< (epi, p, Nat p.loc), (epi', ih, eret.term)] ctx) sg + (extendTyN [< (epi, p, NAT p.loc), (epi', ih, eret.term)] ctx) sg (substCaseSuccRet esuc.names eret) esuc.term fsuc.term expectEqualQ e.loc epi fpi expectEqualQ e.loc epi' fpi' diff --git a/lib/Quox/FreeVars.idr b/lib/Quox/FreeVars.idr index 6b73d63..929eb71 100644 --- a/lib/Quox/FreeVars.idr +++ b/lib/Quox/FreeVars.idr @@ -190,7 +190,7 @@ HasFreeVars (Term d) where fv (Tag {}) = none fv (Eq {ty, l, r, _}) = fvD ty <+> fv l <+> fv r fv (DLam {body, _}) = fvD body - fv (Nat {}) = none + fv (NAT {}) = none fv (Zero {}) = none fv (Succ {p, _}) = fv p fv (STRING {}) = none @@ -268,7 +268,7 @@ HasFreeDVars Term where fdv (Tag {}) = none fdv (Eq {ty, l, r, _}) = fdv @{DScope} ty <+> fdv l <+> fdv r fdv (DLam {body, _}) = fdv @{DScope} body - fdv (Nat {}) = none + fdv (NAT {}) = none fdv (Zero {}) = none fdv (Succ {p, _}) = fdv p fdv (STRING {}) = none diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index ff2f97b..0979915 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -188,7 +188,7 @@ mutual <*> assert_total fromPTermEnumArms loc ds ns arms <*> pure loc - Nat loc => pure $ Nat loc + NAT loc => pure $ NAT loc Zero loc => pure $ Zero loc Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|] diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index 043e691..b687cba 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -296,7 +296,7 @@ termArg fname = withLoc fname $ <|> [|Enum enumType|] <|> [|Tag tag|] <|> const <$> boxTerm fname - <|> Nat <$ res "ℕ" + <|> NAT <$ res "ℕ" <|> Zero <$ res "zero" <|> STRING <$ res "String" <|> [|Str strLit|] diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index 1b60348..d6c13a6 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -85,7 +85,7 @@ namespace PTerm | DLam PatVar PTerm Loc | DApp PTerm PDim Loc - | Nat Loc + | NAT Loc | Zero Loc | Succ PTerm Loc | STRING Loc -- "String" is a reserved word in idris @@ -129,7 +129,7 @@ Located PTerm where (Eq _ _ _ loc).loc = loc (DLam _ _ loc).loc = loc (DApp _ _ loc).loc = loc - (Nat loc).loc = loc + (NAT loc).loc = loc (Zero loc).loc = loc (Succ _ loc).loc = loc (STRING loc).loc = loc diff --git a/lib/Quox/Syntax/Term/Base.idr b/lib/Quox/Syntax/Term/Base.idr index 810d8fe..8ec1838 100644 --- a/lib/Quox/Syntax/Term/Base.idr +++ b/lib/Quox/Syntax/Term/Base.idr @@ -87,7 +87,7 @@ mutual DLam : (body : DScopeTerm d n) -> (loc : Loc) -> Term d n ||| natural numbers (temporary until 𝐖 gets added) - Nat : (loc : Loc) -> Term d n + NAT : (loc : Loc) -> Term d n -- [todo] can these be elims? Zero : (loc : Loc) -> Term d n Succ : (p : Term d n) -> (loc : Loc) -> Term d n @@ -342,7 +342,7 @@ public export %inline typeCase1Y : Elim d n -> Term d n -> (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) -> (loc : Loc) -> - {default (Nat loc) def : Term d n} -> + {default (NAT loc) def : Term d n} -> Elim d n typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc @@ -378,7 +378,7 @@ Located (Term d n) where (Tag _ loc).loc = loc (Eq _ _ _ loc).loc = loc (DLam _ loc).loc = loc - (Nat loc).loc = loc + (NAT loc).loc = loc (Zero loc).loc = loc (STRING loc).loc = loc (Str _ loc).loc = loc @@ -441,7 +441,7 @@ Relocatable (Term d n) where setLoc loc (Tag tag _) = Tag tag loc setLoc loc (Eq ty l r _) = Eq ty l r loc setLoc loc (DLam body _) = DLam body loc - setLoc loc (Nat _) = Nat loc + setLoc loc (NAT _) = NAT loc setLoc loc (Zero _) = Zero loc setLoc loc (Succ p _) = Succ p loc setLoc loc (STRING _) = STRING loc diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index 4559235..ecb5821 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -449,7 +449,7 @@ prettyTerm dnames tnames (Eq ty l r _) = prettyTerm dnames tnames s@(DLam {}) = prettyLambda dnames tnames s -prettyTerm dnames tnames (Nat _) = natD +prettyTerm dnames tnames (NAT _) = natD prettyTerm dnames tnames (Zero _) = hl Syntax "0" prettyTerm dnames tnames (Succ p _) = do succD <- succD diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index 584c7b0..8610b78 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -272,8 +272,8 @@ mutual nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc pushSubstsWith th ph (DLam body loc) = nclo $ DLam (body // th // ph) loc - pushSubstsWith _ _ (Nat loc) = - nclo $ Nat loc + pushSubstsWith _ _ (NAT loc) = + nclo $ NAT loc pushSubstsWith _ _ (Zero loc) = nclo $ Zero loc pushSubstsWith th ph (Succ n loc) = diff --git a/lib/Quox/Syntax/Term/Tighten.idr b/lib/Quox/Syntax/Term/Tighten.idr index 46d26c5..83ea7e0 100644 --- a/lib/Quox/Syntax/Term/Tighten.idr +++ b/lib/Quox/Syntax/Term/Tighten.idr @@ -61,8 +61,8 @@ mutual Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc tightenT' p (DLam body loc) = DLam <$> tightenDS p body <*> pure loc - tightenT' p (Nat loc) = - pure $ Nat loc + tightenT' p (NAT loc) = + pure $ NAT loc tightenT' p (Zero loc) = pure $ Zero loc tightenT' p (Succ s loc) = @@ -186,8 +186,8 @@ mutual Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc dtightenT' p (DLam body loc) = DLam <$> dtightenDS p body <*> pure loc - dtightenT' p (Nat loc) = - pure $ Nat loc + dtightenT' p (NAT loc) = + pure $ NAT loc dtightenT' p (Zero loc) = pure $ Zero loc dtightenT' p (Succ s loc) = @@ -331,7 +331,7 @@ public export %inline typeCase1T : Elim d n -> Term d n -> (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) -> (loc : Loc) -> - {default (Nat loc) def : Term d n} -> + {default (NAT loc) def : Term d n} -> Elim d n typeCase1T ty ret k ns body loc {def} = typeCase ty ret [(k ** ST ns body)] def loc diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index a0695f6..2273a08 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -188,14 +188,14 @@ mutual -- then Ψ | Γ ⊢ σ · (δ i ⇒ t) ⇐ Eq [i ⇒ A] l r ⊳ Σ pure qout - check' ctx sg t@(Nat {}) ty = toCheckType ctx sg t ty + check' ctx sg t@(NAT {}) ty = toCheckType ctx sg t ty check' ctx sg (Zero {}) ty = do - expectNat !(askAt DEFS) ctx SZero ty.loc ty + expectNAT !(askAt DEFS) ctx SZero ty.loc ty pure $ zeroFor ctx check' ctx sg (Succ n {}) ty = do - expectNat !(askAt DEFS) ctx SZero ty.loc ty + expectNAT !(askAt DEFS) ctx SZero ty.loc ty checkC ctx sg n ty check' ctx sg t@(STRING {}) ty = toCheckType ctx sg t ty @@ -275,7 +275,7 @@ mutual checkType' ctx t@(DLam {}) u = throw $ NotType t.loc ctx t - checkType' ctx (Nat {}) u = pure () + checkType' ctx (NAT {}) u = pure () checkType' ctx t@(Zero {}) u = throw $ NotType t.loc ctx t checkType' ctx t@(Succ {}) u = throw $ NotType t.loc ctx t @@ -415,7 +415,7 @@ mutual -- if Ψ | Γ ⊢ σ · n ⇒ ℕ ⊳ Σn nres <- inferC ctx sg n let nat = nres.type - expectNat !(askAt DEFS) ctx SZero n.loc nat + expectNAT !(askAt DEFS) ctx SZero n.loc nat -- if Ψ | Γ, n : ℕ ⊢₀ A ⇐ Type checkTypeC (extendTy Zero ret.name nat ctx) ret.term Nothing -- if Ψ | Γ ⊢ σ · zer ⇐ A[0 ∷ ℕ/n] ⊳ Σz @@ -424,7 +424,7 @@ mutual -- with ρ₂ ≤ π'σ, (ρ₁ + ρ₂) ≤ πσ let [< p, ih] = suc.names pisg = pi * sg.qty - sucCtx = extendTyN [< (pisg, p, Nat p.loc), (pi', ih, ret.term)] ctx + sucCtx = extendTyN [< (pisg, p, NAT p.loc), (pi', ih, ret.term)] ctx sucType = substCaseSuccRet suc.names ret sucout :< qp :< qih <- checkC sucCtx sg suc.term sucType expectCompatQ loc qih (pi' * sg.qty) diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index 9f96291..31c059f 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -54,7 +54,7 @@ substCasePairRet [< x, y] dty retty = public export substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n) substCaseSuccRet [< p, ih] retty = - let arg = Ann (Succ (BVT 1 p.loc) p.loc) (Nat noLoc) $ p.loc `extendL` ih.loc + let arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT noLoc) $ p.loc `extendL` ih.loc in retty.term // (arg ::: shift 2) @@ -104,8 +104,8 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r)) export covering %inline - expectNat : Term d n -> Eff fs () - expectNat = expect ExpectedNat `(Nat {}) `(()) + expectNAT : Term d n -> Eff fs () + expectNAT = expect ExpectedNAT `(NAT {}) `(()) export covering %inline expectSTRING : Term d n -> Eff fs () @@ -155,8 +155,8 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} expectEq = expect ExpectedEq `(Eq {ty, l, r, _}) `((ty, l, r)) export covering %inline - expectNat : Term 0 n -> Eff fs () - expectNat = expect ExpectedNat `(Nat {}) `(()) + expectNAT : Term 0 n -> Eff fs () + expectNAT = expect ExpectedNAT `(NAT {}) `(()) export covering %inline expectSTRING : Term 0 n -> Eff fs () diff --git a/lib/Quox/Typing/Error.idr b/lib/Quox/Typing/Error.idr index 3ac54ba..68683be 100644 --- a/lib/Quox/Typing/Error.idr +++ b/lib/Quox/Typing/Error.idr @@ -67,7 +67,7 @@ data Error | ExpectedSig Loc (NameContexts d n) (Term d n) | ExpectedEnum Loc (NameContexts d n) (Term d n) | ExpectedEq Loc (NameContexts d n) (Term d n) -| ExpectedNat Loc (NameContexts d n) (Term d n) +| ExpectedNAT Loc (NameContexts d n) (Term d n) | ExpectedSTRING Loc (NameContexts d n) (Term d n) | ExpectedBOX Loc (NameContexts d n) (Term d n) | BadUniverse Loc Universe Universe @@ -127,7 +127,7 @@ Located Error where (ExpectedSig loc _ _).loc = loc (ExpectedEnum loc _ _).loc = loc (ExpectedEq loc _ _).loc = loc - (ExpectedNat loc _ _).loc = loc + (ExpectedNAT loc _ _).loc = loc (ExpectedSTRING loc _ _).loc = loc (ExpectedBOX loc _ _).loc = loc (BadUniverse loc _ _).loc = loc @@ -290,10 +290,10 @@ parameters {opts : LayoutOpts} (showContext : Bool) hangDSingle "expected an enumeration type, but got" !(prettyTerm ctx.dnames ctx.tnames s) - ExpectedNat _ ctx s => + ExpectedNAT _ ctx s => hangDSingle ("expected the type" <++> - !(prettyTerm [<] [<] $ Nat noLoc) <+> ", but got") + !(prettyTerm [<] [<] $ NAT noLoc) <+> ", but got") !(prettyTerm ctx.dnames ctx.tnames s) ExpectedSTRING _ ctx s => diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 98505e9..349d9fd 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -186,7 +186,7 @@ eraseTerm ctx ty (DLam body loc) = do a <- fst <$> wrapExpect `(expectEq) ctx loc ty eraseTerm (extendDim body.name ctx) a.term body.term -eraseTerm ctx _ s@(Nat {}) = +eraseTerm ctx _ s@(NAT {}) = throw $ CompileTimeOnly ctx s -- 0 ⤋ 0 ⇐ ℕ @@ -365,12 +365,12 @@ eraseElim ctx e@(CaseEnum qty tag ret arms loc) = do eraseElim ctx (CaseNat qty qtyIH nat ret zero succ loc) = do let ty = sub1 ret nat enat <- eraseElim ctx nat - zero <- eraseTerm ctx (sub1 ret (Ann (Zero loc) (Nat loc) loc)) zero + zero <- eraseTerm ctx (sub1 ret (Ann (Zero loc) (NAT loc) loc)) zero let [< p, ih] = succ.names succ' <- eraseTerm - (extendTyN [< (qty, p, Nat loc), + (extendTyN [< (qty, p, NAT loc), (qtyIH, ih, sub1 (ret // shift 1) (BV 0 loc))] ctx) - (sub1 (ret // shift 2) (Ann (Succ (BVT 1 loc) loc) (Nat loc) loc)) + (sub1 (ret // shift 2) (Ann (Succ (BVT 1 loc) loc) (NAT loc) loc)) succ.term let succ = case isErased qtyIH of Kept => NSRec p ih succ' diff --git a/lib/Quox/Whnf/Coercion.idr b/lib/Quox/Whnf/Coercion.idr index f70df4f..0e35665 100644 --- a/lib/Quox/Whnf/Coercion.idr +++ b/lib/Quox/Whnf/Coercion.idr @@ -211,8 +211,8 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} (ty // one q) loc -- (coe ℕ @_ @_ s) ⇝ (s ∷ ℕ) - Nat tyLoc => - whnf defs ctx sg $ Ann s (Nat tyLoc) loc + NAT tyLoc => + whnf defs ctx sg $ Ann s (NAT tyLoc) loc -- (coe String @_ @_ s) ⇝ (s ∷ String) STRING tyLoc => diff --git a/lib/Quox/Whnf/Interface.idr b/lib/Quox/Whnf/Interface.idr index bbd3f1b..b3f7331 100644 --- a/lib/Quox/Whnf/Interface.idr +++ b/lib/Quox/Whnf/Interface.idr @@ -84,8 +84,8 @@ isTagHead _ = False ||| an expression like `0 ∷ ℕ` or `suc n ∷ ℕ` public export %inline isNatHead : Elim {} -> Bool -isNatHead (Ann (Zero {}) (Nat {}) _) = True -isNatHead (Ann (Succ {}) (Nat {}) _) = True +isNatHead (Ann (Zero {}) (NAT {}) _) = True +isNatHead (Ann (Succ {}) (NAT {}) _) = True isNatHead (Coe {}) = True isNatHead _ = False @@ -121,7 +121,7 @@ isTyCon (Enum {}) = True isTyCon (Tag {}) = False isTyCon (Eq {}) = True isTyCon (DLam {}) = False -isTyCon (Nat {}) = True +isTyCon (NAT {}) = True isTyCon (Zero {}) = False isTyCon (Succ {}) = False isTyCon (STRING {}) = True @@ -168,7 +168,7 @@ canPushCoe sg (Enum {}) _ = True canPushCoe sg (Tag {}) _ = False canPushCoe sg (Eq {}) _ = True canPushCoe sg (DLam {}) _ = False -canPushCoe sg (Nat {}) _ = True +canPushCoe sg (NAT {}) _ = True canPushCoe sg (Zero {}) _ = False canPushCoe sg (Succ {}) _ = False canPushCoe sg (STRING {}) _ = True diff --git a/lib/Quox/Whnf/Main.idr b/lib/Quox/Whnf/Main.idr index ffb82b0..3d7f94b 100644 --- a/lib/Quox/Whnf/Main.idr +++ b/lib/Quox/Whnf/Main.idr @@ -113,10 +113,10 @@ CanWhnf Elim Interface.isRedexE where Left _ => let ty = sub1 ret nat in case nat of - Ann (Zero _) (Nat _) _ => + Ann (Zero _) (NAT _) _ => whnf defs ctx sg $ Ann zer ty zer.loc - Ann (Succ n succLoc) (Nat natLoc) _ => - let nn = Ann n (Nat natLoc) succLoc + Ann (Succ n succLoc) (NAT natLoc) _ => + let nn = Ann n (NAT natLoc) succLoc tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc] in whnf defs ctx sg $ Ann tm ty caseLoc @@ -235,7 +235,7 @@ CanWhnf Term Interface.isRedexT where whnf _ _ _ t@(Tag {}) = pure $ nred t whnf _ _ _ t@(Eq {}) = pure $ nred t whnf _ _ _ t@(DLam {}) = pure $ nred t - whnf _ _ _ t@(Nat {}) = pure $ nred t + whnf _ _ _ t@(NAT {}) = pure $ nred t whnf _ _ _ t@(Zero {}) = pure $ nred t whnf _ _ _ t@(Succ {}) = pure $ nred t whnf _ _ _ t@(STRING {}) = pure $ nred t diff --git a/lib/Quox/Whnf/TypeCase.idr b/lib/Quox/Whnf/TypeCase.idr index 569a88d..a42c0d9 100644 --- a/lib/Quox/Whnf/TypeCase.idr +++ b/lib/Quox/Whnf/TypeCase.idr @@ -156,7 +156,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} ret loc -- (type-case ℕ ∷ _ return Q of { ℕ ⇒ s; ⋯ }) ⇝ s ∷ Q - Nat {} => + NAT {} => whnf defs ctx SZero $ Ann (tycaseRhsDef0 def KNat arms) ret loc -- (type-case String ∷ _ return Q of { String ⇒ s; ⋯ }) ⇝ s ∷ Q diff --git a/tests/Tests/Equal.idr b/tests/Tests/Equal.idr index 818e7c2..61926b0 100644 --- a/tests/Tests/Equal.idr +++ b/tests/Tests/Equal.idr @@ -19,7 +19,7 @@ defGlobals = fromList ("f", mkPostulate GAny (^Arr One (^FT "A" 0) (^FT "A" 0))), ("id", mkDef GAny (^Arr One (^FT "A" 0) (^FT "A" 0)) (^LamY "x" (^BVT 0))), ("eq-AB", mkPostulate GZero (^Eq0 (^TYPE 0) (^FT "A" 0) (^FT "B" 0))), - ("two", mkDef GAny (^Nat) (^Succ (^Succ (^Zero))))] + ("two", mkDef GAny (^NAT) (^Succ (^Succ (^Zero))))] parameters (label : String) (act : Eff Equal ()) {default defGlobals globals : Definitions} @@ -447,30 +447,30 @@ tests = "equality & subtyping" :- [ ], "natural type" :- [ - testEq "ℕ = ℕ" $ equalTy empty (^Nat) (^Nat), - testEq "ℕ = ℕ : ★₀" $ equalT empty (^TYPE 0) (^Nat) (^Nat), - testEq "ℕ = ℕ : ★₆₉" $ equalT empty (^TYPE 69) (^Nat) (^Nat), - testNeq "ℕ ≠ {}" $ equalTy empty (^Nat) (^enum []), - testEq "0=1 ⊢ ℕ = {}" $ equalTy empty01 (^Nat) (^enum []) + testEq "ℕ = ℕ" $ equalTy empty (^NAT) (^NAT), + testEq "ℕ = ℕ : ★₀" $ equalT empty (^TYPE 0) (^NAT) (^NAT), + testEq "ℕ = ℕ : ★₆₉" $ equalT empty (^TYPE 69) (^NAT) (^NAT), + testNeq "ℕ ≠ {}" $ equalTy empty (^NAT) (^enum []), + testEq "0=1 ⊢ ℕ = {}" $ equalTy empty01 (^NAT) (^enum []) ], "natural numbers" :- [ - testEq "0 = 0" $ equalT empty (^Nat) (^Zero) (^Zero), + testEq "0 = 0" $ equalT empty (^NAT) (^Zero) (^Zero), testEq "succ two = succ two" $ - equalT empty (^Nat) (^Succ (^FT "two" 0)) (^Succ (^FT "two" 0)), + equalT empty (^NAT) (^Succ (^FT "two" 0)) (^Succ (^FT "two" 0)), testNeq "succ two ≠ two" $ - equalT empty (^Nat) (^Succ (^FT "two" 0)) (^FT "two" 0), + equalT empty (^NAT) (^Succ (^FT "two" 0)) (^FT "two" 0), testNeq "0 ≠ 1" $ - equalT empty (^Nat) (^Zero) (^Succ (^Zero)), + equalT empty (^NAT) (^Zero) (^Succ (^Zero)), testEq "0=1 ⊢ 0 = 1" $ - equalT empty01 (^Nat) (^Zero) (^Succ (^Zero)) + equalT empty01 (^NAT) (^Zero) (^Succ (^Zero)) ], "natural elim" :- [ testEq "caseω 0 return {a,b} of {zero ⇒ 'a; succ _ ⇒ 'b} = 'a" $ equalT empty (^enum ["a", "b"]) - (E $ ^CaseNat Any Zero (^Ann (^Zero) (^Nat)) + (E $ ^CaseNat Any Zero (^Ann (^Zero) (^NAT)) (SN $ ^enum ["a", "b"]) (^Tag "a") (SN $ ^Tag "b")) @@ -478,16 +478,16 @@ tests = "equality & subtyping" :- [ testEq "caseω 1 return {a,b} of {zero ⇒ 'a; succ _ ⇒ 'b} = 'b" $ equalT empty (^enum ["a", "b"]) - (E $ ^CaseNat Any Zero (^Ann (^Succ (^Zero)) (^Nat)) + (E $ ^CaseNat Any Zero (^Ann (^Succ (^Zero)) (^NAT)) (SN $ ^enum ["a", "b"]) (^Tag "a") (SN $ ^Tag "b")) (^Tag "b"), testEq "caseω 4 return ℕ of {0 ⇒ 0; succ n ⇒ n} = 3" $ equalT empty - (^Nat) - (E $ ^CaseNat Any Zero (^Ann (^makeNat 4) (^Nat)) - (SN $ ^Nat) + (^NAT) + (E $ ^CaseNat Any Zero (^Ann (^makeNat 4) (^NAT)) + (SN $ ^NAT) (^Zero) (SY [< "n", ^BN Unused] $ ^BVT 1)) (^makeNat 3) @@ -513,7 +513,7 @@ tests = "equality & subtyping" :- [ (^Pair (^Tag "b") (^Tag "a")), testEq "0=1 ⊢ ('a, 'b) = ('b, 'a) : ℕ" $ equalT empty01 - (^Nat) + (^NAT) (^Pair (^Tag "a") (^Tag "b")) (^Pair (^Tag "b") (^Tag "a")) ], diff --git a/tests/Tests/FromPTerm.idr b/tests/Tests/FromPTerm.idr index b3451a9..b7bbf6e 100644 --- a/tests/Tests/FromPTerm.idr +++ b/tests/Tests/FromPTerm.idr @@ -85,7 +85,7 @@ tests = "PTerm → Term" :- [ ], "terms" :- - let defs = fromList [("f", mkDef GAny (^Nat) (^Zero))] + let defs = fromList [("f", mkDef GAny (^NAT) (^Zero))] -- doesn't have to be well typed yet, just well scoped fromPTerm = runFromParser {defs} . fromPTermWith [< "𝑖", "𝑗"] [< "A", "x", "y", "z"] diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index 122be48..d74a65d 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -282,8 +282,8 @@ tests = "parser" :- [ ], "naturals" :- [ - parseMatch term "ℕ" `(Nat _), - parseMatch term "Nat" `(Nat _), + parseMatch term "ℕ" `(NAT _), + parseMatch term "Nat" `(NAT _), parseMatch term "zero" `(Zero _), parseMatch term "succ n" `(Succ (V "n" {}) _), parseMatch term "3" @@ -296,9 +296,9 @@ tests = "parser" :- [ "box" :- [ parseMatch term "[1.ℕ]" - `(BOX (PQ One _) (Nat _) _), + `(BOX (PQ One _) (NAT _) _), parseMatch term "[ω. ℕ × ℕ]" - `(BOX (PQ Any _) (Sig (Unused _) (Nat _) (Nat _) _) _), + `(BOX (PQ Any _) (Sig (Unused _) (NAT _) (NAT _) _) _), parseMatch term "[a]" `(Box (V "a" {}) _), parseMatch term "[0]" @@ -388,13 +388,13 @@ tests = "parser" :- [ `(Case (PQ Any _) (V "n" {}) (Unused _, V "A" {}) (CaseNat (V "a" {}) (PV "n'" _, PQ Zero _, Unused _, V "b" {}) _) _), parseMatch term "caseω n return ℕ of { succ _, 1.ih ⇒ ih; zero ⇒ 0; }" - `(Case (PQ Any _) (V "n" {}) (Unused _, Nat _) + `(Case (PQ Any _) (V "n" {}) (Unused _, NAT _) (CaseNat (Zero _) (Unused _, PQ One _, PV "ih" _, V "ih" {}) _) _), parseMatch term "caseω n return ℕ of { succ _, ω.ih ⇒ ih; zero ⇒ 0; }" - `(Case (PQ Any _) (V "n" {}) (Unused _, Nat _) + `(Case (PQ Any _) (V "n" {}) (Unused _, NAT _) (CaseNat (Zero _) (Unused _, PQ Any _, PV "ih" _, V "ih" {}) _) _), parseMatch term "caseω n return ℕ of { succ _, ih ⇒ ih; zero ⇒ 0; }" - `(Case (PQ Any _) (V "n" {}) (Unused _, Nat _) + `(Case (PQ Any _) (V "n" {}) (Unused _, NAT _) (CaseNat (Zero _) (Unused _, PQ One _, PV "ih" _, V "ih" {}) _) _), parseFails term "caseω n return A of { zero ⇒ a }", parseFails term "caseω n return ℕ of { succ ⇒ 5 }" @@ -425,9 +425,9 @@ tests = "parser" :- [ `(MkPDef (PQ Zero _) "A" (PConcrete (Just $ TYPE 0 _) (Enum ["a", "b", "c"] _)) _), parseMatch definition "postulate yeah : ℕ" - `(MkPDef (PQ Any _) "yeah" (PPostulate (Nat _)) _), + `(MkPDef (PQ Any _) "yeah" (PPostulate (NAT _)) _), parseMatch definition "postulateω yeah : ℕ" - `(MkPDef (PQ Any _) "yeah" (PPostulate (Nat _)) _), + `(MkPDef (PQ Any _) "yeah" (PPostulate (NAT _)) _), parseMatch definition "postulate0 FileHandle : ★" `(MkPDef (PQ Zero _) "FileHandle" (PPostulate (TYPE 0 _)) _), parseFails definition "postulate not-a-postulate : ℕ = 69", diff --git a/tests/Tests/PrettyTerm.idr b/tests/Tests/PrettyTerm.idr index 71e183f..11356f7 100644 --- a/tests/Tests/PrettyTerm.idr +++ b/tests/Tests/PrettyTerm.idr @@ -210,7 +210,7 @@ tests = "pretty printing terms" :- [ "type-case" :- [ testPrettyE [<] [<] {label = "type-case ℕ ∷ ★⁰ return ★⁰ of { ⋯ }"} - (^TypeCase (^Ann (^Nat) (^TYPE 0)) (^TYPE 0) empty (^Nat)) + (^TypeCase (^Ann (^NAT) (^TYPE 0)) (^TYPE 0) empty (^NAT)) "type-case ℕ ∷ ★⁰ return ★⁰ of { _ ⇒ ℕ }" "type-case Nat :: Type 0 return Type 0 of { _ => Nat }" ], diff --git a/tests/Tests/Reduce.idr b/tests/Tests/Reduce.idr index 7e81a7a..66595cb 100644 --- a/tests/Tests/Reduce.idr +++ b/tests/Tests/Reduce.idr @@ -52,7 +52,7 @@ tests = "whnf" :- [ ], "neutrals" :- [ - testNoStep "x" (ctx [< ("A", ^Nat)]) $ ^BV 0, + testNoStep "x" (ctx [< ("A", ^NAT)]) $ ^BV 0, testNoStep "a" empty $ ^F "a" 0, testNoStep "f a" empty $ ^App (^F "f" 0) (^FT "a" 0), testNoStep "★₀ ∷ ★₁" empty $ ^Ann (^TYPE 0) (^TYPE 1) @@ -81,13 +81,13 @@ tests = "whnf" :- [ ], "elim closure" :- [ - testWhnf "x{}" (ctx [< ("x", ^Nat)]) + testWhnf "x{}" (ctx [< ("x", ^NAT)]) (CloE (Sub (^BV 0) id)) (^BV 0), testWhnf "x{a/x}" empty (CloE (Sub (^BV 0) (^F "a" 0 ::: id))) (^F "a" 0), - testWhnf "x{a/y}" (ctx [< ("x", ^Nat)]) + testWhnf "x{a/y}" (ctx [< ("x", ^NAT)]) (CloE (Sub (^BV 0) (^BV 0 ::: ^F "a" 0 ::: id))) (^BV 0), testWhnf "x{(y{a/y})/x}" empty @@ -96,7 +96,7 @@ tests = "whnf" :- [ testWhnf "(x y){f/x,a/y}" empty (CloE (Sub (^App (^BV 0) (^BVT 1)) (^F "f" 0 ::: ^F "a" 0 ::: id))) (^App (^F "f" 0) (^FT "a" 0)), - testWhnf "(y ∷ x){A/x}" (ctx [< ("x", ^Nat)]) + testWhnf "(y ∷ x){A/x}" (ctx [< ("x", ^NAT)]) (CloE (Sub (^Ann (^BVT 1) (^BVT 0)) (^F "A" 0 ::: id))) (^BV 0), testWhnf "(y ∷ x){A/x,a/y}" empty @@ -129,10 +129,10 @@ tests = "whnf" :- [ ^App (^F "f" 0) (E $ ^App (^Ann (^LamY "x" (^BVT 0)) (^Arr One (^FT "A" 0) (^FT "A" 0))) (^FT "a" 0)), - testNoStep "λx. (y x){x/x,a/y}" (ctx [< ("y", ^Nat)]) $ + testNoStep "λx. (y x){x/x,a/y}" (ctx [< ("y", ^NAT)]) $ ^LamY "x" (CloT $ Sub (E $ ^App (^BV 1) (^BVT 0)) (^BV 0 ::: ^F "a" 0 ::: id)), - testNoStep "f (y x){x/x,a/y}" (ctx [< ("y", ^Nat)]) $ + testNoStep "f (y x){x/x,a/y}" (ctx [< ("y", ^NAT)]) $ ^App (^F "f" 0) (CloT (Sub (E $ ^App (^BV 1) (^BVT 0)) (^BV 0 ::: ^F "a" 0 ::: id))) diff --git a/tests/Tests/Typechecker.idr b/tests/Tests/Typechecker.idr index 1418643..f99886a 100644 --- a/tests/Tests/Typechecker.idr +++ b/tests/Tests/Typechecker.idr @@ -79,7 +79,7 @@ sndDef = (SY [< "x", "y"] $ ^BVT 0)))) nat : Term d n -nat = ^Nat +nat = ^NAT apps : Elim d n -> List (Term d n) -> Elim d n apps = foldl (\f, s => ^App f s) From 0514fff481882401a39e0d7c3eded96fa24cb1b7 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 2 Nov 2023 20:01:34 +0100 Subject: [PATCH 036/133] =?UTF-8?q?represent=20=E2=84=95=20constants=20dir?= =?UTF-8?q?ectly?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit instead of as huge `succ (succ (succ ⋯))` terms --- lib/Quox/Displace.idr | 2 +- lib/Quox/Equal.idr | 28 +++++++++++++++------------- lib/Quox/FreeVars.idr | 4 ++-- lib/Quox/Parser/FromParser.idr | 2 +- lib/Quox/Parser/Parser.idr | 6 +++--- lib/Quox/Parser/Syntax.idr | 14 ++++++-------- lib/Quox/Syntax/Term/Base.idr | 14 ++++++-------- lib/Quox/Syntax/Term/Pretty.idr | 16 +++------------- lib/Quox/Syntax/Term/Subst.idr | 4 ++-- lib/Quox/Syntax/Term/Tighten.idr | 8 ++++---- lib/Quox/Typechecker.idr | 4 ++-- lib/Quox/Untyped/Erase.idr | 18 +++++++++--------- lib/Quox/Untyped/Scheme.idr | 8 +++----- lib/Quox/Untyped/Syntax.idr | 24 ++++++------------------ lib/Quox/Whnf/Interface.idr | 23 ++++++++++++++++------- lib/Quox/Whnf/Main.idr | 17 ++++++++++++++--- tests/Tests/Equal.idr | 4 ++-- tests/Tests/Parser.idr | 23 +++++++++-------------- 18 files changed, 104 insertions(+), 115 deletions(-) diff --git a/lib/Quox/Displace.idr b/lib/Quox/Displace.idr index 14a3ce5..3ac9907 100644 --- a/lib/Quox/Displace.idr +++ b/lib/Quox/Displace.idr @@ -28,7 +28,7 @@ parameters (k : Universe) Eq (doDisplaceDS ty) (doDisplace l) (doDisplace r) loc doDisplace (DLam body loc) = DLam (doDisplaceDS body) loc doDisplace (NAT loc) = NAT loc - doDisplace (Zero loc) = Zero loc + doDisplace (Nat n loc) = Nat n loc doDisplace (Succ p loc) = Succ (doDisplace p) loc doDisplace (STRING loc) = STRING loc doDisplace (Str s loc) = Str s loc diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 33892c1..7055181 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -279,27 +279,29 @@ namespace Term compare0' defs ctx sg nat@(NAT {}) s t = local_ Equal $ case (s, t) of -- --------------- - -- Γ ⊢ 0 = 0 ⇐ ℕ - (Zero {}, Zero {}) => pure () + -- Γ ⊢ n = n ⇐ ℕ + (Nat x {}, Nat y {}) => unless (x == y) $ clashT s.loc ctx nat s t -- Γ ⊢ s = t ⇐ ℕ -- ------------------------- -- Γ ⊢ succ s = succ t ⇐ ℕ - (Succ s' {}, Succ t' {}) => compare0 defs ctx sg nat s' t' + (Succ s' {}, Succ t' {}) => compare0 defs ctx sg nat s' t' + (Nat (S x) {}, Succ t' {}) => compare0 defs ctx sg nat (Nat x s.loc) t' + (Succ s' {}, Nat (S y) {}) => compare0 defs ctx sg nat s' (Nat y t.loc) (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f - (Zero {}, Succ {}) => clashT s.loc ctx nat s t - (Zero {}, E _) => clashT s.loc ctx nat s t - (Succ {}, Zero {}) => clashT s.loc ctx nat s t - (Succ {}, E _) => clashT s.loc ctx nat s t - (E _, Zero {}) => clashT s.loc ctx nat s t - (E _, Succ {}) => clashT s.loc ctx nat s t + (Nat 0 {}, Succ {}) => clashT s.loc ctx nat s t + (Nat 0 {}, E _) => clashT s.loc ctx nat s t + (Succ {}, Nat 0 {}) => clashT s.loc ctx nat s t + (Succ {}, E _) => clashT s.loc ctx nat s t + (E _, Nat 0 {}) => clashT s.loc ctx nat s t + (E _, Succ {}) => clashT s.loc ctx nat s t - (Zero {}, t) => wrongType t.loc ctx nat t - (Succ {}, t) => wrongType t.loc ctx nat t - (E _, t) => wrongType t.loc ctx nat t - (s, _) => wrongType s.loc ctx nat s + (Nat 0 {}, t) => wrongType t.loc ctx nat t + (Succ {}, t) => wrongType t.loc ctx nat t + (E _, t) => wrongType t.loc ctx nat t + (s, _) => wrongType s.loc ctx nat s compare0' defs ctx sg str@(STRING {}) s t = local_ Equal $ case (s, t) of diff --git a/lib/Quox/FreeVars.idr b/lib/Quox/FreeVars.idr index 929eb71..00ff22d 100644 --- a/lib/Quox/FreeVars.idr +++ b/lib/Quox/FreeVars.idr @@ -191,7 +191,7 @@ HasFreeVars (Term d) where fv (Eq {ty, l, r, _}) = fvD ty <+> fv l <+> fv r fv (DLam {body, _}) = fvD body fv (NAT {}) = none - fv (Zero {}) = none + fv (Nat {}) = none fv (Succ {p, _}) = fv p fv (STRING {}) = none fv (Str {}) = none @@ -269,7 +269,7 @@ HasFreeDVars Term where fdv (Eq {ty, l, r, _}) = fdv @{DScope} ty <+> fdv l <+> fdv r fdv (DLam {body, _}) = fdv @{DScope} body fdv (NAT {}) = none - fdv (Zero {}) = none + fdv (Nat {}) = none fdv (Succ {p, _}) = fdv p fdv (STRING {}) = none fdv (Str {}) = none diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 0979915..8b312e4 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -189,7 +189,7 @@ mutual <*> pure loc NAT loc => pure $ NAT loc - Zero loc => pure $ Zero loc + Nat n loc => pure $ Nat n loc Succ n loc => [|Succ (fromPTermWith ds ns n) (pure loc)|] STRING loc => pure $ STRING loc diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index b687cba..030c2ec 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -296,11 +296,11 @@ termArg fname = withLoc fname $ <|> [|Enum enumType|] <|> [|Tag tag|] <|> const <$> boxTerm fname - <|> NAT <$ res "ℕ" - <|> Zero <$ res "zero" + <|> NAT <$ res "ℕ" + <|> Nat 0 <$ res "zero" + <|> [|Nat nat|] <|> STRING <$ res "String" <|> [|Str strLit|] - <|> [|fromNat nat|] <|> [|V qname displacement|] <|> const <$> tupleTerm fname diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index d6c13a6..2b7e19c 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -86,7 +86,7 @@ namespace PTerm | DApp PTerm PDim Loc | NAT Loc - | Zero Loc | Succ PTerm Loc + | Nat Nat Loc | Succ PTerm Loc | STRING Loc -- "String" is a reserved word in idris | Str String Loc @@ -110,6 +110,10 @@ namespace PTerm | CaseBox PatVar PTerm Loc %name PCaseBody body + public export %inline + Zero : Loc -> PTerm + Zero = Nat 0 + %runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal] export @@ -130,7 +134,7 @@ Located PTerm where (DLam _ _ loc).loc = loc (DApp _ _ loc).loc = loc (NAT loc).loc = loc - (Zero loc).loc = loc + (Nat _ loc).loc = loc (Succ _ loc).loc = loc (STRING loc).loc = loc (Str _ loc).loc = loc @@ -219,12 +223,6 @@ Located PTopLevel where (PLoad _ loc).loc = loc -public export -fromNat : Nat -> Loc -> PTerm -fromNat 0 loc = Zero loc -fromNat (S k) loc = Succ (fromNat k loc) loc - - public export PFile : Type PFile = List PTopLevel diff --git a/lib/Quox/Syntax/Term/Base.idr b/lib/Quox/Syntax/Term/Base.idr index 8ec1838..994b4ea 100644 --- a/lib/Quox/Syntax/Term/Base.idr +++ b/lib/Quox/Syntax/Term/Base.idr @@ -88,8 +88,7 @@ mutual ||| natural numbers (temporary until 𝐖 gets added) NAT : (loc : Loc) -> Term d n - -- [todo] can these be elims? - Zero : (loc : Loc) -> Term d n + Nat : (val : Nat) -> (loc : Loc) -> Term d n Succ : (p : Term d n) -> (loc : Loc) -> Term d n ||| strings @@ -324,10 +323,9 @@ public export %inline BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n BVT i loc = E $ BV i loc -public export -makeNat : Nat -> Loc -> Term d n -makeNat 0 loc = Zero loc -makeNat (S k) loc = Succ (makeNat k loc) loc +public export %inline +Zero : Loc -> Term d n +Zero = Nat 0 public export %inline enum : List TagVal -> Loc -> Term d n @@ -379,7 +377,7 @@ Located (Term d n) where (Eq _ _ _ loc).loc = loc (DLam _ loc).loc = loc (NAT loc).loc = loc - (Zero loc).loc = loc + (Nat _ loc).loc = loc (STRING loc).loc = loc (Str _ loc).loc = loc (Succ _ loc).loc = loc @@ -442,7 +440,7 @@ Relocatable (Term d n) where setLoc loc (Eq ty l r _) = Eq ty l r loc setLoc loc (DLam body _) = DLam body loc setLoc loc (NAT _) = NAT loc - setLoc loc (Zero _) = Zero loc + setLoc loc (Nat n _) = Nat n loc setLoc loc (Succ p _) = Succ p loc setLoc loc (STRING _) = STRING loc setLoc loc (Str s _) = Str s loc diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index ecb5821..a2629de 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -450,19 +450,9 @@ prettyTerm dnames tnames s@(DLam {}) = prettyLambda dnames tnames s prettyTerm dnames tnames (NAT _) = natD -prettyTerm dnames tnames (Zero _) = hl Syntax "0" -prettyTerm dnames tnames (Succ p _) = do - succD <- succD - let succ : Doc opts -> Eff Pretty (Doc opts) - succ t = prettyAppD succD [t] - toNat : Term d n -> Eff Pretty (Either (Doc opts) Nat) - toNat s with (pushSubsts' s) - _ | Zero _ = pure $ Right 0 - _ | Succ d _ = bitraverse succ (pure . S) =<< - toNat (assert_smaller s d) - _ | s' = map Left . withPrec Arg $ - prettyTerm dnames tnames $ assert_smaller s s' - either succ (hl Syntax . text . show . S) =<< toNat p +prettyTerm dnames tnames (Nat n _) = hl Syntax $ pshow n +prettyTerm dnames tnames (Succ p _) = + prettyAppD !succD [!(withPrec Arg $ prettyTerm dnames tnames p)] prettyTerm dnames tnames (STRING _) = stringD prettyTerm dnames tnames (Str s _) = prettyStrLit s diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index 8610b78..b85ffd4 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -274,8 +274,8 @@ mutual nclo $ DLam (body // th // ph) loc pushSubstsWith _ _ (NAT loc) = nclo $ NAT loc - pushSubstsWith _ _ (Zero loc) = - nclo $ Zero loc + pushSubstsWith _ _ (Nat n loc) = + nclo $ Nat n loc pushSubstsWith th ph (Succ n loc) = nclo $ Succ (n // th // ph) loc pushSubstsWith _ _ (STRING loc) = diff --git a/lib/Quox/Syntax/Term/Tighten.idr b/lib/Quox/Syntax/Term/Tighten.idr index 83ea7e0..de45d98 100644 --- a/lib/Quox/Syntax/Term/Tighten.idr +++ b/lib/Quox/Syntax/Term/Tighten.idr @@ -63,8 +63,8 @@ mutual DLam <$> tightenDS p body <*> pure loc tightenT' p (NAT loc) = pure $ NAT loc - tightenT' p (Zero loc) = - pure $ Zero loc + tightenT' p (Nat n loc) = + pure $ Nat n loc tightenT' p (Succ s loc) = Succ <$> tightenT p s <*> pure loc tightenT' p (STRING loc) = @@ -188,8 +188,8 @@ mutual DLam <$> dtightenDS p body <*> pure loc dtightenT' p (NAT loc) = pure $ NAT loc - dtightenT' p (Zero loc) = - pure $ Zero loc + dtightenT' p (Nat n loc) = + pure $ Nat n loc dtightenT' p (Succ s loc) = Succ <$> dtightenT p s <*> pure loc dtightenT' p (STRING loc) = diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index 2273a08..a477c3e 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -190,7 +190,7 @@ mutual check' ctx sg t@(NAT {}) ty = toCheckType ctx sg t ty - check' ctx sg (Zero {}) ty = do + check' ctx sg (Nat {}) ty = do expectNAT !(askAt DEFS) ctx SZero ty.loc ty pure $ zeroFor ctx @@ -276,7 +276,7 @@ mutual throw $ NotType t.loc ctx t checkType' ctx (NAT {}) u = pure () - checkType' ctx t@(Zero {}) u = throw $ NotType t.loc ctx t + checkType' ctx t@(Nat {}) u = throw $ NotType t.loc ctx t checkType' ctx t@(Succ {}) u = throw $ NotType t.loc ctx t checkType' ctx (STRING loc) u = pure () diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 349d9fd..2aa40cf 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -189,9 +189,9 @@ eraseTerm ctx ty (DLam body loc) = do eraseTerm ctx _ s@(NAT {}) = throw $ CompileTimeOnly ctx s --- 0 ⤋ 0 ⇐ ℕ -eraseTerm _ _ (Zero loc) = - pure $ Zero loc +-- n ⤋ n ⇐ ℕ +eraseTerm _ _ (Nat n loc) = + pure $ Nat n loc -- s ⤋ s' ⇐ ℕ -- ----------------------- @@ -438,7 +438,7 @@ eraseElim ctx (DCloE (Sub term th)) = export uses : Var n -> Term n -> Nat -uses i (F _ _) = 0 +uses i (F {}) = 0 uses i (B j _) = if i == j then 1 else 0 uses i (Lam x body _) = uses (VS i) body uses i (App fun arg _) = uses i fun + uses i arg @@ -448,16 +448,16 @@ uses i (Snd pair _) = uses i pair uses i (Tag tag _) = 0 uses i (CaseEnum tag cases _) = uses i tag + foldl max 0 (map (assert_total uses i . snd) cases) -uses i (Absurd _) = 0 -uses i (Zero _) = 0 +uses i (Absurd {}) = 0 +uses i (Nat {}) = 0 uses i (Succ nat _) = uses i nat uses i (CaseNat nat zer suc _) = uses i nat + max (uses i zer) (uses' suc) where uses' : CaseNatSuc n -> Nat uses' (NSRec _ _ s) = uses (VS (VS i)) s uses' (NSNonrec _ s) = uses (VS i) s -uses i (Str _ _) = 0 +uses i (Str {}) = 0 uses i (Let x rhs body _) = uses i rhs + uses (VS i) body -uses i (Erased _) = 0 +uses i (Erased {}) = 0 export inlineable : U.Term n -> Bool @@ -482,7 +482,7 @@ trimLets (CaseEnum tag cases loc) = CaseEnum (trimLets tag) (map (map $ \c => trimLets $ assert_smaller cases c) cases) loc trimLets (Absurd loc) = Absurd loc -trimLets (Zero loc) = Zero loc +trimLets (Nat n loc) = Nat n loc trimLets (Succ nat loc) = Succ (trimLets nat) loc trimLets (CaseNat nat zer suc loc) = CaseNat (trimLets nat) (trimLets zer) (trimLets' suc) loc diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index d0fd2de..a005d4c 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -200,13 +200,11 @@ toScheme xs (CaseEnum tag cases _) = toScheme xs (Absurd _) = pure $ Q "absurd" -toScheme xs (Zero _) = - pure $ N 0 +toScheme xs (Nat n _) = + pure $ N n toScheme xs (Succ nat _) = - case !(toScheme xs nat) of - N n => pure $ N $ S n - s => pure $ L ["+", s, N 1] + pure $ L ["+", !(toScheme xs nat), N 1] toScheme xs (CaseNat nat zer (NSRec p ih suc) _) = freshInBC [< p, ih] $ \[< p, ih] => diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 0548293..b8b6abb 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -39,7 +39,7 @@ data Term where ||| empty match Absurd : Loc -> Term n - Zero : Loc -> Term n + Nat : (val : Nat) -> Loc -> Term n Succ : (nat : Term n) -> Loc -> Term n CaseNat : (nat : Term n) -> (zer : Term n) -> @@ -76,7 +76,7 @@ Located (Term n) where (Tag _ loc).loc = loc (CaseEnum _ _ loc).loc = loc (Absurd loc).loc = loc - (Zero loc).loc = loc + (Nat _ loc).loc = loc (Succ _ loc).loc = loc (CaseNat _ _ _ loc).loc = loc (Str _ loc).loc = loc @@ -198,16 +198,6 @@ sucCaseArm (NSRec x ih s) = pure $ sucCaseArm (NSNonrec x s) = pure $ MkPrettyCaseArm !(sucPat x) [x] s -private covering -prettyNat : {opts : LayoutOpts} -> - BContext n -> Term n -> Eff Pretty (Either Nat (Doc opts)) -prettyNat xs (Zero _) = pure $ Left 0 -prettyNat xs (Succ n _) = - case !(withPrec Arg $ prettyNat xs n) of - Left n => pure $ Left $ S n - Right doc => map Right $ parensIfM App $ sep [!succD, doc] -prettyNat xs s = map Right $ prettyTerm xs s - prettyTerm _ (F x _) = prettyFree x prettyTerm xs (B i _) = prettyTBind $ xs !!! i prettyTerm xs (Lam x body _) = @@ -229,11 +219,9 @@ prettyTerm xs (CaseEnum tag cases _) = prettyCase xs prettyTag tag $ map (\(t, rhs) => MkPrettyCaseArm t [] rhs) $ toList cases prettyTerm xs (Absurd _) = hl Syntax "absurd" -prettyTerm xs (Zero _) = hl Tag "0" +prettyTerm xs (Nat n _) = hl Tag $ pshow n prettyTerm xs (Succ nat _) = - case !(prettyNat xs nat) of - Left n => hl Tag $ pshow $ S n - Right doc => prettyApp' !succD [< doc] + prettyApp' !succD [< !(prettyTerm xs nat)] prettyTerm xs (CaseNat nat zer suc _) = prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)] prettyTerm xs (Str s _) = @@ -298,8 +286,8 @@ CanSubstSelf Term where CaseEnum (tag // th) (map (assert_total mapSnd (// th)) cases) loc Absurd loc => Absurd loc - Zero loc => - Zero loc + Nat n loc => + Nat n loc Succ nat loc => Succ (nat // th) loc CaseNat nat zer suc loc => diff --git a/lib/Quox/Whnf/Interface.idr b/lib/Quox/Whnf/Interface.idr index b3f7331..efc51f9 100644 --- a/lib/Quox/Whnf/Interface.idr +++ b/lib/Quox/Whnf/Interface.idr @@ -84,11 +84,18 @@ isTagHead _ = False ||| an expression like `0 ∷ ℕ` or `suc n ∷ ℕ` public export %inline isNatHead : Elim {} -> Bool -isNatHead (Ann (Zero {}) (NAT {}) _) = True +isNatHead (Ann (Nat {}) (NAT {}) _) = True isNatHead (Ann (Succ {}) (NAT {}) _) = True isNatHead (Coe {}) = True isNatHead _ = False +||| a natural constant, with or without an annotation +public export %inline +isNatConst : Term d n -> Bool +isNatConst (Nat {}) = True +isNatConst (E (Ann (Nat {}) _ _)) = True +isNatConst _ = False + ||| an expression like `[s] ∷ [π. A]` public export %inline isBoxHead : Elim {} -> Bool @@ -122,7 +129,7 @@ isTyCon (Tag {}) = False isTyCon (Eq {}) = True isTyCon (DLam {}) = False isTyCon (NAT {}) = True -isTyCon (Zero {}) = False +isTyCon (Nat {}) = False isTyCon (Succ {}) = False isTyCon (STRING {}) = True isTyCon (Str {}) = False @@ -169,7 +176,7 @@ canPushCoe sg (Tag {}) _ = False canPushCoe sg (Eq {}) _ = True canPushCoe sg (DLam {}) _ = False canPushCoe sg (NAT {}) _ = True -canPushCoe sg (Zero {}) _ = False +canPushCoe sg (Nat {}) _ = False canPushCoe sg (Succ {}) _ = False canPushCoe sg (STRING {}) _ = True canPushCoe sg (Str {}) _ = False @@ -235,9 +242,11 @@ mutual ||| 2. an annotated elimination ||| (the annotation is redundant in a checkable context) ||| 3. a closure + ||| 4. `succ` applied to a natural constant public export isRedexT : RedexTest Term - isRedexT _ _ (CloT {}) = True - isRedexT _ _ (DCloT {}) = True - isRedexT defs sg (E {e, _}) = isAnn e || isRedexE defs sg e - isRedexT _ _ _ = False + isRedexT _ _ (CloT {}) = True + isRedexT _ _ (DCloT {}) = True + isRedexT defs sg (E {e, _}) = isAnn e || isRedexE defs sg e + isRedexT _ _ (Succ p {}) = isNatConst p + isRedexT _ _ _ = False diff --git a/lib/Quox/Whnf/Main.idr b/lib/Quox/Whnf/Main.idr index 3d7f94b..e636adf 100644 --- a/lib/Quox/Whnf/Main.idr +++ b/lib/Quox/Whnf/Main.idr @@ -113,8 +113,13 @@ CanWhnf Elim Interface.isRedexE where Left _ => let ty = sub1 ret nat in case nat of - Ann (Zero _) (NAT _) _ => + Ann (Nat 0 _) (NAT _) _ => whnf defs ctx sg $ Ann zer ty zer.loc + Ann (Nat (S n) succLoc) (NAT natLoc) _ => + let nn = Ann (Nat n succLoc) (NAT natLoc) succLoc + tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc] + in + whnf defs ctx sg $ Ann tm ty caseLoc Ann (Succ n succLoc) (NAT natLoc) _ => let nn = Ann n (NAT natLoc) succLoc tm = subN suc [< nn, CaseNat pi piIH nn ret zer suc caseLoc] @@ -236,13 +241,19 @@ CanWhnf Term Interface.isRedexT where whnf _ _ _ t@(Eq {}) = pure $ nred t whnf _ _ _ t@(DLam {}) = pure $ nred t whnf _ _ _ t@(NAT {}) = pure $ nred t - whnf _ _ _ t@(Zero {}) = pure $ nred t - whnf _ _ _ t@(Succ {}) = pure $ nred t + whnf _ _ _ t@(Nat {}) = pure $ nred t whnf _ _ _ t@(STRING {}) = pure $ nred t whnf _ _ _ t@(Str {}) = pure $ nred t whnf _ _ _ t@(BOX {}) = pure $ nred t whnf _ _ _ t@(Box {}) = pure $ nred t + whnf _ _ _ (Succ p loc) = + case nchoose $ isNatConst p of + Left _ => case p of + Nat p _ => pure $ nred $ Nat (S p) loc + E (Ann (Nat p _) _ _) => pure $ nred $ Nat (S p) loc + Right nc => pure $ Element (Succ p loc) $ ?cc + -- s ∷ A ⇝ s (in term context) whnf defs ctx sg (E e) = do Element e enf <- whnf defs ctx sg e diff --git a/tests/Tests/Equal.idr b/tests/Tests/Equal.idr index 61926b0..60f71ad 100644 --- a/tests/Tests/Equal.idr +++ b/tests/Tests/Equal.idr @@ -486,11 +486,11 @@ tests = "equality & subtyping" :- [ testEq "caseω 4 return ℕ of {0 ⇒ 0; succ n ⇒ n} = 3" $ equalT empty (^NAT) - (E $ ^CaseNat Any Zero (^Ann (^makeNat 4) (^NAT)) + (E $ ^CaseNat Any Zero (^Ann (^Nat 4) (^NAT)) (SN $ ^NAT) (^Zero) (SY [< "n", ^BN Unused] $ ^BVT 1)) - (^makeNat 3) + (^Nat 3) ], todo "pair types", diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index d74a65d..299c905 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -284,12 +284,10 @@ tests = "parser" :- [ "naturals" :- [ parseMatch term "ℕ" `(NAT _), parseMatch term "Nat" `(NAT _), - parseMatch term "zero" `(Zero _), + parseMatch term "zero" `(Nat 0 _), parseMatch term "succ n" `(Succ (V "n" {}) _), - parseMatch term "3" - `(Succ (Succ (Succ (Zero _) _) _) _), - parseMatch term "succ (succ 1)" - `(Succ (Succ (Succ (Zero _) _) _) _), + parseMatch term "3" `(Nat 3 _), + parseMatch term "succ (succ 1)" `(Succ (Succ (Nat 1 _) _) _), parseFails term "succ succ 5", parseFails term "succ" ], @@ -299,12 +297,9 @@ tests = "parser" :- [ `(BOX (PQ One _) (NAT _) _), parseMatch term "[ω. ℕ × ℕ]" `(BOX (PQ Any _) (Sig (Unused _) (NAT _) (NAT _) _) _), - parseMatch term "[a]" - `(Box (V "a" {}) _), - parseMatch term "[0]" - `(Box (Zero _) _), - parseMatch term "[1]" - `(Box (Succ (Zero _) _) _) + parseMatch term "[a]" `(Box (V "a" {}) _), + parseMatch term "[0]" `(Box (Nat 0 _) _), + parseMatch term "[1]" `(Box (Nat 1 _) _) ], "coe" :- [ @@ -389,13 +384,13 @@ tests = "parser" :- [ (CaseNat (V "a" {}) (PV "n'" _, PQ Zero _, Unused _, V "b" {}) _) _), parseMatch term "caseω n return ℕ of { succ _, 1.ih ⇒ ih; zero ⇒ 0; }" `(Case (PQ Any _) (V "n" {}) (Unused _, NAT _) - (CaseNat (Zero _) (Unused _, PQ One _, PV "ih" _, V "ih" {}) _) _), + (CaseNat (Nat 0 _) (Unused _, PQ One _, PV "ih" _, V "ih" {}) _) _), parseMatch term "caseω n return ℕ of { succ _, ω.ih ⇒ ih; zero ⇒ 0; }" `(Case (PQ Any _) (V "n" {}) (Unused _, NAT _) - (CaseNat (Zero _) (Unused _, PQ Any _, PV "ih" _, V "ih" {}) _) _), + (CaseNat (Nat 0 _) (Unused _, PQ Any _, PV "ih" _, V "ih" {}) _) _), parseMatch term "caseω n return ℕ of { succ _, ih ⇒ ih; zero ⇒ 0; }" `(Case (PQ Any _) (V "n" {}) (Unused _, NAT _) - (CaseNat (Zero _) (Unused _, PQ One _, PV "ih" _, V "ih" {}) _) _), + (CaseNat (Nat 0 _) (Unused _, PQ One _, PV "ih" _, V "ih" {}) _) _), parseFails term "caseω n return A of { zero ⇒ a }", parseFails term "caseω n return ℕ of { succ ⇒ 5 }" ], From 5dfefe443c57b20e2f7d8338d7a15df4f81dfcb1 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 17:42:07 +0100 Subject: [PATCH 037/133] more tidying of outputs --- lib/Quox/Untyped/Erase.idr | 28 ++++++++++++++++++++++++---- lib/Quox/Untyped/Scheme.idr | 17 ++++++++++------- lib/Quox/Untyped/Syntax.idr | 34 ++++++++++++++++++++-------------- 3 files changed, 54 insertions(+), 25 deletions(-) diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 2aa40cf..0fc24ef 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -18,6 +18,7 @@ import Language.Reflection %language ElabReflection %hide TT.Name +%hide AppView.(.head) public export @@ -464,10 +465,25 @@ inlineable : U.Term n -> Bool inlineable (F {}) = True inlineable (B {}) = True inlineable (Tag {}) = True +inlineable (Nat {}) = True +inlineable (Str {}) = True inlineable (Absurd {}) = True inlineable (Erased {}) = True inlineable _ = False +export +droppable : U.Term n -> Bool +droppable (F {}) = True +droppable (B {}) = True +droppable (Fst e _) = droppable e +droppable (Snd e _) = droppable e +droppable (Tag {}) = True +droppable (Nat {}) = True +droppable (Str {}) = True +droppable (Absurd {}) = True +droppable (Erased {}) = True +droppable _ = False + export trimLets : U.Term n -> U.Term n trimLets (F x loc) = F x loc @@ -479,8 +495,11 @@ trimLets (Fst pair loc) = Fst (trimLets pair) loc trimLets (Snd pair loc) = Snd (trimLets pair) loc trimLets (Tag tag loc) = Tag tag loc trimLets (CaseEnum tag cases loc) = - CaseEnum (trimLets tag) - (map (map $ \c => trimLets $ assert_smaller cases c) cases) loc + let tag = trimLets tag + cases = map (map $ \c => trimLets $ assert_smaller cases c) cases in + if droppable tag && length cases == 1 + then snd cases.head + else CaseEnum tag cases loc trimLets (Absurd loc) = Absurd loc trimLets (Nat n loc) = Nat n loc trimLets (Succ nat loc) = Succ (trimLets nat) loc @@ -492,8 +511,9 @@ trimLets (CaseNat nat zer suc loc) = trimLets (Str s loc) = Str s loc trimLets (Let x rhs body loc) = let rhs' = trimLets rhs - body' = trimLets body in - if inlineable rhs' || uses VZ body' == 1 + body' = trimLets body + uses = uses VZ body in + if inlineable rhs' || uses == 1 || (droppable rhs' && uses == 0) then sub1 rhs' body' else Let x rhs' body' loc trimLets (Erased loc) = Erased loc diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index a005d4c..be3ee6b 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -292,9 +292,11 @@ defToScheme x (SchemeDef isMain str) = do modifyAt AVOID $ insert x pure $ Just $ Define x $ Literal str -orIndent : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Doc opts -orIndent a b = - parens $ ifMultiline (a <++> b) (a `vappend` indent 2 b) +orIndent : {opts : LayoutOpts} -> Doc opts -> Doc opts -> Eff Pretty (Doc opts) +orIndent a b = do + one <- parens $ a <++> b + two <- parens $ a `vappend` indent 2 b + pure $ ifMultiline one two export covering prettySexp : {opts : LayoutOpts} -> Sexp -> Eff Pretty (Doc opts) @@ -303,7 +305,7 @@ private covering prettyLambda : {opts : LayoutOpts} -> String -> List Id -> Sexp -> Eff Pretty (Doc opts) prettyLambda lam xs e = - pure $ orIndent + orIndent (hsep [!(hl Syntax $ text lam), !(prettySexp $ L $ map V xs)]) !(prettySexp e) @@ -316,7 +318,7 @@ prettyLet : {opts : LayoutOpts} -> SnocList (Id, Sexp) -> Sexp -> Eff Pretty (Doc opts) prettyLet ps (Let x rhs body) = prettyLet (ps :< (x, rhs)) body prettyLet ps e = - pure $ orIndent + orIndent (hsep [!(hl Syntax "let*"), !(bracks . vsep . toList =<< traverse prettyBind ps)]) !(prettySexp e) @@ -335,8 +337,9 @@ prettySexp (L []) = hl Delim "()" prettySexp (L (x :: xs)) = do d <- prettySexp x ds <- traverse prettySexp xs - parens $ (hsep $ d :: ds) <|> (hsep [d, vsep ds]) <|> - (vsep $ d :: map (indent 2) ds) + parens $ ifMultiline + (hsep $ d :: ds) + (hsep [d, vsep ds] <|> vsep (d :: map (indent 2) ds)) prettySexp (Q (V x)) = hl Tag $ "'" <+> prettyId' x prettySexp (Q x) = pure $ hcat [!(hl Tag "'"), !(prettySexp x)] prettySexp (N n) = hl Tag $ pshow n diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index b8b6abb..1697a66 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -112,7 +112,7 @@ prettyArg xs arg = withPrec Arg $ prettyTerm xs arg export covering prettyAppHead : {opts : LayoutOpts} -> BContext n -> Term n -> Eff Pretty (Doc opts) -prettyAppHead xs fun = parensIfM App =<< prettyTerm xs fun +prettyAppHead xs fun = withPrec App $ prettyTerm xs fun export prettyApp' : {opts : LayoutOpts} -> @@ -120,14 +120,15 @@ prettyApp' : {opts : LayoutOpts} -> prettyApp' fun args = do d <- askAt INDENT let args = toList args - pure $ hsep (fun :: args) - <|> hsep [fun, vsep args] - <|> vsep (fun :: map (indent d) args) + parensIfM App $ + hsep (fun :: args) + <|> hsep [fun, vsep args] + <|> vsep (fun :: map (indent d) args) export covering prettyApp : {opts : LayoutOpts} -> BContext n -> Doc opts -> SnocList (Term n) -> Eff Pretty (Doc opts) -prettyApp xs fun args = prettyApp' fun =<< traverse (prettyTerm xs) args +prettyApp xs fun args = prettyApp' fun =<< traverse (prettyArg xs) args public export record PrettyCaseArm a n where @@ -159,10 +160,15 @@ sucPat : {opts : LayoutOpts} -> BindName -> Eff Pretty (Doc opts) sucPat x = pure $ !succD <++> !(prettyTBind x) export -splitApp : Term b -> (Term b, SnocList (Term b)) +splitApp : Term n -> (Term n, SnocList (Term n)) splitApp (App f x _) = mapSnd (:< x) $ splitApp f splitApp f = (f, [<]) +export +splitPair : Term n -> List (Term n) +splitPair (Pair s t _) = s :: splitPair t +splitPair t = [t] + export splitLam : Telescope' BindName a b -> Term b -> Exists $ \c => (Telescope' BindName a c, Term c) @@ -185,9 +191,10 @@ prettyLets xs lets = sequence $ snd $ go lets where go [<] = (xs, [<]) go (lets :< (x, rhs)) = let (ys, docs) = go lets - doc = hsep <$> sequence - [letD, prettyTBind x, cstD, prettyTerm ys rhs, inD] - in + doc = do + x <- prettyTBind x + rhs <- withPrec Outer $ prettyTerm ys rhs + hangDSingle (hsep [!letD, x, !cstD]) (hsep [rhs, !inD]) in (ys :< x, docs :< doc) private @@ -210,8 +217,8 @@ prettyTerm xs (App fun arg _) = let (fun, args) = splitApp fun in prettyApp xs !(prettyAppHead xs fun) (args :< arg) prettyTerm xs (Pair fst snd _) = - parens =<< separateTight !commaD <$> - sequence {t = List} [prettyTerm xs fst, prettyTerm xs snd] + parens . separateTight !commaD =<< + traverse (withPrec Outer . prettyTerm xs) (fst :: splitPair snd) prettyTerm xs (Fst pair _) = prettyApp xs !fstD [< pair] prettyTerm xs (Snd pair _) = prettyApp xs !sndD [< pair] prettyTerm xs (Tag tag _) = prettyTag tag @@ -220,8 +227,7 @@ prettyTerm xs (CaseEnum tag cases _) = map (\(t, rhs) => MkPrettyCaseArm t [] rhs) $ toList cases prettyTerm xs (Absurd _) = hl Syntax "absurd" prettyTerm xs (Nat n _) = hl Tag $ pshow n -prettyTerm xs (Succ nat _) = - prettyApp' !succD [< !(prettyTerm xs nat)] +prettyTerm xs (Succ nat _) = prettyApp xs !succD [< nat] prettyTerm xs (CaseNat nat zer suc _) = prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)] prettyTerm xs (Str s _) = @@ -244,7 +250,7 @@ prettyDef name ErasedDef = prettyDef name (KeptDef isMain rhs) = do name <- prettyFree name {opts} eq <- cstD - rhs <- prettyTerm [<] rhs + rhs <- withPrec Outer $ prettyTerm [<] rhs let header = if isMain then text "#[main]" <++> name else name hangDSingle (header <++> eq) rhs prettyDef name (SchemeDef isMain str) = do From b7e1f37b5b7f7309f76d1cdb9ebc461c21a286f0 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 17:42:44 +0100 Subject: [PATCH 038/133] add some #[compile-scheme] --- examples/list.quox | 2 ++ examples/nat.quox | 4 ++++ 2 files changed, 6 insertions(+) diff --git a/examples/list.quox b/examples/list.quox index cb6ac1e..ac45ba4 100644 --- a/examples/list.quox +++ b/examples/list.quox @@ -24,6 +24,7 @@ def elim : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) → } }; +#[compile-scheme "(lambda% (n xs) xs)"] def up : 0.(A : ★) → (n : ℕ) → Vec n A → Vec¹ n A = λ A n ⇒ case n return n' ⇒ Vec n' A → Vec¹ n' A of { @@ -63,6 +64,7 @@ def elim : 0.(A : ★) → 0.(P : List A → ★) → }; -- [fixme] List A <: List¹ A should be automatic, imo +#[compile-scheme "(lambda (xs) xs)"] def up : 0.(A : ★) → List A → List¹ A = λ A xs ⇒ case xs return List¹ A of { (len, elems) ⇒ diff --git a/examples/nat.quox b/examples/nat.quox index 17715d4..e194206 100644 --- a/examples/nat.quox +++ b/examples/nat.quox @@ -4,6 +4,7 @@ load "either.quox"; namespace nat { +#[compile-scheme "(lambda (n) (cons n 'erased))"] def dup! : (n : ℕ) → [ω. Sing ℕ n] = λ n ⇒ case n return n' ⇒ [ω. Sing ℕ n'] of { @@ -16,6 +17,7 @@ def dup! : (n : ℕ) → [ω. Sing ℕ n] = def dup : ℕ → [ω.ℕ] = λ n ⇒ appω (Sing ℕ n) ℕ (sing.val ℕ n) (dup! n); +#[compile-scheme "(lambda% (m n) (+ m n))"] def plus : ℕ → ℕ → ℕ = λ m n ⇒ case m return ℕ of { @@ -23,6 +25,7 @@ def plus : ℕ → ℕ → ℕ = succ _, 1.p ⇒ succ p }; +#[compile-scheme "(lambda% (m n) (* m n))"] def timesω : ℕ → ω.ℕ → ℕ = λ m n ⇒ case m return ℕ of { @@ -67,6 +70,7 @@ def0 not-succ-self : (m : ℕ) → Not (m ≡ succ m : ℕ) = } +#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"] def eq? : DecEq ℕ = λ m ⇒ caseω m From d4639a35c63b63961d4f5e38dcfee4ab46e4c325 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 17:42:59 +0100 Subject: [PATCH 039/133] add hello.quox to examples --- examples/hello.quox | 26 ++++++++++++++++++++++++++ 1 file changed, 26 insertions(+) create mode 100644 examples/hello.quox diff --git a/examples/hello.quox b/examples/hello.quox new file mode 100644 index 0000000..e1f2052 --- /dev/null +++ b/examples/hello.quox @@ -0,0 +1,26 @@ +def0 Unit : ★ = {tt} + +def drop-unit : 0.(A : ★) → Unit → A → A = + λ A u x ⇒ case u return A of {'tt ⇒ x} + +-- postulate0 IOState : ★ + +def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState + +def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B = + λ A B m k s0 ⇒ + case m s0 return B × IOState of { (x, s1) ⇒ k x s1 } + +def seq : IO Unit → IO Unit → IO Unit = + λ a b ⇒ bind Unit Unit a (λ u ⇒ drop-unit (IO Unit) u b) + +#[compile-scheme "(lambda (n) (builtin-io (display n) (newline) 'tt))"] +postulate print-ℕ : ℕ → IO Unit + +#[compile-scheme "(lambda (str) (builtin-io (display str) (newline) 'tt))"] +postulate print : String → IO Unit + +load "nat.quox" + +#[main] +def main = seq (print-ℕ (nat.plus 1000000000 1)) (print "(nice)") From 90cdcfe4da67a30746339cc8307d25820e7b3ab5 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 20:07:59 +0100 Subject: [PATCH 040/133] add \n and \t escapes to the lexer --- lib/Quox/Parser/Lexer.idr | 12 +++++++----- 1 file changed, 7 insertions(+), 5 deletions(-) diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index 8702aa2..7ef791f 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -71,15 +71,17 @@ tmatch : Lexer -> (String -> Token) -> Tokenizer ExtToken tmatch t f = match t (T . f) -||| [todo] escapes other than `\"` and (accidentally) `\\` export fromStringLit : String -> String fromStringLit = pack . go . unpack . drop 1 . dropLast 1 where go : List Char -> List Char - go [] = [] - go ['\\'] = ['\\'] -- i guess??? - go ('\\' :: c :: cs) = c :: go cs - go (c :: cs) = c :: go cs + go [] = [] + go ['\\'] = ['\\'] -- i guess??? + go ('\\' :: 'n' :: cs) = '\n' :: go cs + go ('\\' :: 't' :: cs) = '\t' :: go cs + -- [todo] others + go ('\\' :: c :: cs) = c :: go cs + go (c :: cs) = c :: go cs private string : Tokenizer ExtToken From b6c435049dff51650cfe5ea5782da66e9c84748b Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 3 Nov 2023 20:08:45 +0100 Subject: [PATCH 041/133] escape strings in scheme the characters \, ", and everything below space or above ~ are replaced with a \xdd;-style escape inside string literals --- lib/Quox/Untyped/Scheme.idr | 25 ++++++++++++++++++++++++- 1 file changed, 24 insertions(+), 1 deletion(-) diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index be3ee6b..3379267 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -278,6 +278,29 @@ prelude = """ ;;;;;; """ +export +toHex : Int -> String +toHex x = + case toHex' x of + [<] => "0" + cs => concatMap singleton cs +where + toHex' : Int -> SnocList Char + toHex' x = + if x == 0 then [<] else + let d = x `div` 16 + m = x `mod` 16 in + toHex' (assert_smaller x d) :< + assert_total strIndex "0123456789abcdef" m + +export +escape : String -> String +escape = concatMap esc1 . unpack where + esc1 : Char -> String + esc1 c = if c < ' ' || c > '~' || c == '\\' || c == '"' + then "\\x" ++ toHex (ord c) ++ ";" + else singleton c + export covering defToScheme : Name -> Definition -> Eff Scheme (Maybe Sexp) defToScheme x ErasedDef = pure Nothing @@ -343,7 +366,7 @@ prettySexp (L (x :: xs)) = do prettySexp (Q (V x)) = hl Tag $ "'" <+> prettyId' x prettySexp (Q x) = pure $ hcat [!(hl Tag "'"), !(prettySexp x)] prettySexp (N n) = hl Tag $ pshow n -prettySexp (S s) = prettyStrLit s +prettySexp (S s) = prettyStrLit $ escape s prettySexp (Lambda xs e) = prettyLambda "lambda" xs e prettySexp (LambdaC xs e) = prettyLambda "lambda%" xs e prettySexp (Let x rhs e) = prettyLet [< (x, rhs)] e From 2f8a2d2cd210c924a08b8fafa1b43d82000a3568 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 4 Nov 2023 17:45:55 +0100 Subject: [PATCH 042/133] fix typo in error --- lib/Quox/Typing/Error.idr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Quox/Typing/Error.idr b/lib/Quox/Typing/Error.idr index 68683be..0b9a4b3 100644 --- a/lib/Quox/Typing/Error.idr +++ b/lib/Quox/Typing/Error.idr @@ -287,7 +287,7 @@ parameters {opts : LayoutOpts} (showContext : Bool) !(prettyTerm ctx.dnames ctx.tnames s) ExpectedEq _ ctx s => - hangDSingle "expected an enumeration type, but got" + hangDSingle "expected an equality type, but got" !(prettyTerm ctx.dnames ctx.tnames s) ExpectedNAT _ ctx s => From 3b9a339e5e0923de605425559f56cd4ae5eeeab6 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 14:30:40 +0100 Subject: [PATCH 043/133] rename "Tag" highlight to "Constant" --- lib/Quox/Parser/FromParser/Error.idr | 2 +- lib/Quox/Pretty.idr | 46 ++++++++++++++-------------- lib/Quox/Syntax/Term/Pretty.idr | 2 +- lib/Quox/Untyped/Scheme.idr | 6 ++-- lib/Quox/Untyped/Syntax.idr | 2 +- 5 files changed, 29 insertions(+), 29 deletions(-) diff --git a/lib/Quox/Parser/FromParser/Error.idr b/lib/Quox/Parser/FromParser/Error.idr index f1afbff..16a3592 100644 --- a/lib/Quox/Parser/FromParser/Error.idr +++ b/lib/Quox/Parser/FromParser/Error.idr @@ -139,7 +139,7 @@ parameters {opts : LayoutOpts} (showContext : Bool) prettyError (WrongFail str err loc) = pure $ vsep [!(prettyLoc loc), - "wrong error, expected to match", !(hl Tag $ text "\"\{str}\""), + "wrong error, expected to match", !(hl Constant $ text "\"\{str}\""), "but got", !(prettyError err)] prettyError (WrapParseError file err) = diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index b2ab4b9..e6f4a17 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -41,7 +41,7 @@ data HL | Dim | DVar | DVarErr | Qty | Universe | Syntax -| Tag +| Constant %runElab derive "HL" [Eq, Ord, Show] @@ -86,7 +86,7 @@ toSGR DVarErr = [SetForeground BrightGreen, SetStyle SingleUnderline] toSGR Qty = [SetForeground BrightMagenta] toSGR Universe = [SetForeground BrightRed] toSGR Syntax = [SetForeground BrightCyan] -toSGR Tag = [SetForeground BrightRed] +toSGR Constant = [SetForeground BrightRed] export %inline highlightSGR : HL -> Highlight @@ -262,25 +262,25 @@ eqndD = hl Delim . text =<< ifUnicode "≡" "==" dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun" annD = hl Delim . text =<< ifUnicode "∷" "::" natD = hl Syntax . text =<< ifUnicode "ℕ" "Nat" -stringD = hl Syntax $ text "String" -eqD = hl Syntax $ text "Eq" -colonD = hl Delim $ text ":" -commaD = hl Delim $ text "," -semiD = hl Delim $ text ";" -caseD = hl Syntax $ text "case" -typecaseD = hl Syntax $ text "type-case" -ofD = hl Syntax $ text "of" -returnD = hl Syntax $ text "return" -dotD = hl Delim $ text "." -zeroD = hl Syntax $ text "zero" -succD = hl Syntax $ text "succ" -coeD = hl Syntax $ text "coe" -compD = hl Syntax $ text "comp" -undD = hl Syntax $ text "_" -cstD = hl Syntax $ text "=" -pipeD = hl Syntax $ text "|" -fstD = hl Syntax $ text "fst" -sndD = hl Syntax $ text "snd" +stringD = hl Syntax $ text "String" +eqD = hl Syntax $ text "Eq" +colonD = hl Delim $ text ":" +commaD = hl Delim $ text "," +semiD = hl Delim $ text ";" +caseD = hl Syntax $ text "case" +typecaseD = hl Syntax $ text "type-case" +ofD = hl Syntax $ text "of" +returnD = hl Syntax $ text "return" +dotD = hl Delim $ text "." +zeroD = hl Constant $ text "zero" +succD = hl Constant $ text "succ" +coeD = hl Syntax $ text "coe" +compD = hl Syntax $ text "comp" +undD = hl Syntax $ text "_" +cstD = hl Syntax $ text "=" +pipeD = hl Syntax $ text "|" +fstD = hl Syntax $ text "fst" +sndD = hl Syntax $ text "snd" export @@ -330,13 +330,13 @@ prettyLoc (L (YesLoc file b)) = export prettyTag : {opts : _} -> String -> Eff Pretty (Doc opts) -prettyTag tag = hl Tag $ text $ "'" ++ quoteTag tag +prettyTag tag = hl Constant $ text $ "'" ++ quoteTag tag export prettyStrLit : {opts : _} -> String -> Eff Pretty (Doc opts) prettyStrLit s = let s = concatMap esc1 $ unpack s in - hl Syntax $ hcat ["\"", text s, "\""] + hl Constant $ hcat ["\"", text s, "\""] where esc1 : Char -> String esc1 '"' = "\""; esc1 '\\' = "\\" diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index a2629de..ffdb3e9 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -287,7 +287,7 @@ prettyEnum : {opts : _} -> List String -> Eff Pretty (Doc opts) prettyEnum cases = tightBraces =<< fillSeparateTight !commaD <$> - traverse (hl Tag . Doc.text . quoteTag) cases + traverse (hl Constant . Doc.text . quoteTag) cases private prettyCaseRet : {opts : _} -> diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index 3379267..61ca482 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -363,9 +363,9 @@ prettySexp (L (x :: xs)) = do parens $ ifMultiline (hsep $ d :: ds) (hsep [d, vsep ds] <|> vsep (d :: map (indent 2) ds)) -prettySexp (Q (V x)) = hl Tag $ "'" <+> prettyId' x -prettySexp (Q x) = pure $ hcat [!(hl Tag "'"), !(prettySexp x)] -prettySexp (N n) = hl Tag $ pshow n +prettySexp (Q (V x)) = hl Constant $ "'" <+> prettyId' x +prettySexp (Q x) = pure $ hcat [!(hl Constant "'"), !(prettySexp x)] +prettySexp (N n) = hl Constant $ pshow n prettySexp (S s) = prettyStrLit $ escape s prettySexp (Lambda xs e) = prettyLambda "lambda" xs e prettySexp (LambdaC xs e) = prettyLambda "lambda%" xs e diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 1697a66..da660cd 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -226,7 +226,7 @@ prettyTerm xs (CaseEnum tag cases _) = prettyCase xs prettyTag tag $ map (\(t, rhs) => MkPrettyCaseArm t [] rhs) $ toList cases prettyTerm xs (Absurd _) = hl Syntax "absurd" -prettyTerm xs (Nat n _) = hl Tag $ pshow n +prettyTerm xs (Nat n _) = hl Constant $ pshow n prettyTerm xs (Succ nat _) = prettyApp xs !succD [< nat] prettyTerm xs (CaseNat nat zer suc _) = prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)] From e211887a34d7a880c588a32ed9464ee022112c70 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:38:13 +0100 Subject: [PATCH 044/133] string/nat lit stuff --- lib/Quox/CharExtra.idr | 7 ++++ lib/Quox/NatExtra.idr | 43 ++++++++++++++++++-- lib/Quox/Parser/Lexer.idr | 80 +++++++++++++++++++++++++++++++------ lib/Quox/Untyped/Scheme.idr | 27 ++++--------- tests/Tests/Lexer.idr | 30 ++++++++++---- 5 files changed, 146 insertions(+), 41 deletions(-) diff --git a/lib/Quox/CharExtra.idr b/lib/Quox/CharExtra.idr index a2a05a3..48c1fab 100644 --- a/lib/Quox/CharExtra.idr +++ b/lib/Quox/CharExtra.idr @@ -166,3 +166,10 @@ isWhitespace ch = ch == '\t' || ch == '\r' || ch == '\n' || isSeparator ch export %foreign "scheme:string-normalize-nfc" normalizeNfc : String -> String + + +export +isCodepoint : Int -> Bool +isCodepoint n = + n <= 0x10FFFF && + not (n >= 0xD800 && n <= 0xDBFF || n >= 0xDC00 && n <= 0xDFFF) diff --git a/lib/Quox/NatExtra.idr b/lib/Quox/NatExtra.idr index 42f627e..64248ec 100644 --- a/lib/Quox/NatExtra.idr +++ b/lib/Quox/NatExtra.idr @@ -4,6 +4,7 @@ import public Data.Nat import Data.Nat.Division import Data.SnocList import Data.Vect +import Data.String %default total @@ -52,6 +53,42 @@ parameters {base : Nat} {auto 0 _ : base `GTE` 2} (chars : Vect base Char) showAtBase : Nat -> String showAtBase = pack . showAtBase' [] -export -showHex : Nat -> String -showHex = showAtBase $ fromList $ unpack "0123456789ABCDEF" +namespace Nat + export + showHex : Nat -> String + showHex = showAtBase $ fromList $ unpack "0123456789abcdef" + +namespace Int + export + showHex : Int -> String + showHex x = + if x < 0 then "-" ++ Nat.showHex (cast (-x)) else Nat.showHex (cast x) + + +namespace Int + export + fromHexit : Char -> Maybe Int + fromHexit c = + if c >= '0' && c <= '9' then Just $ ord c - ord '0' + else if c >= 'a' && c <= 'f' then Just $ ord c - ord 'a' + 10 + else if c >= 'A' && c <= 'F' then Just $ ord c - ord 'A' + 10 + else Nothing + + private + fromHex' : Int -> String -> Maybe Int + fromHex' acc str = case strM str of + StrNil => Just acc + StrCons c cs => fromHex' (16 * acc + !(fromHexit c)) (assert_smaller str cs) + + export %inline + fromHex : String -> Maybe Int + fromHex = fromHex' 0 + +namespace Nat + export + fromHexit : Char -> Maybe Nat + fromHexit = map cast . Int.fromHexit + + export %inline + fromHex : String -> Maybe Nat + fromHex = map cast . Int.fromHex diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index 7ef791f..c18c4a5 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -1,6 +1,7 @@ module Quox.Parser.Lexer import Quox.CharExtra +import Quox.NatExtra import Quox.Name import Data.String.Extra import Data.SortedMap @@ -72,29 +73,84 @@ tmatch t f = match t (T . f) export -fromStringLit : String -> String -fromStringLit = pack . go . unpack . drop 1 . dropLast 1 where - go : List Char -> List Char - go [] = [] - go ['\\'] = ['\\'] -- i guess??? - go ('\\' :: 'n' :: cs) = '\n' :: go cs - go ('\\' :: 't' :: cs) = '\t' :: go cs +fromStringLit : (String -> Token) -> String -> ExtToken +fromStringLit f str = + case go $ unpack $ drop 1 $ dropLast 1 str of + Left err => Invalid err str + Right ok => T $ f $ pack ok +where + Interpolation Char where interpolate = singleton + + go, hexEscape : List Char -> Either String (List Char) + + go [] = Right [] + go ['\\'] = Left "string ends with \\" + go ('\\' :: 'n' :: cs) = ('\n' ::) <$> go cs + go ('\\' :: 't' :: cs) = ('\t' ::) <$> go cs + go ('\\' :: 'x' :: cs) = hexEscape cs + go ('\\' :: 'X' :: cs) = hexEscape cs + go ('\\' :: '\\' :: cs) = ('\\' ::) <$> go cs + go ('\\' :: '"' :: cs) = ('"' ::) <$> go cs -- [todo] others - go ('\\' :: c :: cs) = c :: go cs - go (c :: cs) = c :: go cs + go ('\\' :: c :: _) = Left "unknown escape '\{c}'" + go (c :: cs) = (c ::) <$> go cs + + hexEscape cs = + case break (== ';') cs of + (hs, ';' :: rest) => do + let hs = pack hs + let Just c = Int.fromHex hs + | Nothing => Left #"invalid hex string "\#{hs}" in escape"# + if isCodepoint c + then (chr c ::) <$> go (assert_smaller cs rest) + else Left "codepoint \{hs} out of range" + _ => Left "unterminated hex escape" private string : Tokenizer ExtToken -string = tmatch stringLit (Str . fromStringLit) +string = match stringLit $ fromStringLit Str + + +%hide binLit +%hide octLit +%hide hexLit private nat : Tokenizer ExtToken -nat = tmatch (some (range '0' '9')) (Nat . cast) +nat = match hexLit fromHexLit + <|> tmatch decLit fromDecLit +where + withUnderscores : Lexer -> Lexer + withUnderscores l = l <+> many (opt (is '_') <+> l) + + withoutUnderscores : String -> String + withoutUnderscores = pack . go . unpack where + go : List Char -> List Char + go [] = [] + go ('_' :: cs) = go cs + go (c :: cs) = c :: go cs + + decLit = + withUnderscores (range '0' '9') <+> reject idContEnd + + hexLit = + approx "0x" <+> + withUnderscores (range '0' '9' <|> range 'a' 'f' <|> range 'A' 'F') <+> + reject idContEnd + + fromDecLit : String -> Token + fromDecLit = Nat . cast . withoutUnderscores + + fromHexLit : String -> ExtToken + fromHexLit str = + maybe (Invalid "invalid hex sequence" str) (T . Nat) $ + fromHex $ withoutUnderscores $ drop 2 str + private tag : Tokenizer ExtToken tag = tmatch (is '\'' <+> name) (Tag . drop 1) - <|> tmatch (is '\'' <+> stringLit) (Tag . fromStringLit . drop 1) + <|> match (is '\'' <+> stringLit) (fromStringLit Tag . drop 1) diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index 61ca482..36fbdd4 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -7,6 +7,7 @@ import Quox.Pretty import Quox.EffExtra import Quox.CharExtra +import Quox.NatExtra import Data.DPair import Data.List1 import Data.String @@ -278,28 +279,16 @@ prelude = """ ;;;;;; """ -export -toHex : Int -> String -toHex x = - case toHex' x of - [<] => "0" - cs => concatMap singleton cs -where - toHex' : Int -> SnocList Char - toHex' x = - if x == 0 then [<] else - let d = x `div` 16 - m = x `mod` 16 in - toHex' (assert_smaller x d) :< - assert_total strIndex "0123456789abcdef" m - export escape : String -> String -escape = concatMap esc1 . unpack where +escape = foldMap esc1 . unpack where esc1 : Char -> String - esc1 c = if c < ' ' || c > '~' || c == '\\' || c == '"' - then "\\x" ++ toHex (ord c) ++ ";" - else singleton c + esc1 c = + if c == '\\' || c == '"' then + "\\" ++ singleton c + else if c < ' ' || c > '~' then + "\\x" ++ showHex (ord c) ++ ";" + else singleton c export covering defToScheme : Name -> Definition -> Eff Scheme (Maybe Sexp) diff --git a/tests/Tests/Lexer.idr b/tests/Tests/Lexer.idr index 910a434..499aab4 100644 --- a/tests/Tests/Lexer.idr +++ b/tests/Tests/Lexer.idr @@ -148,15 +148,31 @@ tests = "lexer" :- [ ], "strings" :- [ - lexes #" "" "# [Str ""], - lexes #" "abc" "# [Str "abc"], - lexes #" "\"" "# [Str "\""], - lexes #" "\\" "# [Str "\\"], - lexes #" "\\\"" "# [Str "\\\""], - todo "other escapes" + lexes #" "" "# [Str ""], + lexes #" "abc" "# [Str "abc"], + lexes #" "\"" "# [Str "\""], + lexes #" "\\" "# [Str "\\"], + lexes #" "\\\"" "# [Str "\\\""], + lexes #" "\t" "# [Str "\t"], + lexes #" "\n" "# [Str "\n"], + lexes #" "🐉" "# [Str "🐉"], + lexes #" "\x1f409;" "# [Str "🐉"], + lexFail #" "\q" "#, + lexFail #" "\" "# ], - todo "naturals", + "naturals" :- [ + lexes "0" [Nat 0], + lexes "123" [Nat 123], + lexes "69_420" [Nat 69420], + lexes "0x123" [Nat 0x123], + lexes "0xbeef" [Nat 0xbeef], + lexes "0xBEEF" [Nat 0xBEEF], + lexes "0XBEEF" [Nat 0xBEEF], + lexes "0xbaba_baba" [Nat 0xbabababa], + lexFail "123abc", + lexFail "0x123abcghi" + ], "universes" :- [ lexes "Type0" [TYPE 0], From 580fbc8fd807ced897f245b82c5355f6e988c165 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:38:38 +0100 Subject: [PATCH 045/133] add misc.refl, misc.sing, nat.minus --- examples/misc.quox | 5 +++++ examples/nat.quox | 8 ++++++++ 2 files changed, 13 insertions(+) diff --git a/examples/misc.quox b/examples/misc.quox index d1b3731..bf24d39 100644 --- a/examples/misc.quox +++ b/examples/misc.quox @@ -32,6 +32,8 @@ def funext : (All A (eq-f A P p q)) → p ≡ q : All A P = λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖 +def refl : 0.(A : ★) → (x : A) → x ≡ x : A = λ A x ⇒ δ _ ⇒ x + def sym : 0.(A : ★) → 0.(x y : A) → (x ≡ y : A) → y ≡ x : A = λ A x y eq ⇒ δ 𝑖 ⇒ comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 } @@ -51,6 +53,9 @@ def0 HEq : (A B : ★) → A → B → ★¹ = def0 Sing : (A : ★) → A → ★ = λ A x ⇒ (val : A) × [0. val ≡ x : A] +def sing : 0.(A : ★) → (x : A) → Sing A x = + λ A x ⇒ (x, [δ _ ⇒ x]) + namespace sing { def val : 0.(A : ★) → 0.(x : A) → Sing A x → A = diff --git a/examples/nat.quox b/examples/nat.quox index e194206..f52c768 100644 --- a/examples/nat.quox +++ b/examples/nat.quox @@ -44,6 +44,14 @@ def pred-succ : ω.(n : ℕ) → pred (succ n) ≡ n : ℕ = def0 succ-inj : (m n : ℕ) → succ m ≡ succ n : ℕ → m ≡ n : ℕ = λ m n eq ⇒ δ 𝑖 ⇒ pred (eq @𝑖); +#[compile-scheme "(lambda% (m n) (max 0 (- m n)))"] +def minus : ℕ → ℕ → ℕ = + λ m n ⇒ + (case n return ℕ → ℕ of { + zero ⇒ λ m ⇒ m; + succ _, f ⇒ λ m ⇒ f (pred m) + }) m; + def0 IsSucc : ℕ → ★ = λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True }; From f58fa5218fcd395aa02c2721987e100ef1a26a1d Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:39:52 +0100 Subject: [PATCH 046/133] subscript numbers are no longer special --- lib/Quox/Parser/Lexer.idr | 11 ----------- lib/Quox/Syntax/Term/Pretty.idr | 8 -------- 2 files changed, 19 deletions(-) diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index c18c4a5..1e50c8c 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -153,23 +153,12 @@ tag = tmatch (is '\'' <+> name) (Tag . drop 1) <|> match (is '\'' <+> stringLit) (fromStringLit Tag . drop 1) - -private %inline -fromSub : Char -> Char -fromSub c = case c of - '₀' => '0'; '₁' => '1'; '₂' => '2'; '₃' => '3'; '₄' => '4' - '₅' => '5'; '₆' => '6'; '₇' => '7'; '₈' => '8'; '₉' => '9'; _ => c - private %inline fromSup : Char -> Char fromSup c = case c of '⁰' => '0'; '¹' => '1'; '²' => '2'; '³' => '3'; '⁴' => '4' '⁵' => '5'; '⁶' => '6'; '⁷' => '7'; '⁸' => '8'; '⁹' => '9'; _ => c -private %inline -subToNat : String -> Nat -subToNat = cast . pack . map fromSub . unpack - private %inline supToNat : String -> Nat supToNat = cast . pack . map fromSup . unpack diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index ffdb3e9..cc1784d 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -30,14 +30,6 @@ BTelescope : Nat -> Nat -> Type BTelescope = Telescope' BindName -private -subscript : String -> String -subscript = pack . map sub . unpack where - sub : Char -> Char - sub c = case c of - '0' => '₀'; '1' => '₁'; '2' => '₂'; '3' => '₃'; '4' => '₄' - '5' => '₅'; '6' => '₆'; '7' => '₇'; '8' => '₈'; '9' => '₉'; _ => c - private superscript : String -> String superscript = pack . map sup . unpack where From da3cd404f384f0f4f925b52947f001f02bccf65c Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:40:19 +0100 Subject: [PATCH 047/133] handle when getTermCols returns 0 --- exe/Options.idr | 8 +++++++- 1 file changed, 7 insertions(+), 1 deletion(-) diff --git a/exe/Options.idr b/exe/Options.idr index 299ce98..3efac83 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -40,6 +40,12 @@ record Options where %name Options opts %runElab derive "Options" [Show] +export +defaultWidth : IO Nat +defaultWidth = do + w <- cast {to = Nat} <$> getTermCols + pure $ if w == 0 then 80 else w + export defaultOpts : IO Options defaultOpts = pure $ MkOpts { @@ -47,7 +53,7 @@ defaultOpts = pure $ MkOpts { outFile = Console, until = Nothing, flavor = Unicode, - width = cast !getTermCols, + width = !defaultWidth, include = ["."] } From 6c8ebfb8044783f962c625bd99b2df11dd351553 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:41:21 +0100 Subject: [PATCH 048/133] fix some comments --- lib/Quox/Parser/Lexer.idr | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index 1e50c8c..dad087f 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -163,7 +163,7 @@ private %inline supToNat : String -> Nat supToNat = cast . pack . map fromSup . unpack --- ★0, Type0. base ★/Type is a Reserved +-- ★0, Type0. base ★/Type is a Reserved and ★¹/Type¹ are sequences of two tokens private universe : Tokenizer ExtToken universe = universeWith "★" <|> universeWith "Type" where @@ -312,7 +312,7 @@ tokens = choice $ map skip [pred isWhitespace, lineComment (exact "--" <+> reject symCont), blockComment (exact "{-") (exact "-}")] <+> - [universe] <+> -- ★ᵢ takes precedence over bare ★ + [universe] <+> -- Type takes precedence over bare Type map resTokenizer reserved <+> [sup, nat, string, tag, name] From d9cdf1306de1621bde0bfa5de8a2b00c8f6283dc Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:43:17 +0100 Subject: [PATCH 049/133] fix IsReserved MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit IsReserved should be true for e.g. "λ" but not "fun", since only the first can show up in the lexer output --- lib/Quox/Parser/Lexer.idr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index dad087f..7c4f26f 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -295,7 +295,7 @@ allReservedStrings = foldMap resString2 reserved ||| the token stream public export IsReserved : String -> Type -IsReserved str = So (str `elem` allReservedStrings) +IsReserved str = So (str `elem` reservedStrings) private name : Tokenizer ExtToken From 04af7ae9424a905a5c42337559a0aa00e92a8481 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:44:44 +0100 Subject: [PATCH 050/133] highlight the @ in dim apps as a delim --- lib/Quox/Pretty.idr | 3 ++- lib/Quox/Syntax/Term/Pretty.idr | 3 +-- 2 files changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index e6f4a17..a26100b 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -249,7 +249,7 @@ prettyDBind = hl DVar . prettyBind' export %inline typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD, -stringD, eqD, colonD, commaD, semiD, caseD, typecaseD, returnD, +stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD : {opts : LayoutOpts} -> Eff Pretty (Doc opts) typeD = hl Syntax . text =<< ifUnicode "★" "Type" @@ -267,6 +267,7 @@ eqD = hl Syntax $ text "Eq" colonD = hl Delim $ text ":" commaD = hl Delim $ text "," semiD = hl Delim $ text ";" +atD = hl Delim $ text "@" caseD = hl Syntax $ text "case" typecaseD = hl Syntax $ text "type-case" ofD = hl Syntax $ text "of" diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index cc1784d..ae2b565 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -201,8 +201,7 @@ prettyTArg dnames tnames s = private prettyDArg : {opts : _} -> BContext d -> Dim d -> Eff Pretty (Doc opts) -prettyDArg dnames p = - map (text "@" <+>) $ withPrec Arg $ prettyDim dnames p +prettyDArg dnames p = [|atD <+> withPrec Arg (prettyDim dnames p)|] private splitApps : Elim d n -> (Elim d n, List (Either (Dim d) (Term d n))) From bf8cced8887f416dcae4a0bcab13cde95bd266a4 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:45:07 +0100 Subject: [PATCH 051/133] swap some delim/syntax highlighting around --- lib/Quox/Pretty.idr | 16 ++++++++-------- 1 file changed, 8 insertions(+), 8 deletions(-) diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index a26100b..ac62adb 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -254,18 +254,18 @@ ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD : {opts : LayoutOpts} -> Eff Pretty (Doc opts) typeD = hl Syntax . text =<< ifUnicode "★" "Type" ioStateD = hl Syntax $ text "IOState" -arrowD = hl Delim . text =<< ifUnicode "→" "->" -darrowD = hl Delim . text =<< ifUnicode "⇒" "=>" -timesD = hl Delim . text =<< ifUnicode "×" "**" +arrowD = hl Syntax . text =<< ifUnicode "→" "->" +darrowD = hl Syntax . text =<< ifUnicode "⇒" "=>" +timesD = hl Syntax . text =<< ifUnicode "×" "**" lamD = hl Syntax . text =<< ifUnicode "λ" "fun" -eqndD = hl Delim . text =<< ifUnicode "≡" "==" +eqndD = hl Syntax . text =<< ifUnicode "≡" "==" dlamD = hl Syntax . text =<< ifUnicode "δ" "dfun" -annD = hl Delim . text =<< ifUnicode "∷" "::" +annD = hl Syntax . text =<< ifUnicode "∷" "::" natD = hl Syntax . text =<< ifUnicode "ℕ" "Nat" stringD = hl Syntax $ text "String" eqD = hl Syntax $ text "Eq" -colonD = hl Delim $ text ":" -commaD = hl Delim $ text "," +colonD = hl Syntax $ text ":" +commaD = hl Syntax $ text "," semiD = hl Delim $ text ";" atD = hl Delim $ text "@" caseD = hl Syntax $ text "case" @@ -279,7 +279,7 @@ coeD = hl Syntax $ text "coe" compD = hl Syntax $ text "comp" undD = hl Syntax $ text "_" cstD = hl Syntax $ text "=" -pipeD = hl Syntax $ text "|" +pipeD = hl Delim $ text "|" fstD = hl Syntax $ text "fst" sndD = hl Syntax $ text "snd" From 040a1862c3c718336a1a4965b02a79ac3a046518 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:45:33 +0100 Subject: [PATCH 052/133] refactor scheme prelude --- lib/Quox/Untyped/Scheme.idr | 28 ++++++++++------------------ 1 file changed, 10 insertions(+), 18 deletions(-) diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index 36fbdd4..4998f93 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -237,46 +237,38 @@ export prelude : String prelude = """ #!r6rs +(import (rnrs)) ; curried lambda (define-syntax lambda% (syntax-rules () - [(_ (x0 x1 ...) body ...) - (lambda (x0) (lambda% (x1 ...) body ...))] - [(_ () body ...) - (begin body ...)])) + [(_ (x . xs) . body) (lambda (x) (lambda% xs . body))] + [(_ () . body) (begin . body)])) ; curried application (define-syntax % (syntax-rules () - [(_ e0 e1 e2 ...) - (% (e0 e1) e2 ...)] + [(_ e0 e1 . es) (% (e0 e1) . es)] [(_ e) e])) ; curried function definition (define-syntax define% (syntax-rules () - [(_ (f x ...) body ...) - (define f (lambda% (x ...) body ...))] - [(_ x body ...) - (define x body ...)])) + [(_ (f . xs) . body) (define f (lambda% xs . body))] + [(_ f . body) (define f . body)])) (define-syntax builtin-io (syntax-rules () - [(_ body ...) - (lambda (s) - (let [(res (begin body ...))] - (cons res s)))])) + [(_ . body) (lambda (s) (cons (begin . body) s))])) (define (case-nat-rec z s n) - (let go [(acc (z)) (i 0)] - (if (= i n) acc (go (s i acc) (+ i 1))))) + (do [(i 0 (+ i 1)) (acc (z) (s i acc))] + [(= i n) acc])) (define (case-nat-nonrec z s n) (if (= n 0) (z) (s (- n 1)))) -(define (run-main f) (f 'io-state) (void)) -;;;;;; +(define (run-main f) (f 'io-state)) """ export From c48b7be5593b4336f3f3dda49e2f2592f3c3903f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:47:52 +0100 Subject: [PATCH 053/133] add html output highlighting --- exe/Main.idr | 16 +++++++++++----- exe/Options.idr | 35 +++++++++++++++++++++++------------ lib/Quox/Pretty.idr | 28 +++++++++++++++++++++++----- 3 files changed, 57 insertions(+), 22 deletions(-) diff --git a/exe/Main.idr b/exe/Main.idr index 2ee4c6d..45a377d 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -27,13 +27,18 @@ die opts err = do ignore $ fPutStr stderr $ render opts err exitFailure +private +hlFor : HLType -> OutFile -> HL -> Highlight +hlFor Guess Console = highlightSGR +hlFor Guess _ = noHighlight +hlFor NoHL _ = noHighlight +hlFor Term _ = highlightSGR +hlFor Html _ = highlightHtml + private runPretty : Options -> Eff Pretty a -> a runPretty opts act = - let doColor = opts.color && opts.outFile == Console - hl = if doColor then highlightSGR else noHighlight - in - runPrettyWith Outer opts.flavor hl 2 act + runPrettyWith Outer opts.flavor (hlFor opts.hlType opts.outFile) 2 act private putErrLn : HasIO io => String -> io () @@ -133,7 +138,7 @@ private outputStr : Lazy String -> Eff Compile () outputStr str = case !(asksAt OPTS outFile) of - None => pure () + NoOut => pure () Console => putStr str File f => do res <- withFile f WriteTruncate pure $ \h => fPutStr h str @@ -187,6 +192,7 @@ oneMain [] = throw NoMain oneMain [x] = pure x oneMain mains = throw $ MultipleMains mains + private processFile : String -> Eff Compile () processFile file = withEarlyStop $ do diff --git a/exe/Options.idr b/exe/Options.idr index 3efac83..a4f329f 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -11,7 +11,7 @@ import Derive.Prelude %language ElabReflection public export -data OutFile = File String | Console | None +data OutFile = File String | Console | NoOut %name OutFile f %runElab derive "OutFile" [Eq, Ord, Show] @@ -28,10 +28,15 @@ allPhases = %runElab do cs <- getCons $ fst !(lookupName "Phase") traverse (check . var) cs +||| "guess" is Term for a terminal and NoHL for a file +public export +data HLType = Guess | NoHL | Term | Html +%runElab derive "HLType" [Eq, Ord, Show] + public export record Options where constructor MkOpts - color : Bool + hlType : HLType outFile : OutFile until : Maybe Phase flavor : Pretty.Flavor @@ -49,7 +54,7 @@ defaultWidth = do export defaultOpts : IO Options defaultOpts = pure $ MkOpts { - color = True, + hlType = Guess, outFile = Console, until = Nothing, flavor = Unicode, @@ -66,7 +71,7 @@ data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options) private toOutFile : String -> OptAction -toOutFile "" = Ok {outFile := None} +toOutFile "" = Ok {outFile := NoOut} toOutFile "-" = Ok {outFile := Console} toOutFile f = Ok {outFile := File f} @@ -85,6 +90,14 @@ toWidth s = case parsePositive s of Just n => Ok {width := n} Nothing => Err "invalid width: \{show s}" +private +toHLType : String -> OptAction +toHLType str = case toLower str of + "none" => Ok {hlType := NoHL} + "term" => Ok {hlType := Term} + "html" => Ok {hlType := Html} + _ => Err "unknown highlighting type \{str}\ntypes: term, html, none" + private commonOptDescrs' : List (OptDescr OptAction) commonOptDescrs' = [ @@ -105,10 +118,8 @@ extraOptDescrs = [ "use ascii syntax when printing", MkOpt [] ["width"] (ReqArg toWidth "") "max output width (defaults to terminal width)", - MkOpt [] ["color", "colour"] (NoArg $ Ok {color := True}) - "use colour output (default)", - MkOpt [] ["no-color", "no-colour"] (NoArg $ Ok {color := False}) - "don't use colour output" + MkOpt [] ["color", "colour"] (ReqArg toHLType "") + "select highlighting type" ] private @@ -123,10 +134,10 @@ allOptDescrs = commonOptDescrs' ++ extraOptDescrs ++ helpOptDescrs export usageHeader : String -usageHeader = joinBy "\n" [ - "quox [options] [file.quox ...]", - "rawr" -] +usageHeader = trim """ +quox [options] [file.quox ...] +rawr +""" export usage : List (OptDescr _) -> IO a diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index ac62adb..11aab94 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -92,14 +92,32 @@ export %inline highlightSGR : HL -> Highlight highlightSGR h = MkHighlight (escapeSGR $ toSGR h) (escapeSGR [Reset]) +export %inline +toClass : HL -> String +toClass Delim = "dl" +toClass Free = "fr" +toClass TVar = "tv" +toClass TVarErr = "tv err" +toClass Dim = "dc" +toClass DVar = "dv" +toClass DVarErr = "dv err" +toClass Qty = "qt" +toClass Universe = "un" +toClass Syntax = "sy" +toClass Constant = "co" + +export %inline +highlightHtml : HL -> Highlight +highlightHtml h = MkHighlight #""# "" + + +export %inline +runPrettyHL : (HL -> Highlight) -> Eff Pretty a -> a +runPrettyHL f = runPrettyWith Outer Unicode f 2 export %inline runPretty : Eff Pretty a -> a -runPretty = runPrettyWith Outer Unicode noHighlight 2 - -export %inline -runPrettyColor : Eff Pretty a -> a -runPrettyColor = runPrettyWith Outer Unicode highlightSGR 2 +runPretty = runPrettyHL noHighlight export %inline From 246d80eea2aab402793dc8c79f9af730cb606e7d Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 15:48:01 +0100 Subject: [PATCH 054/133] add io.quox --- examples/io.quox | 31 +++++++++++++++++++++++++++++++ 1 file changed, 31 insertions(+) create mode 100644 examples/io.quox diff --git a/examples/io.quox b/examples/io.quox new file mode 100644 index 0000000..2b6ed66 --- /dev/null +++ b/examples/io.quox @@ -0,0 +1,31 @@ +load "misc.quox" + +namespace io { + +def0 IORes : ★ → ★ = λ A ⇒ A × IOState + +def0 IO : ★ → ★ = λ A ⇒ IOState → IORes A + +def pure : 0.(A : ★) → A → IO A = λ A x s ⇒ (x, s) + +def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B = + λ A B m k s0 ⇒ + case m s0 return IORes B of { (x, s1) ⇒ k x s1 } + +def seq : 0.(B : ★) → IO True → IO B → IO B = + λ B x y ⇒ bind True B x (λ u ⇒ case u return IO B of { 'true ⇒ y }) + +def seq' : IO True → IO True → IO True = seq True + +#[compile-scheme "(lambda (str) (builtin-io (display str) 'true))"] +postulate print : String → IO True + +def newline = print "\n" + +def println : String → IO True = + λ str ⇒ seq' (print str) newline + +#[compile-scheme "(builtin-io (get-line (current-input-port)))"] +postulate readln : IO String + +} From 50984aa1aaadbe12e0d68079ef277738f16de636 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 Nov 2023 20:49:02 +0100 Subject: [PATCH 055/133] refactor #[attribute] stuff --- lib/Quox/Parser/FromParser.idr | 90 +++++++------------ lib/Quox/Parser/Parser.idr | 159 +++++++++++++++++++++++++++------ lib/Quox/Parser/Syntax.idr | 65 +++++++------- tests/Tests/Parser.idr | 83 ++++++++--------- 4 files changed, 237 insertions(+), 160 deletions(-) diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 8b312e4..d96645c 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -311,8 +311,8 @@ fromPTerm = fromPTermWith [<] [<] export -globalPQty : Has (Except Error) fs => (q : Qty) -> Loc -> Eff fs GQty -globalPQty pi loc = case toGlobal pi of +globalPQty : Has (Except Error) fs => PQty -> Eff fs GQty +globalPQty (PQ pi loc) = case toGlobal pi of Just g => pure g Nothing => throw $ QtyNotGlobal loc pi @@ -336,15 +336,14 @@ addDef name def = do export covering -fromPDef : PDefinition -> Maybe String -> Bool -> - Eff FromParserPure NDefinition -fromPDef (MkPDef qty pname pbody defLoc) scheme isMain = do - name <- fromPBaseNameNS pname +fromPDef : PDefinition -> Eff FromParserPure NDefinition +fromPDef def = do + name <- fromPBaseNameNS def.name when !(getsAt DEFS $ isJust . lookup name) $ do - throw $ AlreadyExists defLoc name - gqty <- globalPQty qty.val qty.loc + throw $ AlreadyExists def.loc name + gqty <- globalPQty def.qty let sqty = globalToSubj gqty - case pbody of + case def.body of PConcrete ptype pterm => do type <- traverse fromPTerm ptype term <- fromPTerm pterm @@ -353,72 +352,47 @@ fromPDef (MkPDef qty pname pbody defLoc) scheme isMain = do ignore $ liftTC $ do checkTypeC empty type Nothing checkC empty sqty term type - addDef name $ mkDef gqty type term scheme isMain defLoc + addDef name $ mkDef gqty type term def.scheme def.main def.loc Nothing => do let E elim = term | _ => throw $ AnnotationNeeded term.loc empty term res <- liftTC $ inferC empty sqty elim - addDef name $ mkDef gqty res.type term scheme isMain defLoc + addDef name $ mkDef gqty res.type term def.scheme def.main def.loc PPostulate ptype => do type <- fromPTerm ptype - addDef name $ mkPostulate gqty type scheme isMain defLoc + addDef name $ mkPostulate gqty type def.scheme def.main def.loc public export data HasFail = NoFail | AnyFail | FailWith String -export -hasFail : List PDeclMod -> HasFail -hasFail [] = NoFail -hasFail (PFail str :: _) = maybe AnyFail FailWith str -hasFail (_ :: rest) = hasFail rest +export covering +expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error +expectFail loc act = + case fromParserPure !(getAt GEN) !(getAt DEFS) act of + Left err => pure err + Right _ => throw $ ExpectedFail loc -export -getScheme : List PDeclMod -> Maybe String -getScheme [] = Nothing -getScheme (PCompileScheme str :: _) = Just str -getScheme (_ :: rest) = getScheme rest - -export -isMain : List PDeclMod -> Bool -isMain [] = False -isMain (PMain :: _) = True -isMain (_ :: rest) = isMain rest +export covering +maybeFail : Monoid a => + PFail -> Loc -> Eff FromParserPure a -> Eff FromParserPure a +maybeFail PSucceed _ act = act +maybeFail PFailAny loc act = expectFail loc act $> neutral +maybeFail (PFailMatch str) loc act = do + err <- expectFail loc act + let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e + if str `isInfixOf` renderInfinite msg + then pure neutral + else throw $ WrongFail str err loc export covering fromPDecl : PDecl -> Eff FromParserPure (List NDefinition) - -export covering -fromPDeclBody : PDeclBody -> Maybe String -> Bool -> Loc -> - Eff FromParserPure (List NDefinition) -fromPDeclBody (PDef def) scheme isMain loc = - singleton <$> fromPDef def scheme isMain -fromPDeclBody (PNs ns) scheme isMain loc = do - when (isJust scheme) $ throw $ SchemeOnNamespace loc ns.name - when isMain $ throw $ MainOnNamespace loc ns.name +fromPDecl (PDef def) = + maybeFail def.fail def.loc $ singleton <$> fromPDef def +fromPDecl (PNs ns) = + maybeFail ns.fail ns.loc $ localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls -export covering -expectFail : PDeclBody -> Loc -> Eff FromParserPure Error -expectFail body loc = - let res = fromParserPure !(getAt GEN) !(getAt DEFS) $ - fromPDeclBody body Nothing False loc in - case res of - Left err => pure err - Right _ => throw $ ExpectedFail body.loc - - -fromPDecl (MkPDecl mods decl loc) = case hasFail mods of - NoFail => fromPDeclBody decl (getScheme mods) (isMain mods) loc - AnyFail => expectFail decl loc $> [] - FailWith str => do - err <- expectFail decl loc - let msg = runPretty $ prettyError False err {opts = Opts 10_000} -- w/e - if str `isInfixOf` renderInfinite msg - then pure [] - else throw $ WrongFail str err loc - - mutual export covering loadProcessFile : Loc -> String -> Eff FromParserIO (List NDefinition) diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index 030c2ec..de94618 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -577,7 +577,6 @@ caseTerm fname = withLoc fname $ do body <- mustWork $ caseBody fname pure $ Case qty head ret body --- export -- term : FileName -> Grammar True PTerm term fname = lamTerm fname <|> caseTerm fname @@ -586,20 +585,114 @@ term fname = lamTerm fname export -pragma : Grammar True a -> Grammar True a -pragma p = resC "#[" *> p <* mustWork (resC "]") +attr : FileName -> Grammar True PAttr +attr fname = withLoc fname $ do + resC "#[" + name <- baseName + args <- many $ termArg fname + mustWork $ resC "]" + pure $ PA name args export -declMod : Grammar True PDeclMod -declMod = pragma $ - exactName "fail" *> [|PFail $ optional strLit|] - <|> exactName "compile-scheme" *> [|PCompileScheme strLit|] - <|> exactName "main" $> PMain - <|> do other <- qname - fatalError "unknown declaration flag \{show other}" {c = False} +findDups : List PAttr -> List String +findDups attrs = + SortedSet.toList $ snd $ foldl check (empty, empty) attrs +where + Seen = SortedSet String; Dups = SortedSet String + check : (Seen, Dups) -> PAttr -> (Seen, Dups) + check (seen, dups) (PA a _ _) = + (insert a seen, if contains a seen then insert a dups else dups) export -decl : FileName -> Grammar True PDecl +noDups : List PAttr -> Grammar False () +noDups attrs = do + let dups = findDups attrs + when (not $ null dups) $ + fatalError "duplicate attribute names: \{joinBy "," dups}" + +export +attrList : FileName -> Grammar False (List PAttr) +attrList fname = do + res <- many $ attr fname + noDups res $> res + +public export +data AttrMatch a = Matched a | NoMatch String | Malformed String String + +export +Functor AttrMatch where + map f (Matched x) = Matched $ f x + map f (NoMatch s) = NoMatch s + map f (Malformed a e) = Malformed a e + +export +(<|>) : AttrMatch a -> AttrMatch a -> AttrMatch a +Matched x <|> _ = Matched x +NoMatch _ <|> y = y +Malformed a e <|> _ = Malformed a e + +export +isFail : PAttr -> AttrMatch PFail +isFail (PA "fail" [] _) = Matched PFailAny +isFail (PA "fail" [Str s _] _) = Matched $ PFailMatch s +isFail (PA "fail" _ _) = Malformed "fail" "be absent or a string literal" +isFail a = NoMatch a.name + +export +isMain : PAttr -> AttrMatch () +isMain (PA "main" [] _) = Matched () +isMain (PA "main" _ _) = Malformed "main" "have no arguments" +isMain a = NoMatch a.name + +export +isScheme : PAttr -> AttrMatch String +isScheme (PA "compile-scheme" [Str s _] _) = Matched s +isScheme (PA "compile-scheme" _ _) = + Malformed "compile-scheme" "be a string literal" +isScheme a = NoMatch a.name + +export +matchAttr : String -> AttrMatch a -> Either String a +matchAttr _ (Matched x) = Right x +matchAttr d (NoMatch a) = Left "unrecognised \{d} attribute \{a}" +matchAttr _ (Malformed a s) = Left $ unlines + ["invalid \{a} attribute", "(should \{s})"] + +export +mkPDef : List PAttr -> PQty -> PBaseName -> PBody -> + Either String (Loc -> PDefinition) +mkPDef attrs qty name body = do + let start = MkPDef qty name body PSucceed False Nothing noLoc + res <- foldlM addAttr start attrs + pure $ \l => {loc_ := l} (the PDefinition res) +where + data PDefAttr = DefFail PFail | DefMain | DefScheme String + + isDefAttr : PAttr -> Either String PDefAttr + isDefAttr attr = matchAttr "definition" $ + DefFail <$> isFail attr + <|> DefMain <$ isMain attr + <|> DefScheme <$> isScheme attr + + addAttr : PDefinition -> PAttr -> Either String PDefinition + addAttr def attr = + case !(isDefAttr attr) of + DefFail f => pure $ {fail := f} def + DefMain => pure $ {main := True} def + DefScheme str => pure $ {scheme := Just str} def + +export +mkPNamespace : List PAttr -> Mods -> List PDecl -> + Either String (Loc -> PNamespace) +mkPNamespace attrs name decls = do + let start = MkPNamespace name decls PSucceed noLoc + res <- foldlM addAttr start attrs + pure $ \l => {loc_ := l} (the PNamespace res) +where + isNsAttr = matchAttr "namespace" . isFail + + addAttr : PNamespace -> PAttr -> Either String PNamespace + addAttr ns attr = pure $ {fail := !(isNsAttr attr)} ns ||| `def` alone means `defω`; same for `postulate` export @@ -624,43 +717,55 @@ postulateIntro : FileName -> Grammar True PQty postulateIntro = defIntro' "postulate" "postulate0" "postulateω" export -postulate : FileName -> Grammar True PDefinition -postulate fname = withLoc fname $ Core.do +postulate : FileName -> List PAttr -> Grammar True PDefinition +postulate fname attrs = withLoc fname $ do qty <- postulateIntro fname name <- baseName type <- resC ":" *> mustWork (term fname) - pure $ MkPDef qty name $ PPostulate type + optRes ";" + either fatalError pure $ mkPDef attrs qty name $ PPostulate type export -concrete : FileName -> Grammar True PDefinition -concrete fname = withLoc fname $ do +concrete : FileName -> List PAttr -> Grammar True PDefinition +concrete fname attrs = withLoc fname $ do qty <- defIntro fname name <- baseName type <- optional $ resC ":" *> mustWork (term fname) term <- needRes "=" *> mustWork (term fname) optRes ";" - pure $ MkPDef qty name $ PConcrete type term + either fatalError pure $ mkPDef attrs qty name $ PConcrete type term export -definition : FileName -> Grammar True PDefinition -definition fname = try (postulate fname) <|> concrete fname +definition : FileName -> List PAttr -> Grammar True PDefinition +definition fname attrs = + try (postulate fname attrs) <|> concrete fname attrs export -namespace_ : FileName -> Grammar True PNamespace -namespace_ fname = withLoc fname $ do - ns <- resC "namespace" *> qname; needRes "{" - decls <- nsInner; optRes ";" - pure $ MkPNamespace (ns.mods :< ns.base) decls +nsname : Grammar True Mods +nsname = do ns <- qname; pure $ ns.mods :< ns.base + + +export +decl : FileName -> Grammar True PDecl + +export +namespace_ : FileName -> List PAttr -> Grammar True PNamespace +namespace_ fname attrs = withLoc fname $ do + ns <- resC "namespace" *> nsname; needRes "{" + decls <- nsInner + either fatalError pure $ mkPNamespace attrs ns decls where nsInner : Grammar True (List PDecl) nsInner = [] <$ resC "}" <|> [|(assert_total decl fname <* commit) :: assert_total nsInner|] export -declBody : FileName -> Grammar True PDeclBody -declBody fname = [|PDef $ definition fname|] <|> [|PNs $ namespace_ fname|] +declBody : FileName -> List PAttr -> Grammar True PDecl +declBody fname attrs = + [|PDef $ definition fname attrs|] <|> [|PNs $ namespace_ fname attrs|] -decl fname = withLoc fname [|MkPDecl (many declMod) (declBody fname)|] +-- decl : FileName -> Grammar True PDecl +decl fname = attrList fname >>= declBody fname export load : FileName -> Grammar True PTopLevel diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index 2b7e19c..3265fd2 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -159,58 +159,51 @@ data PBody = PConcrete (Maybe PTerm) PTerm | PPostulate PTerm %runElab derive "PBody" [Eq, Ord, Show, PrettyVal] +public export +data PFail = + PSucceed +| PFailAny +| PFailMatch String +%runElab derive "PFail" [Eq, Ord, Show, PrettyVal] + public export record PDefinition where constructor MkPDef - qty : PQty - name : PBaseName - body : PBody - loc_ : Loc + qty : PQty + name : PBaseName + body : PBody + fail : PFail + main : Bool + scheme : Maybe String + loc_ : Loc %name PDefinition def %runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal] export Located PDefinition where def.loc = def.loc_ -public export -data PDeclMod = - PFail (Maybe String) - | PCompileScheme String - | PMain -%name PDeclMod mod -%runElab derive "PDeclMod" [Eq, Ord, Show, PrettyVal] - mutual public export record PNamespace where constructor MkPNamespace name : Mods decls : List PDecl + fail : PFail loc_ : Loc %name PNamespace ns public export - record PDecl where - constructor MkPDecl - mods : List PDeclMod - decl : PDeclBody - loc_ : Loc - - public export - data PDeclBody = - PDef PDefinition - | PNs PNamespace - %name PDeclBody decl -%runElab deriveMutual ["PNamespace", "PDecl", "PDeclBody"] - [Eq, Ord, Show, PrettyVal] + data PDecl = + PDef PDefinition + | PNs PNamespace + %name PDecl decl +%runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal] export Located PNamespace where ns.loc = ns.loc_ -export Located PDecl where decl.loc = decl.loc_ - export -Located PDeclBody where - (PDef def).loc = def.loc - (PNs ns).loc = ns.loc +Located PDecl where + (PDef d).loc = d.loc + (PNs ns).loc = ns.loc public export data PTopLevel = PD PDecl | PLoad String Loc @@ -223,6 +216,18 @@ Located PTopLevel where (PLoad _ loc).loc = loc +public export +record PAttr where + constructor PA + name : PBaseName + args : List PTerm + loc_ : Loc +%name PAttr attr +%runElab derive "PAttr" [Eq, Ord, Show, PrettyVal] + +export Located PAttr where attr.loc = attr.loc_ + + public export PFile : Type PFile = List PTopLevel diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index 299c905..4736e89 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -395,36 +395,37 @@ tests = "parser" :- [ parseFails term "caseω n return ℕ of { succ ⇒ 5 }" ], - "definitions" :- [ + "definitions" :- + let definition = flip definition [] in [ parseMatch definition "defω x : {a} × {b} = ('a, 'b);" `(MkPDef (PQ Any _) "x" (PConcrete (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) - (Pair (Tag "a" _) (Tag "b" _) _)) _), + (Pair (Tag "a" _) (Tag "b" _) _)) _ _ _ _), parseMatch definition "def# x : {a} ** {b} = ('a, 'b)" `(MkPDef (PQ Any _) "x" (PConcrete (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) - (Pair (Tag "a" _) (Tag "b" _) _)) _), + (Pair (Tag "a" _) (Tag "b" _) _)) _ _ _ _), parseMatch definition "def ω.x : {a} × {b} = ('a, 'b)" `(MkPDef (PQ Any _) "x" (PConcrete (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) - (Pair (Tag "a" _) (Tag "b" _) _)) _), + (Pair (Tag "a" _) (Tag "b" _) _)) _ _ _ _), parseMatch definition "def x : {a} × {b} = ('a, 'b)" `(MkPDef (PQ Any _) "x" (PConcrete (Just (Sig (Unused _) (Enum ["a"] _) (Enum ["b"] _) _)) - (Pair (Tag "a" _) (Tag "b" _) _)) _), + (Pair (Tag "a" _) (Tag "b" _) _)) _ _ _ _), parseMatch definition "def0 A : ★⁰ = {a, b, c}" `(MkPDef (PQ Zero _) "A" - (PConcrete (Just $ TYPE 0 _) (Enum ["a", "b", "c"] _)) _), + (PConcrete (Just $ TYPE 0 _) (Enum ["a", "b", "c"] _)) _ _ _ _), parseMatch definition "postulate yeah : ℕ" - `(MkPDef (PQ Any _) "yeah" (PPostulate (NAT _)) _), + `(MkPDef (PQ Any _) "yeah" (PPostulate (NAT _)) _ _ _ _), parseMatch definition "postulateω yeah : ℕ" - `(MkPDef (PQ Any _) "yeah" (PPostulate (NAT _)) _), + `(MkPDef (PQ Any _) "yeah" (PPostulate (NAT _)) _ _ _ _), parseMatch definition "postulate0 FileHandle : ★" - `(MkPDef (PQ Zero _) "FileHandle" (PPostulate (TYPE 0 _)) _), + `(MkPDef (PQ Zero _) "FileHandle" (PPostulate (TYPE 0 _)) _ _ _ _), parseFails definition "postulate not-a-postulate : ℕ = 69", parseFails definition "postulate not-a-postulate = 69", parseFails definition "def not-a-def : ℕ" @@ -432,52 +433,44 @@ tests = "parser" :- [ "top level" :- [ parseMatch input "def0 A : ★⁰ = {}; def0 B : ★¹ = A;" - `([PD $ MkPDecl [] - (PDef $ MkPDef (PQ Zero _) "A" - (PConcrete (Just $ TYPE 0 _) (Enum [] _)) _) _, - PD $ MkPDecl [] - (PDef $ MkPDef (PQ Zero _) "B" - (PConcrete (Just $ TYPE 1 _) (V "A" {})) _) _]), + `([PD $ PDef $ MkPDef (PQ Zero _) "A" + (PConcrete (Just $ TYPE 0 _) (Enum [] _)) PSucceed False Nothing _, + PD $ PDef $ MkPDef (PQ Zero _) "B" + (PConcrete (Just $ TYPE 1 _) (V "A" {})) PSucceed False Nothing _]), parseMatch input "def0 A : ★⁰ = {} def0 B : ★¹ = A" $ - `([PD $ MkPDecl [] - (PDef $ MkPDef (PQ Zero _) "A" - (PConcrete (Just $ TYPE 0 _) (Enum [] _)) _) _, - PD $ MkPDecl [] - (PDef $ MkPDef (PQ Zero _) "B" - (PConcrete (Just $ TYPE 1 _) (V "A" {})) _) _]), + `([PD $ PDef $ MkPDef (PQ Zero _) "A" + (PConcrete (Just $ TYPE 0 _) (Enum [] _)) PSucceed False Nothing _, + PD $ PDef $ MkPDef (PQ Zero _) "B" + (PConcrete (Just $ TYPE 1 _) (V "A" {})) PSucceed False Nothing _]), note "empty input", parsesAs input "" [], parseFails input ";;;;;;;;;;;;;;;;;;;;;;;;;;", parseMatch input "namespace a {}" - `([PD $ MkPDecl [] (PNs $ MkPNamespace [< "a"] [] _) _]), + `([PD $ PNs $ MkPNamespace [< "a"] [] PSucceed _]), parseMatch input "namespace a.b.c {}" - `([PD $ MkPDecl [] - (PNs $ MkPNamespace [< "a", "b", "c"] [] _) _]), + `([PD $ PNs $ MkPNamespace [< "a", "b", "c"] [] PSucceed _]), parseMatch input "namespace a {namespace b {}}" - `([PD (MkPDecl [] - (PNs $ MkPNamespace [< "a"] - [MkPDecl [] (PNs $ MkPNamespace [< "b"] [] _) _] _) _)]), + `([PD (PNs $ MkPNamespace [< "a"] + [PNs $ MkPNamespace [< "b"] [] PSucceed _] PSucceed _)]), parseMatch input "namespace a {def x = 't ∷ {t}}" - `([PD (MkPDecl [] - (PNs $ MkPNamespace [< "a"] - [MkPDecl [] - (PDef $ MkPDef (PQ Any _) "x" - (PConcrete Nothing - (Ann (Tag "t" _) (Enum ["t"] _) _)) _) _] _) _)]), + `([PD (PNs $ MkPNamespace [< "a"] + [PDef $ MkPDef (PQ Any _) "x" + (PConcrete Nothing (Ann (Tag "t" _) (Enum ["t"] _) _)) + PSucceed False Nothing _] + PSucceed _)]), parseMatch input "namespace a {def x : {t} = 't} def y = a.x" - `([PD (MkPDecl [] - (PNs $ MkPNamespace [< "a"] - [MkPDecl [] - (PDef $ MkPDef (PQ Any _) "x" - (PConcrete (Just (Enum ["t"] _)) - (Tag "t" _)) _) _] _) _), - PD (MkPDecl [] - (PDef $ MkPDef (PQ Any _) "y" - (PConcrete Nothing (V (MakePName [< "a"] "x") Nothing _)) _) _)]), + `([PD (PNs $ MkPNamespace [< "a"] + [PDef $ MkPDef (PQ Any _) "x" + (PConcrete (Just (Enum ["t"] _)) (Tag "t" _)) + PSucceed False Nothing _] + PSucceed _), + PD (PDef $ MkPDef (PQ Any _) "y" + (PConcrete Nothing (V (MakePName [< "a"] "x") Nothing _)) + PSucceed False Nothing _)]), parseMatch input #" load "a.quox"; def b = a.b "# `([PLoad "a.quox" _, - PD (MkPDecl [] - (PDef $ MkPDef (PQ Any _) "b" - (PConcrete Nothing (V (MakePName [< "a"] "b") Nothing _)) _) _)]) + PD (PDef $ MkPDef (PQ Any _) "b" + (PConcrete Nothing (V (MakePName [< "a"] "b") Nothing _)) + PSucceed False Nothing _)]) ] ] From cc78ccd940f113d70eff06d98b535db08501ffcb Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 6 Nov 2023 22:11:11 +0100 Subject: [PATCH 056/133] fix some parenthesisation --- lib/Quox/Syntax/Term/Pretty.idr | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index ae2b565..7b9f89e 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -431,7 +431,7 @@ prettyTerm dnames tnames (Eq (S _ (N ty)) l r _) = pure $ sep [l <++> !eqndD, r <++> !colonD, ty] prettyTerm dnames tnames (Eq ty l r _) = - parensIfM Arg =<< do + parensIfM App =<< do ty <- prettyTypeLine dnames tnames ty l <- withPrec Arg $ prettyTerm dnames tnames l r <- withPrec Arg $ prettyTerm dnames tnames r @@ -443,6 +443,7 @@ prettyTerm dnames tnames s@(DLam {}) = prettyTerm dnames tnames (NAT _) = natD prettyTerm dnames tnames (Nat n _) = hl Syntax $ pshow n prettyTerm dnames tnames (Succ p _) = + parensIfM App =<< prettyAppD !succD [!(withPrec Arg $ prettyTerm dnames tnames p)] prettyTerm dnames tnames (STRING _) = stringD From d115672d49527e4112619153f11755da76a25d8b Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 10 Nov 2023 15:07:19 +0100 Subject: [PATCH 057/133] example stuff --- examples/hello.quox | 2 -- examples/misc.quox | 5 +++++ examples/nat.quox | 52 ++++++++++++++++++++++++++++++++++++--------- examples/qty.quox | 10 ++++++--- 4 files changed, 54 insertions(+), 15 deletions(-) diff --git a/examples/hello.quox b/examples/hello.quox index e1f2052..3b7122e 100644 --- a/examples/hello.quox +++ b/examples/hello.quox @@ -3,8 +3,6 @@ def0 Unit : ★ = {tt} def drop-unit : 0.(A : ★) → Unit → A → A = λ A u x ⇒ case u return A of {'tt ⇒ x} --- postulate0 IOState : ★ - def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B = diff --git a/examples/misc.quox b/examples/misc.quox index bf24d39..8afbde9 100644 --- a/examples/misc.quox +++ b/examples/misc.quox @@ -14,6 +14,11 @@ def0 cong : (x y : A) → (xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) (p x) (p y) = λ A P p x y xy ⇒ δ 𝑖 ⇒ p (xy @𝑖) +def0 cong' : + (A B : ★) → (f : A → B) → + (x y : A) → (xy : x ≡ y : A) → f x ≡ f y : B = + λ A B ⇒ cong A (λ _ ⇒ B) + def0 coherence : (A B : ★) → (AB : A ≡ B : ★) → (x : A) → Eq (𝑖 ⇒ AB @𝑖) x (coe (𝑖 ⇒ AB @𝑖) x) = diff --git a/examples/nat.quox b/examples/nat.quox index f52c768..3b9894a 100644 --- a/examples/nat.quox +++ b/examples/nat.quox @@ -4,12 +4,27 @@ load "either.quox"; namespace nat { +def elim-0-1 : + 0.(P : ℕ → ★) → + ω.(P 0) → ω.(P 1) → + ω.(0.(n : ℕ) → P n → P (succ n)) → + (n : ℕ) → P n = + λ P p0 p1 ps n ⇒ + case n return n' ⇒ P n' of { + zero ⇒ p0; + succ n' ⇒ + case n' return n'' ⇒ P (succ n'') of { + zero ⇒ p1; + succ n'', IH ⇒ ps (succ n'') IH + } + } + #[compile-scheme "(lambda (n) (cons n 'erased))"] def dup! : (n : ℕ) → [ω. Sing ℕ n] = λ n ⇒ case n return n' ⇒ [ω. Sing ℕ n'] of { zero ⇒ [(zero, [δ _ ⇒ zero])]; - succ n, 1.d ⇒ + succ n, d ⇒ appω (Sing ℕ n) (Sing ℕ (succ n)) (sing.app ℕ ℕ n (λ n ⇒ succ n)) d }; @@ -21,16 +36,16 @@ def dup : ℕ → [ω.ℕ] = def plus : ℕ → ℕ → ℕ = λ m n ⇒ case m return ℕ of { - zero ⇒ n; - succ _, 1.p ⇒ succ p + zero ⇒ n; + succ _, p ⇒ succ p }; #[compile-scheme "(lambda% (m n) (* m n))"] def timesω : ℕ → ω.ℕ → ℕ = λ m n ⇒ case m return ℕ of { - zero ⇒ zero; - succ _, 1.t ⇒ plus n t + zero ⇒ zero; + succ _, t ⇒ plus n t }; def times : ℕ → ℕ → ℕ = @@ -106,25 +121,42 @@ def eqb : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ dec.bool (m ≡ n : ℕ) (eq? def0 plus-zero : (m : ℕ) → m ≡ plus m 0 : ℕ = λ m ⇒ case m return m' ⇒ m' ≡ plus m' 0 : ℕ of { - zero ⇒ δ _ ⇒ zero; - succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖) + zero ⇒ δ _ ⇒ 0; + succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖) }; def0 plus-succ : (m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ = λ m n ⇒ case m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : ℕ of { - zero ⇒ δ _ ⇒ succ n; - succ _, ω.ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖) + zero ⇒ δ _ ⇒ succ n; + succ _, ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖) }; def0 plus-comm : (m n : ℕ) → plus m n ≡ plus n m : ℕ = λ m n ⇒ case m return m' ⇒ plus m' n ≡ plus n m' : ℕ of { zero ⇒ plus-zero n; - succ m', ω.ih ⇒ + succ m', ih ⇒ trans ℕ (succ (plus m' n)) (succ (plus n m')) (plus n (succ m')) (δ 𝑖 ⇒ succ (ih @𝑖)) (plus-succ n m') }; +def0 times-zero : (m : ℕ) → 0 ≡ timesω m 0 : ℕ = + λ m ⇒ + case m return m' ⇒ 0 ≡ timesω m' 0 : ℕ of { + zero ⇒ δ _ ⇒ zero; + succ m', ih ⇒ ih + }; + +def0 times-succ : (m n : ℕ) → plus m (timesω m n) ≡ timesω m (succ n) : ℕ = + λ m n ⇒ + case m + return m' ⇒ plus m' (timesω m' n) ≡ timesω m' (succ n) : ℕ + of { + zero ⇒ δ _ ⇒ 0; + succ m', ih ⇒ + δ 𝑖 ⇒ plus (succ n) (ih @𝑖) + }; + } diff --git a/examples/qty.quox b/examples/qty.quox index 26a1a8b..9f5e529 100644 --- a/examples/qty.quox +++ b/examples/qty.quox @@ -61,13 +61,17 @@ def0 unbox : (π : Qty) → (A : ★) → Box π A → A = 'any ⇒ λ x ⇒ case x return A of { [x] ⇒ x }; } +def0 unbox0 = unbox 'zero +def0 unbox1 = unbox 'one +def0 unboxω = unbox 'any + def apply : (π : Qty) → 0.(A : ★) → 0.(B : A → ★) → FUN π A B → (x : Box π A) → B (unbox π A x) = λ π A B ⇒ case π return π' ⇒ FUN π' A B → (x : Box π' A) → B (unbox π' A x) of { - 'zero ⇒ λ f x ⇒ case x return x' ⇒ B (unbox 'zero A x') of { [x] ⇒ f x }; - 'one ⇒ λ f x ⇒ case x return x' ⇒ B (unbox 'one A x') of { [x] ⇒ f x }; - 'any ⇒ λ f x ⇒ case x return x' ⇒ B (unbox 'any A x') of { [x] ⇒ f x }; + 'zero ⇒ λ f x ⇒ case x return x' ⇒ B (unbox0 A x') of { [x] ⇒ f x }; + 'one ⇒ λ f x ⇒ case x return x' ⇒ B (unbox1 A x') of { [x] ⇒ f x }; + 'any ⇒ λ f x ⇒ case x return x' ⇒ B (unboxω A x') of { [x] ⇒ f x }; } From 310822ffa55f1d53238b0756bdaf4368cad32e51 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 16 Nov 2023 18:32:38 +0100 Subject: [PATCH 058/133] remove old replaced stuff --- tests/on-hold/Tests/Lexer.idr | 144 -------------------------------- tests/on-hold/Tests/Parser.idr | 144 -------------------------------- tests/on-hold/Tests/Unicode.idr | 90 -------------------- 3 files changed, 378 deletions(-) delete mode 100644 tests/on-hold/Tests/Lexer.idr delete mode 100644 tests/on-hold/Tests/Parser.idr delete mode 100644 tests/on-hold/Tests/Unicode.idr diff --git a/tests/on-hold/Tests/Lexer.idr b/tests/on-hold/Tests/Lexer.idr deleted file mode 100644 index c432360..0000000 --- a/tests/on-hold/Tests/Lexer.idr +++ /dev/null @@ -1,144 +0,0 @@ -module Tests.Lexer - -import Quox.Lexer -import TAP - - -RealError = Quox.Lexer.Error -%hide Quox.Lexer.Error - -export -ToInfo RealError where - toInfo (Err reason line col char) = - [("reason", show reason), - ("line", show line), - ("col", show col), - ("char", show char)] - -data Error -= LexerError RealError -| WrongAnswer (List Token) (List Token) -| TestFailed (List Token) - -ToInfo Error where - toInfo (LexerError err) = toInfo err - toInfo (WrongAnswer exp got) = - [("expected", show exp), ("received", show got)] - toInfo (TestFailed got) = - [("failed", show got)] - - -lex' : String -> Either Error (List Token) -lex' = bimap LexerError (map val) . lex - -parameters (label : String) (input : String) - acceptsSuchThat' : (List Token -> Maybe Error) -> Test - acceptsSuchThat' p = test label $ delay $ do - res <- bimap LexerError (map val) $ lex input - case p res of - Just err => throwError err - Nothing => pure () - - acceptsSuchThat : (List Token -> Bool) -> Test - acceptsSuchThat p = acceptsSuchThat' $ \res => - if p res then Nothing else Just $ TestFailed res - - acceptsWith : List Token -> Test - acceptsWith expect = acceptsSuchThat' $ \res => - if res == expect then Nothing else Just $ WrongAnswer expect res - - accepts : Test - accepts = acceptsSuchThat $ const True - - rejects : Test - rejects = testThrows label (\case LexerError _ => True; _ => False) $ delay $ - bimap LexerError (map val) $ lex input - -parameters (input : String) {default False esc : Bool} - show' : String -> String - show' s = if esc then show s else "\"\{s}\"" - - acceptsWith' : List Token -> Test - acceptsWith' = acceptsWith (show' input) input - - accepts' : Test - accepts' = accepts (show' input) input - - rejects' : Test - rejects' = rejects "\{show' input} (reject)" input - - -tests = "lexer" :- [ - "comments" :- [ - acceptsWith' "" [], - acceptsWith' " \n \t\t " [] {esc = True}, - acceptsWith' "-- a" [], - acceptsWith' "{- -}" [], - acceptsWith' "{--}" [], - acceptsWith' "{------}" [], - acceptsWith' "{- {- -} -}" [], - acceptsWith' "{- } -}" [], - rejects' "{-}", - rejects' "{- {- -}", - acceptsWith' "( -- comment \n )" [P LParen, P RParen] {esc = True} - ], - - "punctuation" :- [ - acceptsWith' "({[:,]})" - [P LParen, P LBrace, P LSquare, - P Colon, P Comma, - P RSquare, P RBrace, P RParen], - acceptsWith' " ( { [ : , ] } ) " - [P LParen, P LBrace, P LSquare, - P Colon, P Comma, - P RSquare, P RBrace, P RParen], - acceptsWith' "→ ⇒ × ⊲ ∷" - [P Arrow, P DblArrow, P Times, P Triangle, P DblColon], - acceptsWith' "_" [P Wild] - ], - - "names & symbols" :- [ - acceptsWith' "a" [Name "a"], - acceptsWith' "abc" [Name "abc"], - acceptsWith' "_a" [Name "_a"], - acceptsWith' "a_" [Name "a_"], - acceptsWith' "a_b" [Name "a_b"], - acceptsWith' "abc'" [Name "abc'"], - acceptsWith' "a'b'c''" [Name "a'b'c''"], - acceptsWith' "abc123" [Name "abc123"], - acceptsWith' "_1" [Name "_1"], - acceptsWith' "ab cd" [Name "ab", Name "cd"], - acceptsWith' "ab{--}cd" [Name "ab", Name "cd"], - acceptsWith' "'a" [Symbol "a"], - acceptsWith' "'ab" [Symbol "ab"], - acceptsWith' "'_b" [Symbol "_b"], - acceptsWith' "a.b.c" [Name "a", P Dot, Name "b", P Dot, Name "c"], - rejects' "'", - rejects' "1abc" - ], - - "keywords" :- [ - acceptsWith' "λ" [K Lam], - acceptsWith' "let" [K Let], - acceptsWith' "in" [K In], - acceptsWith' "case" [K Case], - acceptsWith' "of" [K Of], - acceptsWith' "ω" [K Omega], - acceptsWith' "Π" [K Pi], - acceptsWith' "Σ" [K Sigma], - acceptsWith' "W" [K W], - acceptsWith' "WAAA" [Name "WAAA"] - ], - - "universes" :- [ - acceptsWith' "★10" [TYPE 10], - rejects' "★" - ], - - "numbers" :- [ - acceptsWith' "0" [N Zero], - acceptsWith' "1" [N One], - acceptsWith' "2" [N $ Other 2], - acceptsWith' "69" [N $ Other 69] - ] -] diff --git a/tests/on-hold/Tests/Parser.idr b/tests/on-hold/Tests/Parser.idr deleted file mode 100644 index d335a7a..0000000 --- a/tests/on-hold/Tests/Parser.idr +++ /dev/null @@ -1,144 +0,0 @@ -module Tests.Parser - -import Quox.Syntax -import Quox.Parser -import Quox.Lexer -import Tests.Lexer -import Quox.Pretty - -import TermImpls -import Data.SnocVect -import Text.Parser -import TAP - - -export -Show tok => ToInfo (ParsingError tok) where - toInfo (Error msg Nothing) = [("msg", msg)] - toInfo (Error msg (Just loc)) = [("loc", show loc), ("msg", msg)] - - -numberErrs : List1 Info -> Info -numberErrs (head ::: []) = head -numberErrs (head ::: tail) = go 0 (head :: tail) where - number1 : Nat -> Info -> Info - number1 n = map $ \(k, v) => (show n ++ k, v) - - go : Nat -> List Info -> Info - go k [] = [] - go k (x :: xs) = number1 k x ++ go (S k) xs - -export -ToInfo Parser.Error where - toInfo (Lex err) = toInfo err - toInfo (Parse errs) = numberErrs $ map toInfo errs - toInfo (Leftover toks) = toInfo [("leftover", toks)] - - -RealError = Quox.Parser.Error -%hide Lexer.RealError -%hide Quox.Parser.Error - -data Error a -= Parser RealError -| Unexpected a a -| ShouldFail a - -export -Show a => ToInfo (Error a) where - toInfo (Parser err) = toInfo err - toInfo (Unexpected exp got) = toInfo $ - [("expected", exp), ("received", got)] - toInfo (ShouldFail got) = toInfo [("success", got)] - - -parameters {c : Bool} (grm : Grammar c a) (note : String) (input : String) - parsesNote : (Show a, Eq a) => a -> Test - parsesNote exp = test "\"\{input}\"\{note}" $ delay $ - case lexParseAll grm input of - Right got => if got == exp then Right () - else Left $ Unexpected exp got - Left err => Left $ Parser err - - rejectsNote : Show a => Test - rejectsNote = test "\"\{input}\"\{note} ‹reject›" $ do - case lexParseAll grm input of - Left err => Right () - Right val => Left $ ShouldFail val - -parameters {c : Bool} (grm : Grammar c a) (input : String) - parses : (Show a, Eq a) => a -> Test - parses = parsesNote grm "" input - - rejects : Show a => Test - rejects = rejectsNote grm "" input - -tests = "parser" :- [ - "numbers" :- - let parses = parses number - in [ - parses "0" 0, - parses "1" 1, - parses "1000" 1000 - ], - - "bound vars (x, y, z | a ⊢)" :- - let grm = bound "test" {bound = [< "x", "y", "z"], avoid = [< "a"]} - parses = parses grm; rejects = rejects grm; rejectsNote = rejectsNote grm - in [ - parses "x" (V 2), - parses "y" (V 1), - parses "z" (V 0), - rejects "M.x", - rejects "x.a", - rejectsNote " (avoid)" "a", - rejectsNote " (not in scope)" "c" - ], - - "bound or free vars (x, y, z ⊢)" :- - let parses = parses $ nameWith {bound = [< "x", "y", "z"], avoid = [<]} - in [ - parses "x" (Left (V 2)), - parses "y" (Left (V 1)), - parses "z" (Left (V 0)), - parses "a" (Right (MakeName [<] (UN "a"))), - parses "a.b.c" (Right (MakeName [< "a", "b"] (UN "c"))), - parses "a . b . c" (Right (MakeName [< "a", "b"] (UN "c"))), - parses "M.x" (Right (MakeName [< "M"] (UN "x"))), - parses "x.a" (Right (MakeName [< "x"] (UN "a"))) - ], - - "dimension (i, j | x, y, z ⊢)" :- - let grm = dimension {dvars = [< "i", "j"], tvars = [< "x", "y", "z"]} - parses = parses grm; rejects = rejects grm; rejectsNote = rejectsNote grm - in [ - parses "0" (K Zero), - parses "1" (K One), - rejects "2", - parses "i" (B (V 1)), - rejectsNote " (tvar)" "x", - rejectsNote " (not in scope)" "a" - ], - - "terms & elims (i, j | x, y, z ⊢)" :- - let dvars = [< "i", "j"]; tvars = [< "x", "y", "z"] - tgrm = term {dvars, tvars}; egrm = elim {dvars, tvars} - tparses = parsesNote tgrm " (term)" - eparses = parsesNote egrm " (elim)" - trejects = rejectsNote tgrm " (term)" - erejects = rejectsNote egrm " (elim)" - in [ - "universes" :- [ - tparses "★0" (TYPE 0), - tparses "★1000" (TYPE 1000) - ], - - "variables" :- [ - eparses "a" (F "a"), - eparses "x" (BV 2), - trejects "a", - tparses "[a]" (FT "a"), - tparses "[x]" (BVT 2) - ] - ] -] diff --git a/tests/on-hold/Tests/Unicode.idr b/tests/on-hold/Tests/Unicode.idr deleted file mode 100644 index e3b0c1c..0000000 --- a/tests/on-hold/Tests/Unicode.idr +++ /dev/null @@ -1,90 +0,0 @@ -module Tests.Unicode - -import Quox.NatExtra -import Quox.Unicode -import Data.List -import Data.String -import Data.Maybe -import TAP - - -maxLatin1 = '\xFF' - -escape : Char -> Maybe String -escape '\'' = Nothing -escape c = - if c > maxLatin1 then Nothing else - case unpack $ show c of - '\'' :: '\\' :: cs => pack . ('\\' ::) <$> init' cs - _ => Nothing - -codepoint : Char -> String -codepoint = padLeft 4 '0' . showHex . cast - -display : Char -> String -display c = - let c' = fromMaybe (singleton c) $ escape c in - if '\x20' <= c && c <= maxLatin1 - then "「\{c'}」" - else "「\{c'}」 (U+\{codepoint c})" - -displayS' : String -> String -displayS' = - foldMap (\c => if c <= maxLatin1 then singleton c else "\\x\{codepoint c}") . - unpack - -displayS : String -> String -displayS str = - if all (<= maxLatin1) (unpack str) - then "「\{str}」" - else "「\{str}」 (\"\{displayS' str}\")" - -testOneChar : (Char -> Bool) -> Char -> Test -testOneChar pred c = test (display c) $ unless (pred c) $ Left () - -testAllChars : String -> (Char -> Bool) -> List Char -> Test -testAllChars label pred chars = label :- map (testOneChar pred) chars - - -testNfc : String -> String -> Test -testNfc input result = - test (displayS input) $ - let norm = normalizeNfc input in - unless (norm == result) $ - Left [("expected", displayS result), ("received", displayS norm)] - -testAlreadyNfc : String -> Test -testAlreadyNfc input = testNfc input input - - - -tests = "unicode" :- [ - "general categories" :- [ - testAllChars "id starts" isIdStart - ['a', 'á', '𝕕', '개', 'ʨ', '𒁙', '𝟙'], - testAllChars "not id starts" (not . isIdStart) - ['0', '_', '-', '‿', ' ', '[', ',', '.', '\1'], - testAllChars "id continuations" isIdCont - ['a', 'á', '𝕕', '개', 'ʨ', '𒁙', '0', '\''], - testAllChars "not id continuations" (not . isIdCont) - ['_', '‿', ' ', '[', ',', '.', '\1'], - testAllChars "id connectors" isIdConnector - ['_', '‿'], - testAllChars "not id connectors" (not . isIdConnector) - ['a', ' ', ',', '-'], - testAllChars "white space" isWhitespace - [' ', '\t', '\r', '\n', - '\x2028', -- line separator - '\x2029' -- paragraph separator - ], - testAllChars "not white space" (not . isWhitespace) - ['a', '-', '_', '\1'] - ], - - "normalisation" :- [ - testNfc "e\x301" "é", - testAlreadyNfc "é", - testAlreadyNfc "" - -- idk if this is wrong it's chez's fault. or unicode's - ] -] From e2ad18ff1fefa913e884b236b0579df13a2e170c Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 16 Nov 2023 18:33:03 +0100 Subject: [PATCH 059/133] hello.quox tweaks --- examples/hello.quox | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/examples/hello.quox b/examples/hello.quox index 3b7122e..8e5dbf9 100644 --- a/examples/hello.quox +++ b/examples/hello.quox @@ -12,13 +12,13 @@ def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B = def seq : IO Unit → IO Unit → IO Unit = λ a b ⇒ bind Unit Unit a (λ u ⇒ drop-unit (IO Unit) u b) -#[compile-scheme "(lambda (n) (builtin-io (display n) (newline) 'tt))"] +#[compile-scheme "(lambda (n) (builtin-io (printf \"~d~n\" n) 'tt))"] postulate print-ℕ : ℕ → IO Unit -#[compile-scheme "(lambda (str) (builtin-io (display str) (newline) 'tt))"] +#[compile-scheme "(lambda (s) (builtin-io (printf \"~s~n\" s) 'tt))"] postulate print : String → IO Unit load "nat.quox" #[main] -def main = seq (print-ℕ (nat.plus 1000000000 1)) (print "(nice)") +def main = seq (print-ℕ (nat.plus 60 9)) (print "(nice)") From 4291afd51be5070a0a3f2b6df81e88c31a9776db Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 4 Dec 2023 18:21:27 +0100 Subject: [PATCH 060/133] allow fst/snd to take multiple arguments also succ though that won't be well typed --- lib/Quox/Parser/Parser.idr | 28 ++++++++++++++++------------ tests/Tests/Parser.idr | 10 +++++++++- 2 files changed, 25 insertions(+), 13 deletions(-) diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index de94618..c8b7192 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -381,11 +381,24 @@ eqTerm : FileName -> Grammar True PTerm eqTerm fname = withLoc fname $ resC "Eq" *> mustWork [|Eq (typeLine fname) (termArg fname) (termArg fname)|] +private +appArg : Loc -> PTerm -> Either PDim PTerm -> PTerm +appArg loc f (Left p) = DApp f p loc +appArg loc f (Right s) = App f s loc + +||| a dimension argument with an `@` prefix, or +||| a term argument with no prefix +export +anyArg : FileName -> Grammar True (Either PDim PTerm) +anyArg fname = dimArg fname <||> termArg fname + export resAppTerm : FileName -> (word : String) -> (0 _ : IsReserved word) => (PTerm -> Loc -> PTerm) -> Grammar True PTerm -resAppTerm fname word f = withLoc fname $ - resC word *> mustWork [|f (termArg fname)|] +resAppTerm fname word f = withLoc fname $ do + head <- withLoc fname $ resC word *> mustWork [|f (termArg fname)|] + args <- many $ anyArg fname + pure $ \loc => foldl (appArg loc) head args export succTerm : FileName -> Grammar True PTerm @@ -399,21 +412,12 @@ export sndTerm : FileName -> Grammar True PTerm sndTerm fname = resAppTerm fname "snd" Snd -||| a dimension argument with an `@` prefix, or -||| a term argument with no prefix -export -anyArg : FileName -> Grammar True (Either PDim PTerm) -anyArg fname = dimArg fname <||> termArg fname - export normalAppTerm : FileName -> Grammar True PTerm normalAppTerm fname = withLoc fname $ do head <- termArg fname args <- many $ anyArg fname - pure $ \loc => foldl (ap loc) head args -where ap : Loc -> PTerm -> Either PDim PTerm -> PTerm - ap loc f (Left p) = DApp f p loc - ap loc f (Right s) = App f s loc + pure $ \loc => foldl (appArg loc) head args ||| application term `f x @y z`, or other terms that look like application ||| like `succ` or `coe`. diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index 4736e89..26b327a 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -138,7 +138,15 @@ tests = "parser" :- [ parseMatch term "f @p" `(DApp (V "f" {}) (V "p" {}) _), parseMatch term "f x @p y" - `(App (DApp (App (V "f" {}) (V "x" {}) _) (V "p" {}) _) (V "y" {}) _) + `(App (DApp (App (V "f" {}) (V "x" {}) _) (V "p" {}) _) (V "y" {}) _), + parseMatch term "fst e" + `(Fst (V "e" {}) _), + parseMatch term "snd e" + `(Snd (V "e" {}) _), + parseMatch term "(fst e) x" + `(App (Fst (V "e" {}) _) (V "x" {}) _), + parseMatch term "fst e x" + `(App (Fst (V "e" {}) _) (V "x" {}) _) ], "annotations" :- [ From 59e7a457a6aadf02d505600605871c18f1e35de1 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 4 Dec 2023 18:28:57 +0100 Subject: [PATCH 061/133] let case be the head of an application too --- lib/Quox/Parser/Parser.idr | 118 +++++++++++++++++++------------------ tests/Tests/Parser.idr | 10 +++- 2 files changed, 71 insertions(+), 57 deletions(-) diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index c8b7192..b73044a 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -286,8 +286,66 @@ export universe1 : Grammar True Universe universe1 = universeTok <|> res "★" *> option 0 super -||| argument/atomic term: single-token terms, or those with delimiters e.g. -||| `[t]` + +public export +PCaseArm : Type +PCaseArm = (PCasePat, PTerm) + +export +caseArm : FileName -> Grammar True PCaseArm +caseArm fname = + [|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|] + +export +checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody +checkCaseArms loc [] = pure $ CaseEnum [] loc +checkCaseArms loc ((PPair x y _, rhs) :: rest) = + if null rest then pure $ CasePair (x, y) rhs loc + else fatalError "unexpected pattern after pair" +checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do + let rest = for rest $ \case + (PTag tag _, rhs) => Just (tag, rhs) + _ => Nothing + maybe (fatalError "expected all patterns to be tags") + (\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest +checkCaseArms loc ((PZero _, rhs1) :: rest) = do + let [(PSucc p q ih _, rhs2)] = rest + | _ => fatalError "expected succ pattern after zero" + pure $ CaseNat rhs1 (p, q, ih, rhs2) loc +checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do + let [(PZero _, rhs2)] = rest + | _ => fatalError "expected zero pattern after succ" + pure $ CaseNat rhs2 (p, q, ih, rhs1) loc +checkCaseArms loc ((PBox x _, rhs) :: rest) = + if null rest then pure $ CaseBox x rhs loc + else fatalError "unexpected pattern after box" + +export +caseBody : FileName -> Grammar True PCaseBody +caseBody fname = do + body <- bounds $ delimSep "{" "}" ";" $ caseArm fname + let loc = makeLoc fname body.bounds + checkCaseArms loc body.val + +export +caseReturn : FileName -> Grammar True (PatVar, PTerm) +caseReturn fname = do + x <- patVar fname <* resC "⇒" <|> unused fname + ret <- assert_total term fname + pure (x, ret) + +export +caseTerm : FileName -> Grammar True PTerm +caseTerm fname = withLoc fname $ do + qty <- caseIntro fname; commit + head <- mustWork $ assert_total term fname; needRes "return" + ret <- mustWork $ caseReturn fname; needRes "of" + body <- mustWork $ caseBody fname + pure $ Case qty head ret body + + +||| argument/atomic term: single-token terms, or those with delimiters +||| e.g. `[t]`. includes `case` because the end delimiter is the `}`. export termArg : FileName -> Grammar True PTerm termArg fname = withLoc fname $ @@ -302,6 +360,7 @@ termArg fname = withLoc fname $ <|> STRING <$ res "String" <|> [|Str strLit|] <|> [|V qname displacement|] + <|> const <$> caseTerm fname <|> const <$> tupleTerm fname export @@ -525,65 +584,12 @@ where makePi q doms cod loc = foldr (\(q, x, s), t => Pi q x s t loc) cod $ toDoms (toQty q) doms -public export -PCaseArm : Type -PCaseArm = (PCasePat, PTerm) + export -caseArm : FileName -> Grammar True PCaseArm -caseArm fname = - [|(,) (casePat fname) (needRes "⇒" *> assert_total term fname)|] - -export -checkCaseArms : Loc -> List PCaseArm -> Grammar False PCaseBody -checkCaseArms loc [] = pure $ CaseEnum [] loc -checkCaseArms loc ((PPair x y _, rhs) :: rest) = - if null rest then pure $ CasePair (x, y) rhs loc - else fatalError "unexpected pattern after pair" -checkCaseArms loc ((PTag tag _, rhs1) :: rest) = do - let rest = for rest $ \case - (PTag tag _, rhs) => Just (tag, rhs) - _ => Nothing - maybe (fatalError "expected all patterns to be tags") - (\rest => pure $ CaseEnum ((tag, rhs1) :: rest) loc) rest -checkCaseArms loc ((PZero _, rhs1) :: rest) = do - let [(PSucc p q ih _, rhs2)] = rest - | _ => fatalError "expected succ pattern after zero" - pure $ CaseNat rhs1 (p, q, ih, rhs2) loc -checkCaseArms loc ((PSucc p q ih _, rhs1) :: rest) = do - let [(PZero _, rhs2)] = rest - | _ => fatalError "expected zero pattern after succ" - pure $ CaseNat rhs2 (p, q, ih, rhs1) loc -checkCaseArms loc ((PBox x _, rhs) :: rest) = - if null rest then pure $ CaseBox x rhs loc - else fatalError "unexpected pattern after box" - -export -caseBody : FileName -> Grammar True PCaseBody -caseBody fname = do - body <- bounds $ delimSep "{" "}" ";" $ caseArm fname - let loc = makeLoc fname body.bounds - checkCaseArms loc body.val - -export -caseReturn : FileName -> Grammar True (PatVar, PTerm) -caseReturn fname = do - x <- patVar fname <* resC "⇒" <|> unused fname - ret <- assert_total term fname - pure (x, ret) - -export -caseTerm : FileName -> Grammar True PTerm -caseTerm fname = withLoc fname $ do - qty <- caseIntro fname; commit - head <- mustWork $ assert_total term fname; needRes "return" - ret <- mustWork $ caseReturn fname; needRes "of" - body <- mustWork $ caseBody fname - pure $ Case qty head ret body -- term : FileName -> Grammar True PTerm term fname = lamTerm fname - <|> caseTerm fname <|> piTerm fname <|> sigmaTerm fname diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index 26b327a..d27ee2b 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -400,7 +400,15 @@ tests = "parser" :- [ `(Case (PQ Any _) (V "n" {}) (Unused _, NAT _) (CaseNat (Nat 0 _) (Unused _, PQ One _, PV "ih" _, V "ih" {}) _) _), parseFails term "caseω n return A of { zero ⇒ a }", - parseFails term "caseω n return ℕ of { succ ⇒ 5 }" + parseFails term "caseω n return ℕ of { succ ⇒ 5 }", + parseMatch term + "case1 f s return x ⇒ A x of { (l, r) ⇒ r l } x" + `(App + (Case (PQ One _) (App (V "f" {}) (V "s" {}) _) + (PV "x" _, App (V "A" {}) (V "x" {}) _) + (CasePair (PV "l" _, PV "r" _) + (App (V "r" {}) (V "l" {}) _) _) _) + (V "x" {}) _) ], "definitions" :- From 68d8019f00dad77196a6f80c0d306e724fa7936f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 4 Dec 2023 18:48:25 +0100 Subject: [PATCH 062/133] add `let` to frontend syntax --- lib/Quox/Parser/FromParser.idr | 3 +++ lib/Quox/Parser/Lexer.idr | 3 +++ lib/Quox/Parser/Parser.idr | 15 +++++++++++++++ lib/Quox/Parser/Syntax.idr | 3 +++ tests/Tests/Lexer.idr | 7 +++++++ tests/Tests/Parser.idr | 24 ++++++++++++++++++++++++ 6 files changed, 55 insertions(+) diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index d96645c..75c2bdf 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -264,6 +264,9 @@ mutual <*> fromPTermDScope ds ns [< j1] val1 <*> pure loc + Let (qty, x, rhs) body loc => + ?fromPTerm_let + private fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n -> List (PTagVal, PTerm) -> diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index 7c4f26f..afd6df5 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -261,6 +261,9 @@ reserved = Word "caseω" `Or` Word "case#", Word1 "return", Word1 "of", + Word1 "let", Word1 "in", + Word1 "let0", Word1 "let1", + Word "letω" `Or` Word "let#", Word1 "fst", Word1 "snd", Word1 "_", Word1 "Eq", diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index b73044a..42e2170 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -585,13 +585,28 @@ where foldr (\(q, x, s), t => Pi q x s t loc) cod $ toDoms (toQty q) doms +letIntro : FileName -> Grammar True PQty +letIntro fname = + withLoc fname (PQ Zero <$ res "let0") + <|> withLoc fname (PQ One <$ res "let1") + <|> withLoc fname (PQ Any <$ res "letω") + <|> do resC "let" + qty fname <* needRes "." <|> defLoc fname (PQ One) export +letTerm : FileName -> Grammar True PTerm +letTerm fname = withLoc fname $ do + qty <- letIntro fname + x <- patVar fname <* mustWork (resC "=") + rhs <- assert_total term fname <* mustWork (resC "in") + body <- assert_total term fname + pure $ Let (qty, x, rhs) body -- term : FileName -> Grammar True PTerm term fname = lamTerm fname <|> piTerm fname <|> sigmaTerm fname + <|> letTerm fname export diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index 3265fd2..4011ac5 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -100,6 +100,8 @@ namespace PTerm | Coe (PatVar, PTerm) PDim PDim PTerm Loc | Comp (PatVar, PTerm) PDim PDim PTerm PDim (PatVar, PTerm) (PatVar, PTerm) Loc + + | Let (PQty, PatVar, PTerm) PTerm Loc %name PTerm s, t public export @@ -144,6 +146,7 @@ Located PTerm where (Ann _ _ loc).loc = loc (Coe _ _ _ _ loc).loc = loc (Comp _ _ _ _ _ _ _ loc).loc = loc + (Let _ _ loc).loc = loc export Located PCaseBody where diff --git a/tests/Tests/Lexer.idr b/tests/Tests/Lexer.idr index 499aab4..549de46 100644 --- a/tests/Tests/Lexer.idr +++ b/tests/Tests/Lexer.idr @@ -108,6 +108,13 @@ tests = "lexer" :- [ lexes "case0" [Reserved "case0"], lexes "case##" [Name "case##"], + lexes "let" [Reserved "let"], + lexes "letω" [Reserved "letω"], + lexes "let#" [Reserved "letω"], + lexes "let1" [Reserved "let1"], + lexes "let0" [Reserved "let0"], + lexes "let##" [Name "let##"], + lexes "_" [Reserved "_"], lexes "_a" [Name "_a"], lexes "a_" [Name "a_"], diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index d27ee2b..dc27730 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -411,6 +411,30 @@ tests = "parser" :- [ (V "x" {}) _) ], + "let" :- [ + parseMatch term "let x = y in z" + `(Let (PQ One _, PV "x" {}, V "y" {}) (V "z" {}) _), + parseMatch term "let0 x = y in z" + `(Let (PQ Zero _, PV "x" {}, V "y" {}) (V "z" {}) _), + parseMatch term "let1 x = y in z" + `(Let (PQ One _, PV "x" {}, V "y" {}) (V "z" {}) _), + parseMatch term "letω x = y in z" + `(Let (PQ Any _, PV "x" {}, V "y" {}) (V "z" {}) _), + parseMatch term "let x = y1 y2 in z1 z2" + `(Let (PQ One _, PV "x" {}, + (App (V "y1" {}) (V "y2" {}) _)) + (App (V "z1" {}) (V "z2" {}) _) _), + parseMatch term "let x = a in let y = b in z" + `(Let (PQ One _, PV "x" {}, V "a" {}) + (Let (PQ One _, PV "y" {}, V "b" {}) (V "z" {}) _) _), + parseMatch term "let x = y in z ∷ Z" + `(Let (PQ One _, PV "x" {}, V "y" {}) + (Ann (V "z" {}) (V "Z" {}) _) _), + parseMatch term "let x = y in z₁ ≡ z₂ : Z" + `(Let (PQ One _, PV "x" {}, V "y" {}) + (Eq (Unused _, V "Z" {}) (V "z₁" {}) (V "z₂" {}) _) _) + ], + "definitions" :- let definition = flip definition [] in [ parseMatch definition "defω x : {a} × {b} = ('a, 'b);" From b1699ce0226bf576ee2617b61fa0802ad28aad04 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 4 Dec 2023 22:47:52 +0100 Subject: [PATCH 063/133] add let to the core --- lib/Quox/Displace.idr | 2 + lib/Quox/FreeVars.idr | 82 +++++++-------- lib/Quox/Parser/FromParser.idr | 5 +- lib/Quox/Pretty.idr | 6 +- lib/Quox/Syntax/Term/Base.idr | 5 + lib/Quox/Syntax/Term/Pretty.idr | 46 +++++++++ lib/Quox/Syntax/Term/Subst.idr | 171 ++++++++++++++++--------------- lib/Quox/Syntax/Term/Tighten.idr | 8 +- lib/Quox/Typechecker.idr | 12 +++ lib/Quox/Untyped/Erase.idr | 19 ++++ lib/Quox/Untyped/Syntax.idr | 5 - lib/Quox/Whnf/Interface.idr | 4 + lib/Quox/Whnf/Main.idr | 5 +- 13 files changed, 234 insertions(+), 136 deletions(-) diff --git a/lib/Quox/Displace.idr b/lib/Quox/Displace.idr index 3ac9907..6f8e1ed 100644 --- a/lib/Quox/Displace.idr +++ b/lib/Quox/Displace.idr @@ -34,6 +34,8 @@ parameters (k : Universe) doDisplace (Str s loc) = Str s loc doDisplace (BOX qty ty loc) = BOX qty (doDisplace ty) loc doDisplace (Box val loc) = Box (doDisplace val) loc + doDisplace (Let qty rhs body loc) = + Let qty (doDisplace rhs) (doDisplaceS body) loc doDisplace (E e) = E (doDisplace e) doDisplace (CloT (Sub t th)) = CloT (Sub (doDisplace t) (assert_total $ map doDisplace th)) diff --git a/lib/Quox/FreeVars.idr b/lib/Quox/FreeVars.idr index 00ff22d..29c08ca 100644 --- a/lib/Quox/FreeVars.idr +++ b/lib/Quox/FreeVars.idr @@ -180,26 +180,27 @@ export HasFreeVars (Elim d) export HasFreeVars (Term d) where - fv (TYPE {}) = none - fv (IOState {}) = none - fv (Pi {arg, res, _}) = fv arg <+> fv res - fv (Lam {body, _}) = fv body - fv (Sig {fst, snd, _}) = fv fst <+> fv snd - fv (Pair {fst, snd, _}) = fv fst <+> fv snd - fv (Enum {}) = none - fv (Tag {}) = none - fv (Eq {ty, l, r, _}) = fvD ty <+> fv l <+> fv r - fv (DLam {body, _}) = fvD body - fv (NAT {}) = none - fv (Nat {}) = none - fv (Succ {p, _}) = fv p - fv (STRING {}) = none - fv (Str {}) = none - fv (BOX {ty, _}) = fv ty - fv (Box {val, _}) = fv val - fv (E e) = fv e - fv (CloT s) = fv s - fv (DCloT s) = fv s.term + fv (TYPE {}) = none + fv (IOState {}) = none + fv (Pi {arg, res, _}) = fv arg <+> fv res + fv (Lam {body, _}) = fv body + fv (Sig {fst, snd, _}) = fv fst <+> fv snd + fv (Pair {fst, snd, _}) = fv fst <+> fv snd + fv (Enum {}) = none + fv (Tag {}) = none + fv (Eq {ty, l, r, _}) = fvD ty <+> fv l <+> fv r + fv (DLam {body, _}) = fvD body + fv (NAT {}) = none + fv (Nat {}) = none + fv (Succ {p, _}) = fv p + fv (STRING {}) = none + fv (Str {}) = none + fv (BOX {ty, _}) = fv ty + fv (Box {val, _}) = fv val + fv (Let {rhs, body, _}) = fv rhs <+> fv body + fv (E e) = fv e + fv (CloT s) = fv s + fv (DCloT s) = fv s.term export HasFreeVars (Elim d) where @@ -258,26 +259,27 @@ export HasFreeDVars Elim export HasFreeDVars Term where - fdv (TYPE {}) = none - fdv (IOState {}) = none - fdv (Pi {arg, res, _}) = fdv arg <+> fdvT res - fdv (Lam {body, _}) = fdvT body - fdv (Sig {fst, snd, _}) = fdv fst <+> fdvT snd - fdv (Pair {fst, snd, _}) = fdv fst <+> fdv snd - fdv (Enum {}) = none - fdv (Tag {}) = none - fdv (Eq {ty, l, r, _}) = fdv @{DScope} ty <+> fdv l <+> fdv r - fdv (DLam {body, _}) = fdv @{DScope} body - fdv (NAT {}) = none - fdv (Nat {}) = none - fdv (Succ {p, _}) = fdv p - fdv (STRING {}) = none - fdv (Str {}) = none - fdv (BOX {ty, _}) = fdv ty - fdv (Box {val, _}) = fdv val - fdv (E e) = fdv e - fdv (CloT s) = fdv s @{WithSubst} - fdv (DCloT s) = fdvSubst s + fdv (TYPE {}) = none + fdv (IOState {}) = none + fdv (Pi {arg, res, _}) = fdv arg <+> fdvT res + fdv (Lam {body, _}) = fdvT body + fdv (Sig {fst, snd, _}) = fdv fst <+> fdvT snd + fdv (Pair {fst, snd, _}) = fdv fst <+> fdv snd + fdv (Enum {}) = none + fdv (Tag {}) = none + fdv (Eq {ty, l, r, _}) = fdv @{DScope} ty <+> fdv l <+> fdv r + fdv (DLam {body, _}) = fdv @{DScope} body + fdv (NAT {}) = none + fdv (Nat {}) = none + fdv (Succ {p, _}) = fdv p + fdv (STRING {}) = none + fdv (Str {}) = none + fdv (BOX {ty, _}) = fdv ty + fdv (Box {val, _}) = fdv val + fdv (Let {rhs, body, _}) = fdv rhs <+> fdvT body + fdv (E e) = fdv e + fdv (CloT s) = fdv s @{WithSubst} + fdv (DCloT s) = fdvSubst s export HasFreeDVars Elim where diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 75c2bdf..b252f73 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -265,7 +265,10 @@ mutual <*> pure loc Let (qty, x, rhs) body loc => - ?fromPTerm_let + Let (fromPQty qty) + <$> fromPTermElim ds ns rhs + <*> fromPTermTScope ds ns [< x] body + <*> pure loc private fromPTermEnumArms : Loc -> Context' PatVar d -> Context' PatVar n -> diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index 11aab94..3472479 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -267,8 +267,8 @@ prettyDBind = hl DVar . prettyBind' export %inline typeD, ioStateD, arrowD, darrowD, timesD, lamD, eqndD, dlamD, annD, natD, -stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, -ofD, dotD, zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD : +stringD, eqD, colonD, commaD, semiD, atD, caseD, typecaseD, returnD, ofD, dotD, +zeroD, succD, coeD, compD, undD, cstD, pipeD, fstD, sndD, letD, inD : {opts : LayoutOpts} -> Eff Pretty (Doc opts) typeD = hl Syntax . text =<< ifUnicode "★" "Type" ioStateD = hl Syntax $ text "IOState" @@ -300,6 +300,8 @@ cstD = hl Syntax $ text "=" pipeD = hl Delim $ text "|" fstD = hl Syntax $ text "fst" sndD = hl Syntax $ text "snd" +letD = hl Syntax $ text "let" +inD = hl Syntax $ text "in" export diff --git a/lib/Quox/Syntax/Term/Base.idr b/lib/Quox/Syntax/Term/Base.idr index 994b4ea..36715d4 100644 --- a/lib/Quox/Syntax/Term/Base.idr +++ b/lib/Quox/Syntax/Term/Base.idr @@ -99,6 +99,9 @@ mutual BOX : (qty : Qty) -> (ty : Term d n) -> (loc : Loc) -> Term d n Box : (val : Term d n) -> (loc : Loc) -> Term d n + Let : (qty : Qty) -> (rhs : Elim d n) -> + (body : ScopeTerm d n) -> (loc : Loc) -> Term d n + ||| elimination E : (e : Elim d n) -> Term d n @@ -383,6 +386,7 @@ Located (Term d n) where (Succ _ loc).loc = loc (BOX _ _ loc).loc = loc (Box _ loc).loc = loc + (Let _ _ _ loc).loc = loc (E e).loc = e.loc (CloT (Sub t _)).loc = t.loc (DCloT (Sub t _)).loc = t.loc @@ -446,6 +450,7 @@ Relocatable (Term d n) where setLoc loc (Str s _) = Str s loc setLoc loc (BOX qty ty _) = BOX qty ty loc setLoc loc (Box val _) = Box val loc + setLoc loc (Let qty rhs body _) = Let qty rhs body loc setLoc loc (E e) = E $ setLoc loc e setLoc loc (CloT (Sub term subst)) = CloT $ Sub (setLoc loc term) subst setLoc loc (DCloT (Sub term subst)) = DCloT $ Sub (setLoc loc term) subst diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index 7b9f89e..e686a74 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -317,6 +317,44 @@ prettyCase dnames tnames qty head ret body = prettyCase_ dnames tnames ![|caseD <+> prettyQty qty|] head ret body +private +LetBinder : Nat -> Nat -> Type +LetBinder d n = (Qty, BindName, Elim d n) + +private +LetExpr : Nat -> Nat -> Nat -> Type +LetExpr d n n' = (Telescope (LetBinder d) n n', Term d n') + +private +PrettyLetResult : LayoutOpts -> Nat -> Type +PrettyLetResult opts d = + Exists $ \n => (BContext n, Term d n, SnocList (Doc opts)) + +-- [todo] factor out this and the untyped version somehow +export +splitLet : Telescope (LetBinder d) n n' -> Term d n' -> Exists (LetExpr d n) +splitLet ys t@(Let qty rhs body _) = + splitLet (ys :< (qty, body.name, rhs)) (assert_smaller t body.term) +splitLet ys t = + Evidence _ (ys, t) + +private covering +prettyLets : {opts : LayoutOpts} -> + BContext d -> BContext a -> Telescope (LetBinder d) a b -> + Eff Pretty (SnocList (Doc opts)) +prettyLets dnames xs lets = sequence $ snd $ go lets where + go : forall b. Telescope (LetBinder d) a b -> + (BContext b, SnocList (Eff Pretty (Doc opts))) + go [<] = (xs, [<]) + go (lets :< (qty, x, rhs)) = + let (ys, docs) = go lets + doc = do + x <- prettyTBind x + rhs <- withPrec Outer $ assert_total prettyElim dnames ys rhs + hangDSingle (hsep [!letD, x, !cstD]) (hsep [rhs, !inD]) in + (ys :< x, docs :< doc) + + private isDefaultDir : Dim d -> Dim d -> Bool isDefaultDir (K Zero _) (K One _) = True @@ -457,6 +495,14 @@ prettyTerm dnames tnames (BOX qty ty _) = prettyTerm dnames tnames (Box val _) = bracks =<< withPrec Outer (prettyTerm dnames tnames val) +prettyTerm dnames tnames (Let qty rhs body _) = do + let Evidence _ (lets, body) = splitLet [< (qty, body.name, rhs)] body.term + heads <- prettyLets dnames tnames lets + let tnames = tnames . map (\(_, x, _) => x) lets + body <- withPrec Outer $ assert_total prettyTerm dnames tnames body + let lines = toList $ heads :< body + pure $ ifMultiline (hsep lines) (vsep lines) + prettyTerm dnames tnames (E e) = prettyElim dnames tnames e prettyTerm dnames tnames t0@(CloT (Sub t ph)) = diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index b85ffd4..330a10e 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -249,89 +249,90 @@ mutual isCloE (DCloE {}) = True isCloE _ = False -mutual - export - PushSubsts Term Subst.isCloT where - pushSubstsWith th ph (TYPE l loc) = - nclo $ TYPE l loc - pushSubstsWith th ph (IOState loc) = - nclo $ IOState loc - pushSubstsWith th ph (Pi qty a body loc) = - nclo $ Pi qty (a // th // ph) (body // th // ph) loc - pushSubstsWith th ph (Lam body loc) = - nclo $ Lam (body // th // ph) loc - pushSubstsWith th ph (Sig a b loc) = - nclo $ Sig (a // th // ph) (b // th // ph) loc - pushSubstsWith th ph (Pair s t loc) = - nclo $ Pair (s // th // ph) (t // th // ph) loc - pushSubstsWith th ph (Enum tags loc) = - nclo $ Enum tags loc - pushSubstsWith th ph (Tag tag loc) = - nclo $ Tag tag loc - pushSubstsWith th ph (Eq ty l r loc) = - nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc - pushSubstsWith th ph (DLam body loc) = - nclo $ DLam (body // th // ph) loc - pushSubstsWith _ _ (NAT loc) = - nclo $ NAT loc - pushSubstsWith _ _ (Nat n loc) = - nclo $ Nat n loc - pushSubstsWith th ph (Succ n loc) = - nclo $ Succ (n // th // ph) loc - pushSubstsWith _ _ (STRING loc) = - nclo $ STRING loc - pushSubstsWith _ _ (Str s loc) = - nclo $ Str s loc - pushSubstsWith th ph (BOX pi ty loc) = - nclo $ BOX pi (ty // th // ph) loc - pushSubstsWith th ph (Box val loc) = - nclo $ Box (val // th // ph) loc - pushSubstsWith th ph (E e) = - let Element e nc = pushSubstsWith th ph e in nclo $ E e - pushSubstsWith th ph (CloT (Sub s ps)) = - pushSubstsWith th (comp th ps ph) s - pushSubstsWith th ph (DCloT (Sub s ps)) = - pushSubstsWith (ps . th) ph s +export +PushSubsts Elim Subst.isCloE where + pushSubstsWith th ph (F x u loc) = + nclo $ F x u loc + pushSubstsWith th ph (B i loc) = + let res = getLoc ph i loc in + case nchoose $ isCloE res of + Left yes => assert_total pushSubsts res + Right no => Element res no + pushSubstsWith th ph (App f s loc) = + nclo $ App (f // th // ph) (s // th // ph) loc + pushSubstsWith th ph (CasePair pi p r b loc) = + nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc + pushSubstsWith th ph (Fst pair loc) = + nclo $ Fst (pair // th // ph) loc + pushSubstsWith th ph (Snd pair loc) = + nclo $ Snd (pair // th // ph) loc + pushSubstsWith th ph (CaseEnum pi t r arms loc) = + nclo $ CaseEnum pi (t // th // ph) (r // th // ph) + (map (\b => b // th // ph) arms) loc + pushSubstsWith th ph (CaseNat pi pi' n r z s loc) = + nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph) + (z // th // ph) (s // th // ph) loc + pushSubstsWith th ph (CaseBox pi x r b loc) = + nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc + pushSubstsWith th ph (DApp f d loc) = + nclo $ DApp (f // th // ph) (d // th) loc + pushSubstsWith th ph (Ann s a loc) = + nclo $ Ann (s // th // ph) (a // th // ph) loc + pushSubstsWith th ph (Coe ty p q val loc) = + nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc + pushSubstsWith th ph (Comp ty p q val r zero one loc) = + nclo $ Comp (ty // th // ph) (p // th) (q // th) + (val // th // ph) (r // th) + (zero // th // ph) (one // th // ph) loc + pushSubstsWith th ph (TypeCase ty ret arms def loc) = + nclo $ TypeCase (ty // th // ph) (ret // th // ph) + (map (\t => t // th // ph) arms) (def // th // ph) loc + pushSubstsWith th ph (CloE (Sub e ps)) = + pushSubstsWith th (comp th ps ph) e + pushSubstsWith th ph (DCloE (Sub e ps)) = + pushSubstsWith (ps . th) ph e - export - PushSubsts Elim Subst.isCloE where - pushSubstsWith th ph (F x u loc) = - nclo $ F x u loc - pushSubstsWith th ph (B i loc) = - let res = getLoc ph i loc in - case nchoose $ isCloE res of - Left yes => assert_total pushSubsts res - Right no => Element res no - pushSubstsWith th ph (App f s loc) = - nclo $ App (f // th // ph) (s // th // ph) loc - pushSubstsWith th ph (CasePair pi p r b loc) = - nclo $ CasePair pi (p // th // ph) (r // th // ph) (b // th // ph) loc - pushSubstsWith th ph (Fst pair loc) = - nclo $ Fst (pair // th // ph) loc - pushSubstsWith th ph (Snd pair loc) = - nclo $ Snd (pair // th // ph) loc - pushSubstsWith th ph (CaseEnum pi t r arms loc) = - nclo $ CaseEnum pi (t // th // ph) (r // th // ph) - (map (\b => b // th // ph) arms) loc - pushSubstsWith th ph (CaseNat pi pi' n r z s loc) = - nclo $ CaseNat pi pi' (n // th // ph) (r // th // ph) - (z // th // ph) (s // th // ph) loc - pushSubstsWith th ph (CaseBox pi x r b loc) = - nclo $ CaseBox pi (x // th // ph) (r // th // ph) (b // th // ph) loc - pushSubstsWith th ph (DApp f d loc) = - nclo $ DApp (f // th // ph) (d // th) loc - pushSubstsWith th ph (Ann s a loc) = - nclo $ Ann (s // th // ph) (a // th // ph) loc - pushSubstsWith th ph (Coe ty p q val loc) = - nclo $ Coe (ty // th // ph) (p // th) (q // th) (val // th // ph) loc - pushSubstsWith th ph (Comp ty p q val r zero one loc) = - nclo $ Comp (ty // th // ph) (p // th) (q // th) - (val // th // ph) (r // th) - (zero // th // ph) (one // th // ph) loc - pushSubstsWith th ph (TypeCase ty ret arms def loc) = - nclo $ TypeCase (ty // th // ph) (ret // th // ph) - (map (\t => t // th // ph) arms) (def // th // ph) loc - pushSubstsWith th ph (CloE (Sub e ps)) = - pushSubstsWith th (comp th ps ph) e - pushSubstsWith th ph (DCloE (Sub e ps)) = - pushSubstsWith (ps . th) ph e +export +PushSubsts Term Subst.isCloT where + pushSubstsWith th ph (TYPE l loc) = + nclo $ TYPE l loc + pushSubstsWith th ph (IOState loc) = + nclo $ IOState loc + pushSubstsWith th ph (Pi qty a body loc) = + nclo $ Pi qty (a // th // ph) (body // th // ph) loc + pushSubstsWith th ph (Lam body loc) = + nclo $ Lam (body // th // ph) loc + pushSubstsWith th ph (Sig a b loc) = + nclo $ Sig (a // th // ph) (b // th // ph) loc + pushSubstsWith th ph (Pair s t loc) = + nclo $ Pair (s // th // ph) (t // th // ph) loc + pushSubstsWith th ph (Enum tags loc) = + nclo $ Enum tags loc + pushSubstsWith th ph (Tag tag loc) = + nclo $ Tag tag loc + pushSubstsWith th ph (Eq ty l r loc) = + nclo $ Eq (ty // th // ph) (l // th // ph) (r // th // ph) loc + pushSubstsWith th ph (DLam body loc) = + nclo $ DLam (body // th // ph) loc + pushSubstsWith _ _ (NAT loc) = + nclo $ NAT loc + pushSubstsWith _ _ (Nat n loc) = + nclo $ Nat n loc + pushSubstsWith th ph (Succ n loc) = + nclo $ Succ (n // th // ph) loc + pushSubstsWith _ _ (STRING loc) = + nclo $ STRING loc + pushSubstsWith _ _ (Str s loc) = + nclo $ Str s loc + pushSubstsWith th ph (BOX pi ty loc) = + nclo $ BOX pi (ty // th // ph) loc + pushSubstsWith th ph (Box val loc) = + nclo $ Box (val // th // ph) loc + pushSubstsWith th ph (E e) = + let Element e nc = pushSubstsWith th ph e in nclo $ E e + pushSubstsWith th ph (Let qty rhs body loc) = + nclo $ Let qty (rhs // th // ph) (body // th // ph) loc + pushSubstsWith th ph (CloT (Sub s ps)) = + pushSubstsWith th (comp th ps ph) s + pushSubstsWith th ph (DCloT (Sub s ps)) = + pushSubstsWith (ps . th) ph s diff --git a/lib/Quox/Syntax/Term/Tighten.idr b/lib/Quox/Syntax/Term/Tighten.idr index de45d98..0709684 100644 --- a/lib/Quox/Syntax/Term/Tighten.idr +++ b/lib/Quox/Syntax/Term/Tighten.idr @@ -75,8 +75,10 @@ mutual BOX qty <$> tightenT p ty <*> pure loc tightenT' p (Box val loc) = Box <$> tightenT p val <*> pure loc + tightenT' p (Let qty rhs body loc) = + Let qty <$> assert_total tightenE p rhs <*> tightenS p body <*> pure loc tightenT' p (E e) = - assert_total $ E <$> tightenE p e + E <$> assert_total tightenE p e private tightenE' : OPE n1 n2 -> (e : Elim d n2) -> (0 ne : NotClo e) => @@ -200,8 +202,10 @@ mutual BOX qty <$> dtightenT p ty <*> pure loc dtightenT' p (Box val loc) = Box <$> dtightenT p val <*> pure loc + dtightenT' p (Let qty rhs body loc) = + Let qty <$> assert_total dtightenE p rhs <*> dtightenS p body <*> pure loc dtightenT' p (E e) = - assert_total $ E <$> dtightenE p e + E <$> assert_total dtightenE p e export dtightenE' : OPE d1 d2 -> (e : Elim d2 n) -> (0 ne : NotClo e) => diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index a477c3e..13052b1 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -213,6 +213,13 @@ mutual -- then Ψ | Γ ⊢ σ · [s] ⇐ [π.A] ⊳ πΣ pure $ q * valout + check' ctx sg (Let qty rhs body loc) ty = do + eres <- inferC ctx (subjMult sg qty) rhs + qout <- checkC (extendTy (qty * sg.qty) body.name eres.type ctx) sg + body.term (weakT 1 ty) + >>= popQ loc qty + pure $ qty * eres.qout + qout + check' ctx sg (E e) ty = do -- if Ψ | Γ ⊢ σ · e ⇒ A' ⊳ Σ infres <- inferC ctx sg e @@ -286,6 +293,11 @@ mutual checkType' ctx (BOX q ty _) u = checkType ctx ty u checkType' ctx t@(Box {}) u = throw $ NotType t.loc ctx t + checkType' ctx (Let qty rhs body loc) u = do + expectEqualQ loc qty Zero + ety <- inferC ctx SZero rhs + checkType (extendTy Zero body.name ety.type ctx) body.term u + checkType' ctx (E e) u = do -- if Ψ | Γ ⊢₀ E ⇒ Type ℓ infres <- inferC ctx SZero e diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 0fc24ef..43630c2 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -222,6 +222,25 @@ eraseTerm ctx ty (Box val loc) = do Erased => pure $ Erased loc Kept => eraseTerm ctx a val +-- s ⤋ s' ⇐ A +-- ---------------------------- +-- let0 x = e in s ⤋ s' ⇐ A +-- +-- e ⤋ e' s ⤋ s' ⇐ A π ≠ 0 +-- ------------------------------------- +-- letπ x = e in s ⤋ let x = e' in s' +eraseTerm ctx ty (Let pi e s loc) = do + let x = s.name + case isErased pi of + Erased => do + ety <- computeElimType ctx SZero e + s' <- eraseTerm (extendTy pi x ety ctx) (weakT 1 ty) s.term + pure $ sub1 (Erased e.loc) s' + Kept => do + EraRes ety e' <- eraseElim ctx e + s' <- eraseTerm (extendTy pi x ety ctx) (weakT 1 ty) s.term + pure $ Let x e' s' loc + -- e ⤋ e' ⇒ B -- ------------ -- e ⤋ e' ⇐ A diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index da660cd..5df044d 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -96,11 +96,6 @@ public export Definitions = SortedMap Name Definition -export -letD, inD : {opts : LayoutOpts} -> Eff Pretty (Doc opts) -letD = hl Syntax "let" -inD = hl Syntax "in" - export covering prettyTerm : {opts : LayoutOpts} -> BContext n -> Term n -> Eff Pretty (Doc opts) diff --git a/lib/Quox/Whnf/Interface.idr b/lib/Quox/Whnf/Interface.idr index efc51f9..15a8978 100644 --- a/lib/Quox/Whnf/Interface.idr +++ b/lib/Quox/Whnf/Interface.idr @@ -135,6 +135,7 @@ isTyCon (STRING {}) = True isTyCon (Str {}) = False isTyCon (BOX {}) = True isTyCon (Box {}) = False +isTyCon (Let {}) = False isTyCon (E {}) = False isTyCon (CloT {}) = False isTyCon (DCloT {}) = False @@ -182,6 +183,7 @@ canPushCoe sg (STRING {}) _ = True canPushCoe sg (Str {}) _ = False canPushCoe sg (BOX {}) _ = True canPushCoe sg (Box {}) _ = False +canPushCoe sg (Let {}) _ = False canPushCoe sg (E {}) _ = False canPushCoe sg (CloT {}) _ = False canPushCoe sg (DCloT {}) _ = False @@ -243,10 +245,12 @@ mutual ||| (the annotation is redundant in a checkable context) ||| 3. a closure ||| 4. `succ` applied to a natural constant + ||| 5. a `let` expression public export isRedexT : RedexTest Term isRedexT _ _ (CloT {}) = True isRedexT _ _ (DCloT {}) = True + isRedexT _ _ (Let {}) = True isRedexT defs sg (E {e, _}) = isAnn e || isRedexE defs sg e isRedexT _ _ (Succ p {}) = isNatConst p isRedexT _ _ _ = False diff --git a/lib/Quox/Whnf/Main.idr b/lib/Quox/Whnf/Main.idr index e636adf..9248edf 100644 --- a/lib/Quox/Whnf/Main.idr +++ b/lib/Quox/Whnf/Main.idr @@ -252,7 +252,10 @@ CanWhnf Term Interface.isRedexT where Left _ => case p of Nat p _ => pure $ nred $ Nat (S p) loc E (Ann (Nat p _) _ _) => pure $ nred $ Nat (S p) loc - Right nc => pure $ Element (Succ p loc) $ ?cc + Right nc => pure $ Element (Succ p loc) nc + + whnf defs ctx sg (Let _ rhs body _) = + whnf defs ctx sg $ sub1 body rhs -- s ∷ A ⇝ s (in term context) whnf defs ctx sg (E e) = do From 415a823decceced4fbef2b829ad7e77b999a2240 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 4 Dec 2023 22:49:32 +0100 Subject: [PATCH 064/133] comment out an unfinished definition lmao --- examples/nat.quox | 3 +++ 1 file changed, 3 insertions(+) diff --git a/examples/nat.quox b/examples/nat.quox index 3b9894a..efc834d 100644 --- a/examples/nat.quox +++ b/examples/nat.quox @@ -149,6 +149,8 @@ def0 times-zero : (m : ℕ) → 0 ≡ timesω m 0 : ℕ = succ m', ih ⇒ ih }; +{- +-- unfinished def0 times-succ : (m n : ℕ) → plus m (timesω m n) ≡ timesω m (succ n) : ℕ = λ m n ⇒ case m @@ -158,5 +160,6 @@ def0 times-succ : (m n : ℕ) → plus m (timesω m n) ≡ timesω m (succ n) : succ m', ih ⇒ δ 𝑖 ⇒ plus (succ n) (ih @𝑖) }; +-} } From e48f03a61c1d67633d5f2cf015ed4fffe0fea544 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 4 Dec 2023 23:27:59 +0100 Subject: [PATCH 065/133] multiple semi-sep binds in a let --- lib/Quox/Parser/Parser.idr | 32 +++++++++++++++++++++----------- tests/Tests/Parser.idr | 21 ++++++++++++++++++++- 2 files changed, 41 insertions(+), 12 deletions(-) diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index 42e2170..6419c55 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -585,22 +585,32 @@ where foldr (\(q, x, s), t => Pi q x s t loc) cod $ toDoms (toQty q) doms -letIntro : FileName -> Grammar True PQty +export +letIntro : FileName -> Grammar True (Maybe PQty) letIntro fname = - withLoc fname (PQ Zero <$ res "let0") - <|> withLoc fname (PQ One <$ res "let1") - <|> withLoc fname (PQ Any <$ res "letω") - <|> do resC "let" - qty fname <* needRes "." <|> defLoc fname (PQ One) + withLoc fname (Just . PQ Zero <$ res "let0") + <|> withLoc fname (Just . PQ One <$ res "let1") + <|> withLoc fname (Just . PQ Any <$ res "letω") + <|> Nothing <$ resC "let" + +export +letBinder : FileName -> Maybe PQty -> Grammar True (PQty, PatVar, PTerm) +letBinder fname mq = do + qty <- the (Grammar False PQty) $ case mq of + Just q => pure q + Nothing => qty fname <* mustWork (resC ".") <|> defLoc fname (PQ One) + x <- patVar fname; mustWork (resC "=") + rhs <- term fname + pure $ (qty, x, rhs) export letTerm : FileName -> Grammar True PTerm letTerm fname = withLoc fname $ do - qty <- letIntro fname - x <- patVar fname <* mustWork (resC "=") - rhs <- assert_total term fname <* mustWork (resC "in") - body <- assert_total term fname - pure $ Let (qty, x, rhs) body + qty <- letIntro fname + binds <- sepEndBy1 (res ";") $ assert_total letBinder fname qty + mustWork $ resC "in" + body <- assert_total term fname + pure $ \loc => foldr (\b, s => Let b s loc) body binds -- term : FileName -> Grammar True PTerm term fname = lamTerm fname diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index dc27730..e1f780a 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -414,12 +414,16 @@ tests = "parser" :- [ "let" :- [ parseMatch term "let x = y in z" `(Let (PQ One _, PV "x" {}, V "y" {}) (V "z" {}) _), + parseMatch term "let x = y; in z" + `(Let (PQ One _, PV "x" {}, V "y" {}) (V "z" {}) _), parseMatch term "let0 x = y in z" `(Let (PQ Zero _, PV "x" {}, V "y" {}) (V "z" {}) _), parseMatch term "let1 x = y in z" `(Let (PQ One _, PV "x" {}, V "y" {}) (V "z" {}) _), parseMatch term "letω x = y in z" `(Let (PQ Any _, PV "x" {}, V "y" {}) (V "z" {}) _), + parseMatch term "let ω.x = y in z" + `(Let (PQ Any _, PV "x" {}, V "y" {}) (V "z" {}) _), parseMatch term "let x = y1 y2 in z1 z2" `(Let (PQ One _, PV "x" {}, (App (V "y1" {}) (V "y2" {}) _)) @@ -427,12 +431,27 @@ tests = "parser" :- [ parseMatch term "let x = a in let y = b in z" `(Let (PQ One _, PV "x" {}, V "a" {}) (Let (PQ One _, PV "y" {}, V "b" {}) (V "z" {}) _) _), + parseMatch term "let x = a; y = b in z" + `(Let (PQ One _, PV "x" {}, V "a" {}) + (Let (PQ One _, PV "y" {}, V "b" {}) (V "z" {}) _) _), + parseMatch term "letω x = a; y = b in z" + `(Let (PQ Any _, PV "x" {}, V "a" {}) + (Let (PQ Any _, PV "y" {}, V "b" {}) (V "z" {}) _) _), + parseMatch term "letω x = a; y = b; in z" + `(Let (PQ Any _, PV "x" {}, V "a" {}) + (Let (PQ Any _, PV "y" {}, V "b" {}) (V "z" {}) _) _), + parseMatch term "let ω.x = a; 1.y = b in z" + `(Let (PQ Any _, PV "x" {}, V "a" {}) + (Let (PQ One _, PV "y" {}, V "b" {}) (V "z" {}) _) _), parseMatch term "let x = y in z ∷ Z" `(Let (PQ One _, PV "x" {}, V "y" {}) (Ann (V "z" {}) (V "Z" {}) _) _), parseMatch term "let x = y in z₁ ≡ z₂ : Z" `(Let (PQ One _, PV "x" {}, V "y" {}) - (Eq (Unused _, V "Z" {}) (V "z₁" {}) (V "z₂" {}) _) _) + (Eq (Unused _, V "Z" {}) (V "z₁" {}) (V "z₂" {}) _) _), + parseFails term "let1 1.x = y in z", + parseFails term "let x = y", + parseFails term "let x in z" ], "definitions" :- From 8b8129027d1408aa8a48184aa704349bf9cc6ceb Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 4 Dec 2023 23:35:54 +0100 Subject: [PATCH 066/133] update syntax.ebnf --- syntax.ebnf | 15 +++++++++++---- 1 file changed, 11 insertions(+), 4 deletions(-) diff --git a/syntax.ebnf b/syntax.ebnf index ff78604..1296129 100644 --- a/syntax.ebnf +++ b/syntax.ebnf @@ -24,7 +24,7 @@ dim arg = "@", dim. pat var = NAME | "_". -term = lambda | case | pi | sigma | ann. +term = lambda | pi | sigma | ann | let. lambda = ("λ" | "δ"), {pat var}+, "⇒", term. @@ -49,12 +49,18 @@ sigma = (binder | ann), "×", (sigma | ann). ann = infix eq, ["∷", term]. +bare let binder = pat var, "=", term. +qty let binder = [qty, "."], bare let binder. + +let = ("let0" | "let1" | "letω"), {bare let binder / ";"}+, "in", term + | "let", {qty let binder / ";"}+, "in", term. + infix eq = app term, ["≡", term, ":", app term]. (* dependent is below *) -app term = coe | comp | split universe | dep eq | succ | normal app. +app term = coe | comp | split universe | dep eq | special app | normal app. split universe = "★", NAT. dep eq = "Eq", type line, term arg, term arg. -succ = "succ", term arg. +special app = ("fst" | "snd" | "succ"), {term arg}+. normal app = term arg, {term arg | dim arg}. (* direction defaults to @0 @1 *) @@ -76,4 +82,5 @@ term arg = UNIVERSE | "★", SUPER | "zero" | NAT | QNAME, displacement - | "(", {term / ","}+, [","], ")". + | "(", {term / ","}+, [","], ")" + | case. From 08a8c694b1fba3421782ebd727b213064663dcc7 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 4 Dec 2023 23:36:30 +0100 Subject: [PATCH 067/133] a usage in hello.quox. why not --- examples/hello.quox | 4 +++- 1 file changed, 3 insertions(+), 1 deletion(-) diff --git a/examples/hello.quox b/examples/hello.quox index 8e5dbf9..db220cf 100644 --- a/examples/hello.quox +++ b/examples/hello.quox @@ -21,4 +21,6 @@ postulate print : String → IO Unit load "nat.quox" #[main] -def main = seq (print-ℕ (nat.plus 60 9)) (print "(nice)") +def main : IO Unit = + let1 sixty-nine = nat.plus 60 9 in + seq (print-ℕ sixty-nine) (print "(nice)") From cdf1ec6debdaa837aadd4013b9929108ad999715 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 4 Dec 2023 23:38:17 +0100 Subject: [PATCH 068/133] fix a comment --- lib/Quox/Untyped/Erase.idr | 6 +++--- 1 file changed, 3 insertions(+), 3 deletions(-) diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 43630c2..701eaad 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -222,9 +222,9 @@ eraseTerm ctx ty (Box val loc) = do Erased => pure $ Erased loc Kept => eraseTerm ctx a val --- s ⤋ s' ⇐ A --- ---------------------------- --- let0 x = e in s ⤋ s' ⇐ A +-- s ⤋ s' ⇐ A +-- --------------------------------- +-- let0 x = e in s ⤋ s'[⌷/x] ⇐ A -- -- e ⤋ e' s ⤋ s' ⇐ A π ≠ 0 -- ------------------------------------- From 03c197bd0442293fc660bccbbe3249cc34cf2a35 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 7 Dec 2023 01:35:39 +0100 Subject: [PATCH 069/133] add local bindings to context MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - without this, inside the body of `let x = e in …`, the typechecker would forget that `x = e` - now bound variables can reduce, if they have a definition, so RedexTest needs to take the context too --- exe/Main.idr | 7 +- lib/Quox/Equal.idr | 34 +++-- lib/Quox/Typechecker.idr | 8 +- lib/Quox/Typing.idr | 4 +- lib/Quox/Typing/Context.idr | 100 +++++++++++--- lib/Quox/Untyped/Erase.idr | 209 ++++++++++++++++-------------- lib/Quox/Whnf/Coercion.idr | 14 +- lib/Quox/Whnf/ComputeElimType.idr | 10 +- lib/Quox/Whnf/Interface.idr | 100 +++++++------- lib/Quox/Whnf/Main.idr | 5 +- lib/Quox/Whnf/TypeCase.idr | 10 +- tests/AstExtra.idr | 8 +- tests/Tests/Reduce.idr | 2 +- 13 files changed, 300 insertions(+), 211 deletions(-) diff --git a/exe/Main.idr b/exe/Main.idr index 45a377d..177f438 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -164,7 +164,7 @@ private liftFromParser : Eff FromParserIO a -> Eff CompileStop a liftFromParser act = runEff act $ with Union.(::) - [handleExcept (\err => throw $ FromParserError err), + [handleExcept $ \err => throw $ FromParserError err, handleStateIORef !(asksAt STATE defs), handleStateIORef !(asksAt STATE ns), handleStateIORef !(asksAt STATE suf), @@ -174,8 +174,7 @@ private liftErase : Q.Definitions -> Eff Erase a -> Eff CompileStop a liftErase defs act = runEff act - [\case Err e => throw $ EraseError e, - \case Ask => pure defs, + [handleExcept $ \err => throw $ EraseError err, handleStateIORef !(asksAt STATE suf)] private @@ -207,7 +206,7 @@ processFile file = withEarlyStop $ do traverse (uncurry Q.prettyDef) defList let defs = SortedMap.fromList defList erased <- liftErase defs $ - traverse (\(x, d) => (x,) <$> eraseDef x d) defList + traverse (\(x, d) => (x,) <$> eraseDef defs x d) defList outputDocStopIf Erase $ traverse (uncurry U.prettyDef) erased (scheme, mains) <- liftScheme $ map catMaybes $ diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 7055181..9a69ffb 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -170,12 +170,19 @@ compareType : Definitions -> EqContext n -> (s, t : Term 0 n) -> Eff EqualInner () +private +0 NotRedexEq : {isRedex : RedexTest tm} -> CanWhnf tm isRedex => + Definitions -> EqContext n -> SQty -> Pred (tm 0 n) +NotRedexEq defs ctx sg t = NotRedex defs (toWhnfContext ctx) sg t + namespace Term private covering - compare0' : (defs : Definitions) -> EqContext n -> (sg : SQty) -> + compare0' : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) -> (ty, s, t : Term 0 n) -> - (0 _ : NotRedex defs SZero ty) => (0 _ : So (isTyConE ty)) => - (0 _ : NotRedex defs sg s) => (0 _ : NotRedex defs sg t) => + (0 _ : NotRedexEq defs ctx SZero ty) => + (0 _ : So (isTyConE ty)) => + (0 _ : NotRedexEq defs ctx sg s) => + (0 _ : NotRedexEq defs ctx sg t) => Eff EqualInner () compare0' defs ctx sg (TYPE {}) s t = compareType defs ctx s t @@ -350,9 +357,10 @@ namespace Term private covering -compareType' : (defs : Definitions) -> EqContext n -> (s, t : Term 0 n) -> - (0 _ : NotRedex defs SZero s) => (0 _ : So (isTyConE s)) => - (0 _ : NotRedex defs SZero t) => (0 _ : So (isTyConE t)) => +compareType' : (defs : Definitions) -> (ctx : EqContext n) -> + (s, t : Term 0 n) -> + (0 _ : NotRedexEq defs ctx SZero s) => (0 _ : So (isTyConE s)) => + (0 _ : NotRedexEq defs ctx SZero t) => (0 _ : So (isTyConE t)) => (0 _ : So (sameTyCon s t)) => Eff EqualInner () -- equality is the same as subtyping, except with the @@ -477,8 +485,9 @@ namespace Elim EqualElim = InnerErrEff :: EqualInner private covering - computeElimTypeE : (defs : Definitions) -> EqContext n -> (sg : SQty) -> - (e : Elim 0 n) -> (0 ne : NotRedex defs sg e) => + computeElimTypeE : (defs : Definitions) -> (ctx : EqContext n) -> + (sg : SQty) -> + (e : Elim 0 n) -> (0 ne : NotRedexEq defs ctx sg e) => Eff EqualElim (Term 0 n) computeElimTypeE defs ectx sg e = lift $ computeElimType defs (toWhnfContext ectx) sg e @@ -492,8 +501,8 @@ namespace Elim try act = lift $ catch putError $ lift act {fs' = EqualElim} private covering %inline - clashE : (defs : Definitions) -> EqContext n -> (sg : SQty) -> - (e, f : Elim 0 n) -> (0 nf : NotRedex defs sg f) => + clashE : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) -> + (e, f : Elim 0 n) -> (0 nf : NotRedexEq defs ctx sg f) => Eff EqualElim (Term 0 n) clashE defs ctx sg e f = do putError $ ClashE e.loc ctx !mode e f @@ -522,9 +531,10 @@ namespace Elim (e, f : Elim 0 n) -> Eff EqualElim (Term 0 n) private covering - compare0Inner' : (defs : Definitions) -> EqContext n -> (sg : SQty) -> + compare0Inner' : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) -> (e, f : Elim 0 n) -> - (0 ne : NotRedex defs sg e) -> (0 nf : NotRedex defs sg f) -> + (0 ne : NotRedexEq defs ctx sg e) -> + (0 nf : NotRedexEq defs ctx sg f) -> Eff EqualElim (Term 0 n) compare0Inner' defs ctx sg e@(F {}) f _ _ = do diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index 13052b1..53677a5 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -215,8 +215,8 @@ mutual check' ctx sg (Let qty rhs body loc) ty = do eres <- inferC ctx (subjMult sg qty) rhs - qout <- checkC (extendTy (qty * sg.qty) body.name eres.type ctx) sg - body.term (weakT 1 ty) + qout <- checkC (extendTyLet (qty * sg.qty) body.name eres.type (E rhs) ctx) + sg body.term (weakT 1 ty) >>= popQ loc qty pure $ qty * eres.qout + qout @@ -338,8 +338,8 @@ mutual pure $ lookupBound sg.qty i ctx.tctx where lookupBound : forall n. Qty -> Var n -> TContext d n -> InferResult' d n - lookupBound pi VZ (ctx :< type) = - InfRes {type = weakT 1 type, qout = zeroFor ctx :< pi} + lookupBound pi VZ (ctx :< var) = + InfRes {type = weakT 1 var.type, qout = zeroFor ctx :< pi} lookupBound pi (VS i) (ctx :< _) = let InfRes {type, qout} = lookupBound pi i ctx in InfRes {type = weakT 1 type, qout = qout :< Zero} diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index 31c059f..5d62e8a 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -70,7 +70,7 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} parameters (ctx : TyContext d n) (sg : SQty) (loc : Loc) export covering whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => - tm d n -> Eff fs (NonRedex tm d n defs sg) + tm d n -> Eff fs (NonRedex tm d n defs ? sg) whnf tm = do let Val n = ctx.termLen; Val d = ctx.dimLen res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm @@ -120,7 +120,7 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} parameters (ctx : EqContext n) (sg : SQty) (loc : Loc) export covering whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => - tm 0 n -> Eff fs (NonRedex tm 0 n defs sg) + tm 0 n -> Eff fs (NonRedex tm 0 n defs ? sg) whnf tm = do res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm rethrow res diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index a1dd49a..f660a7c 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -14,9 +14,27 @@ public export QContext : Nat -> Type QContext = Context' Qty +public export +record LocalVar d n where + constructor MkLocal + type : Term d n + term : Maybe (Term d n) -- if from a `let` +%runElab deriveIndexed "LocalVar" [Show] + +export +CanShift (LocalVar d) where + l // by = {type $= (// by), term $= map (// by)} l + +namespace LocalVar + subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n + subD th = {type $= (// th), term $= map (// th)} + + weakD : LocalVar d n -> LocalVar (S d) n + weakD = subD $ shift 1 + public export TContext : TermLike -TContext d = Context (Term d) +TContext d = Context (\n => LocalVar d n) public export QOutput : Nat -> Type @@ -67,10 +85,6 @@ record WhnfContext d n where %runElab deriveIndexed "WhnfContext" [Show] namespace TContext - export %inline - pushD : TContext d n -> TContext (S d) n - pushD tel = map (// shift 1) tel - export %inline zeroFor : Context tm n -> QOutput n zeroFor ctx = Zero <$ ctx @@ -89,6 +103,14 @@ public export CtxExtension0 : Nat -> Nat -> Nat -> Type CtxExtension0 d = Telescope ((BindName,) . Term d) +public export +CtxExtensionLet : Nat -> Nat -> Nat -> Type +CtxExtensionLet d = Telescope ((Qty, BindName,) . LocalVar d) + +public export +CtxExtensionLet0 : Nat -> Nat -> Nat -> Type +CtxExtensionLet0 d = Telescope ((BindName,) . LocalVar d) + namespace TyContext public export %inline empty : TyContext 0 0 @@ -100,21 +122,34 @@ namespace TyContext null ctx = null ctx.dnames && null ctx.tnames export %inline - extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2 - extendTyN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) = - let (qs, xs, ss) = unzip3 xss in + extendTyLetN : CtxExtensionLet d n1 n2 -> TyContext d n1 -> TyContext d n2 + extendTyLetN xss (MkTyContext {termLen, dctx, dnames, tctx, tnames, qtys}) = + let (qs, xs, ls) = unzip3 xss in MkTyContext { dctx, dnames, termLen = extendLen xss termLen, - tctx = tctx . ss, + tctx = tctx . ls, tnames = tnames . xs, qtys = qtys . qs } + export %inline + extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2 + extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, MkLocal s Nothing)) + + export %inline + extendTyLetN0 : CtxExtensionLet0 d n1 n2 -> TyContext d n1 -> TyContext d n2 + extendTyLetN0 xss = extendTyLetN (map (Zero,) xss) + export %inline extendTyN0 : CtxExtension0 d n1 n2 -> TyContext d n1 -> TyContext d n2 extendTyN0 xss = extendTyN (map (Zero,) xss) + export %inline + extendTyLet : Qty -> BindName -> Term d n -> Term d n -> + TyContext d n -> TyContext d (S n) + extendTyLet q x s e = extendTyLetN [< (q, x, MkLocal s (Just e))] + export %inline extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n) extendTy q x s = extendTyN [< (q, x, s)] @@ -130,7 +165,7 @@ namespace TyContext dctx = dctx : EqContext n1 -> EqContext n2 - extendTyN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) = - let (qs, xs, ss) = unzip3 xss in + extendTyLetN : CtxExtensionLet 0 n1 n2 -> EqContext n1 -> EqContext n2 + extendTyLetN xss (MkEqContext {termLen, dassign, dnames, tctx, tnames, qtys}) = + let (qs, xs, ls) = unzip3 xss in MkEqContext { termLen = extendLen xss termLen, - tctx = tctx . ss, + tctx = tctx . ls, tnames = tnames . xs, qtys = qtys . qs, dassign, dnames } + export %inline + extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2 + extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, MkLocal s Nothing)) + + export %inline + extendTyLetN0 : CtxExtensionLet0 0 n1 n2 -> EqContext n1 -> EqContext n2 + extendTyLetN0 xss = extendTyLetN (map (Zero,) xss) + export %inline extendTyN0 : CtxExtension0 0 n1 n2 -> EqContext n1 -> EqContext n2 extendTyN0 xss = extendTyN (map (Zero,) xss) + export %inline + extendTyLet : Qty -> BindName -> Term 0 n -> Term 0 n -> + EqContext n -> EqContext (S n) + extendTyLet q x s e = extendTyLetN [< (q, x, MkLocal s (Just e))] + export %inline extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n) extendTy q x s = extendTyN [< (q, x, s)] @@ -225,7 +273,7 @@ namespace EqContext toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) = MkTyContext { dctx = fromGround dassign, - tctx = map (// shift0 dimLen) tctx, + tctx = map (subD $ shift0 dimLen) tctx, dnames, tnames, qtys } @@ -252,7 +300,7 @@ namespace WhnfContext MkWhnfContext { dimLen = [|Val s + dimLen|], dnames = dnames ++ toSnocVect' ns, - tctx = dweakT s <$> tctx, + tctx = map (subD $ shift s) tctx, tnames } @@ -264,10 +312,20 @@ namespace WhnfContext private prettyTContextElt : {opts : _} -> BContext d -> BContext n -> - Qty -> BindName -> Term d n -> Eff Pretty (Doc opts) -prettyTContextElt dnames tnames q x s = - pure $ hsep [hcat [!(prettyQty q), !dotD, !(prettyTBind x)], !colonD, - !(withPrec Outer $ prettyTerm dnames tnames s)] + Qty -> BindName -> LocalVar d n -> Eff Pretty (Doc opts) +prettyTContextElt dnames tnames q x s = do + q <- prettyQty q; dot <- dotD + x <- prettyTBind x; colon <- colonD + ty <- withPrec Outer $ prettyTerm dnames tnames s.type; eq <- cstD + tm <- traverse (withPrec Outer . prettyTerm dnames tnames) s.term + d <- askAt INDENT + let qx = hcat [q, dot, x] + pure $ case tm of + Nothing => + ifMultiline (hsep [qx, colon, ty]) (vsep [qx, indent d $ colon <++> ty]) + Just tm => + ifMultiline (hsep [qx, colon, ty, eq, tm]) + (vsep [qx, indent d $ colon <++> ty, indent d $ eq <++> tm]) private prettyTContext' : {opts : _} -> diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 701eaad..c51c5f5 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -88,16 +88,16 @@ parameters {opts : LayoutOpts} (showContext : Bool) public export Erase : List (Type -> Type) -Erase = [Except Error, DefsReader, NameGen] +Erase = [Except Error, NameGen] export liftWhnf : Eff Whnf a -> Eff Erase a liftWhnf act = lift $ wrapErr WrapTypeError act export covering -computeElimType : ErasureContext d n -> SQty -> Elim d n -> Eff Erase (Term d n) -computeElimType ctx sg e = do - defs <- askAt DEFS +computeElimType : Q.Definitions -> ErasureContext d n -> SQty -> + Elim d n -> Eff Erase (Term d n) +computeElimType defs ctx sg e = do let ctx = toWhnfContext ctx liftWhnf $ do Element e _ <- whnf defs ctx sg e @@ -106,10 +106,11 @@ computeElimType ctx sg e = do private %macro wrapExpect : TTImp -> - Elab (TyContext d n -> Loc -> Term d n -> Eff Erase a) + Elab (Q.Definitions -> TyContext d n -> Loc -> + Term d n -> Eff Erase a) wrapExpect f_ = do f <- check `(\x => ~(f_) x) - pure $ \ctx, loc, s => liftWhnf $ f !(askAt DEFS) ctx SZero loc s + pure $ \defs, ctx, loc, s => liftWhnf $ f defs ctx SZero loc s public export @@ -119,27 +120,36 @@ record EraseElimResult d n where term : U.Term n +export covering +eraseTerm' : (defs : Q.Definitions) -> (ctx : ErasureContext d n) -> + (ty, tm : Q.Term d n) -> + (0 _ : NotRedex defs (toWhnfContext ctx) SZero ty) => + Eff Erase (U.Term n) + -- "Ψ | Γ | Σ ⊢ s ⤋ s' ⇐ A" for `s' <- eraseTerm (Ψ,Γ,Σ) A s` -- -- in the below comments, Ψ, Γ, Σ are implicit and -- only their extensions are written export covering -eraseTerm : ErasureContext d n -> +eraseTerm : Q.Definitions -> ErasureContext d n -> (ty, tm : Q.Term d n) -> Eff Erase (U.Term n) +eraseTerm defs ctx ty tm = do + Element ty _ <- liftWhnf $ Interface.whnf defs (toWhnfContext ctx) SZero ty + eraseTerm' defs ctx ty tm -- "Ψ | Γ | Σ ⊢ e ⤋ e' ⇒ A" for `EraRes A e' <- eraseElim (Ψ,Γ,Σ) e` export covering -eraseElim : ErasureContext d n -> (tm : Q.Elim d n) -> +eraseElim : Q.Definitions -> ErasureContext d n -> (tm : Q.Elim d n) -> Eff Erase (EraseElimResult d n) -eraseTerm ctx _ s@(TYPE {}) = +eraseTerm' defs ctx _ s@(TYPE {}) = throw $ CompileTimeOnly ctx s -eraseTerm ctx _ s@(IOState {}) = +eraseTerm' defs ctx _ s@(IOState {}) = throw $ CompileTimeOnly ctx s -eraseTerm ctx _ s@(Pi {}) = +eraseTerm' defs ctx _ s@(Pi {}) = throw $ CompileTimeOnly ctx s -- x : A | 0.x ⊢ s ⤋ s' ⇐ B @@ -149,66 +159,66 @@ eraseTerm ctx _ s@(Pi {}) = -- x : A | π.x ⊢ s ⤋ s' ⇐ B π ≠ 0 -- ---------------------------------------- -- (λ x ⇒ s) ⤋ (λ x ⇒ s') ⇐ π.(x : A) → B -eraseTerm ctx ty (Lam body loc) = do +eraseTerm' defs ctx ty (Lam body loc) = do let x = body.name - (qty, arg, res) <- wrapExpect `(expectPi) ctx loc ty - body <- eraseTerm (extendTy qty x arg ctx) res.term body.term + (qty, arg, res) <- wrapExpect `(expectPi) defs ctx loc ty + body <- eraseTerm defs (extendTy qty x arg ctx) res.term body.term pure $ case isErased qty of Kept => U.Lam x body loc Erased => sub1 (Erased loc) body -eraseTerm ctx _ s@(Sig {}) = +eraseTerm' defs ctx _ s@(Sig {}) = throw $ CompileTimeOnly ctx s -- s ⤋ s' ⇐ A t ⤋ t' ⇐ B[s/x] -- --------------------------------- -- (s, t) ⤋ (s', t') ⇐ (x : A) × B -eraseTerm ctx ty (Pair fst snd loc) = do - (a, b) <- wrapExpect `(expectSig) ctx loc ty +eraseTerm' defs ctx ty (Pair fst snd loc) = do + (a, b) <- wrapExpect `(expectSig) defs ctx loc ty let b = sub1 b (Ann fst a a.loc) - fst <- eraseTerm ctx a fst - snd <- eraseTerm ctx b snd + fst <- eraseTerm defs ctx a fst + snd <- eraseTerm defs ctx b snd pure $ Pair fst snd loc -eraseTerm ctx _ s@(Enum {}) = +eraseTerm' defs ctx _ s@(Enum {}) = throw $ CompileTimeOnly ctx s -- '𝐚 ⤋ '𝐚 ⇐ {⋯} -eraseTerm ctx _ (Tag tag loc) = +eraseTerm' defs ctx _ (Tag tag loc) = pure $ Tag tag loc -eraseTerm ctx ty s@(Eq {}) = +eraseTerm' defs ctx ty s@(Eq {}) = throw $ CompileTimeOnly ctx s -- 𝑖 ⊢ s ⤋ s' ⇐ A -- --------------------------------- -- (δ 𝑖 ⇒ s) ⤋ s' ⇐ Eq (𝑖 ⇒ A) l r -eraseTerm ctx ty (DLam body loc) = do - a <- fst <$> wrapExpect `(expectEq) ctx loc ty - eraseTerm (extendDim body.name ctx) a.term body.term +eraseTerm' defs ctx ty (DLam body loc) = do + a <- fst <$> wrapExpect `(expectEq) defs ctx loc ty + eraseTerm defs (extendDim body.name ctx) a.term body.term -eraseTerm ctx _ s@(NAT {}) = +eraseTerm' defs ctx _ s@(NAT {}) = throw $ CompileTimeOnly ctx s -- n ⤋ n ⇐ ℕ -eraseTerm _ _ (Nat n loc) = +eraseTerm' _ _ _ (Nat n loc) = pure $ Nat n loc -- s ⤋ s' ⇐ ℕ -- ----------------------- -- succ s ⤋ succ s' ⇐ ℕ -eraseTerm ctx ty (Succ p loc) = do - p <- eraseTerm ctx ty p +eraseTerm' defs ctx ty (Succ p loc) = do + p <- eraseTerm defs ctx ty p pure $ Succ p loc -eraseTerm ctx ty s@(STRING {}) = +eraseTerm' defs ctx ty s@(STRING {}) = throw $ CompileTimeOnly ctx s -- s ⤋ s ⇐ String -eraseTerm _ _ (Str s loc) = +eraseTerm' _ _ _ (Str s loc) = pure $ Str s loc -eraseTerm ctx ty s@(BOX {}) = +eraseTerm' defs ctx ty s@(BOX {}) = throw $ CompileTimeOnly ctx s -- [s] ⤋ ⌷ ⇐ [0.A] @@ -216,48 +226,49 @@ eraseTerm ctx ty s@(BOX {}) = -- π ≠ 0 s ⤋ s' ⇐ A -- -------------------- -- [s] ⤋ s' ⇐ [π.A] -eraseTerm ctx ty (Box val loc) = do - (qty, a) <- wrapExpect `(expectBOX) ctx loc ty +eraseTerm' defs ctx ty (Box val loc) = do + (qty, a) <- wrapExpect `(expectBOX) defs ctx loc ty case isErased qty of Erased => pure $ Erased loc - Kept => eraseTerm ctx a val + Kept => eraseTerm defs ctx a val -- s ⤋ s' ⇐ A -- --------------------------------- -- let0 x = e in s ⤋ s'[⌷/x] ⇐ A -- --- e ⤋ e' s ⤋ s' ⇐ A π ≠ 0 +-- e ⤋ e' ⇒ E π ≠ 0 +-- x : E ≔ e ⊢ s ⤋ s' ⇐ A -- ------------------------------------- -- letπ x = e in s ⤋ let x = e' in s' -eraseTerm ctx ty (Let pi e s loc) = do +eraseTerm' defs ctx ty (Let pi e s loc) = do let x = s.name case isErased pi of Erased => do - ety <- computeElimType ctx SZero e - s' <- eraseTerm (extendTy pi x ety ctx) (weakT 1 ty) s.term + ety <- computeElimType defs ctx SZero e + s' <- eraseTerm defs (extendTyLet pi x ety (E e) ctx) (weakT 1 ty) s.term pure $ sub1 (Erased e.loc) s' Kept => do - EraRes ety e' <- eraseElim ctx e - s' <- eraseTerm (extendTy pi x ety ctx) (weakT 1 ty) s.term + EraRes ety e' <- eraseElim defs ctx e + s' <- eraseTerm defs (extendTyLet pi x ety (E e) ctx) (weakT 1 ty) s.term pure $ Let x e' s' loc -- e ⤋ e' ⇒ B -- ------------ -- e ⤋ e' ⇐ A -eraseTerm ctx ty (E e) = - term <$> eraseElim ctx e +eraseTerm' defs ctx ty (E e) = + term <$> eraseElim defs ctx e -eraseTerm ctx ty (CloT (Sub term th)) = - eraseTerm ctx ty $ pushSubstsWith' id th term +eraseTerm' defs ctx ty (CloT (Sub term th)) = + eraseTerm defs ctx ty $ pushSubstsWith' id th term -eraseTerm ctx ty (DCloT (Sub term th)) = - eraseTerm ctx ty $ pushSubstsWith' th id term +eraseTerm' defs ctx ty (DCloT (Sub term th)) = + eraseTerm defs ctx ty $ pushSubstsWith' th id term -- defω x : A = s -- ---------------- -- x ⤋ x ⇒ A -eraseElim ctx e@(F x u loc) = do - Just def <- asksAt DEFS $ lookup x +eraseElim defs ctx e@(F x u loc) = do + let Just def = lookup x defs | Nothing => throw $ notInScope loc x case isErased def.qty.qty of Erased => throw $ CompileTimeOnly ctx $ E e @@ -266,10 +277,10 @@ eraseElim ctx e@(F x u loc) = do -- π.x ∈ Σ π ≠ 0 -- ----------------- -- x ⤋ x ⇒ A -eraseElim ctx e@(B i loc) = do +eraseElim defs ctx e@(B i loc) = do case isErased $ ctx.qtys !!! i of Erased => throw $ CompileTimeOnly ctx $ E e - Kept => pure $ EraRes (ctx.tctx !! i) $ B i loc + Kept => pure $ EraRes (ctx.tctx !! i).type $ B i loc -- f ⤋ f' ⇒ π.(x : A) → B s ⤋ s' ⇒ A π ≠ 0 -- --------------------------------------------- @@ -278,13 +289,13 @@ eraseElim ctx e@(B i loc) = do -- f ⤋ f' ⇒ 0.(x : A) → B -- ------------------------- -- f s ⤋ f' ⇒ B[s/x] -eraseElim ctx (App fun arg loc) = do - efun <- eraseElim ctx fun - (qty, targ, tres) <- wrapExpect `(expectPi) ctx loc efun.type +eraseElim defs ctx (App fun arg loc) = do + efun <- eraseElim defs ctx fun + (qty, targ, tres) <- wrapExpect `(expectPi) defs ctx loc efun.type let ty = sub1 tres (Ann arg targ arg.loc) case isErased qty of Erased => pure $ EraRes ty efun.term - Kept => do arg <- eraseTerm ctx targ arg + Kept => do arg <- eraseTerm defs ctx targ arg pure $ EraRes ty $ App efun.term arg loc -- e ⇒ (x : A) × B @@ -298,16 +309,16 @@ eraseElim ctx (App fun arg loc) = do -- (caseρ e return z ⇒ R of {(x, y) ⇒ s}) ⤋ -- ⤋ -- let xy = e' in let x = fst xy in let y = snd xy in s' ⇒ R[e/z] -eraseElim ctx (CasePair qty pair ret body loc) = do +eraseElim defs ctx (CasePair qty pair ret body loc) = do let [< x, y] = body.names case isErased qty of Kept => do - EraRes ety eterm <- eraseElim ctx pair + EraRes ety eterm <- eraseElim defs ctx pair let ty = sub1 (ret // shift 2) $ Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 ety) loc - (tfst, tsnd) <- wrapExpect `(expectSig) ctx loc ety + (tfst, tsnd) <- wrapExpect `(expectSig) defs ctx loc ety let ctx' = extendTyN [< (qty, x, tfst), (qty, y, tsnd.term)] ctx - body' <- eraseTerm ctx' ty body.term + body' <- eraseTerm defs ctx' ty body.term p <- mnb "p" loc pure $ EraRes (sub1 ret pair) $ Let p eterm @@ -316,28 +327,28 @@ eraseElim ctx (CasePair qty pair ret body loc) = do (body' // (B VZ loc ::: B (VS VZ) loc ::: shift 3)) loc) loc) loc Erased => do - ety <- computeElimType ctx SOne pair + ety <- computeElimType defs ctx SOne pair let ty = sub1 (ret // shift 2) $ Ann (Pair (BVT 0 loc) (BVT 1 loc) loc) (weakT 2 ety) loc - (tfst, tsnd) <- wrapExpect `(expectSig) ctx loc ety + (tfst, tsnd) <- wrapExpect `(expectSig) defs ctx loc ety let ctx' = extendTyN0 [< (x, tfst), (y, tsnd.term)] ctx - body' <- eraseTerm ctx' ty body.term + body' <- eraseTerm defs ctx' ty body.term pure $ EraRes (sub1 ret pair) $ subN [< Erased loc, Erased loc] body' -- e ⤋ e' ⇒ (x : A) × B -- ---------------------- -- fst e ⤋ fst e' ⇒ A -eraseElim ctx (Fst pair loc) = do - epair <- eraseElim ctx pair - a <- fst <$> wrapExpect `(expectSig) ctx loc epair.type +eraseElim defs ctx (Fst pair loc) = do + epair <- eraseElim defs ctx pair + a <- fst <$> wrapExpect `(expectSig) defs ctx loc epair.type pure $ EraRes a $ Fst epair.term loc -- e ⤋ e' ⇒ (x : A) × B -- ----------------------------- -- snd e ⤋ snd e' ⇒ B[fst e/x] -eraseElim ctx (Snd pair loc) = do - epair <- eraseElim ctx pair - b <- snd <$> wrapExpect `(expectSig) ctx loc epair.type +eraseElim defs ctx (Snd pair loc) = do + epair <- eraseElim defs ctx pair + b <- snd <$> wrapExpect `(expectSig) defs ctx loc epair.type pure $ EraRes (sub1 b (Fst pair loc)) $ Snd epair.term loc -- caseρ e return z ⇒ R of {} ⤋ absurd ⇒ R[e/z] @@ -349,23 +360,23 @@ eraseElim ctx (Snd pair loc) = do -- e ⤋ e' ⇒ A sᵢ ⤋ s'ᵢ ⇐ R[𝐚ᵢ/z] ρ ≠ 0 i ≠ 0 -- ------------------------------------------------------------------- -- caseρ e return z ⇒ R of {𝐚ᵢ ⇒ sᵢ} ⤋ case e of {𝐚ᵢ ⇒ s'ᵢ} ⇒ R[e/z] -eraseElim ctx e@(CaseEnum qty tag ret arms loc) = do +eraseElim defs ctx e@(CaseEnum qty tag ret arms loc) = do let ty = sub1 ret tag case isErased qty of Erased => case SortedMap.toList arms of [] => pure $ EraRes ty $ Absurd loc [(t, rhs)] => do let ty' = sub1 ret (Ann (Tag t loc) (enum [t] loc) loc) - rhs' <- eraseTerm ctx ty' rhs + rhs' <- eraseTerm defs ctx ty' rhs pure $ EraRes ty rhs' _ => throw $ CompileTimeOnly ctx $ E e Kept => case List1.fromList $ SortedMap.toList arms of Nothing => pure $ EraRes ty $ Absurd loc Just arms => do - etag <- eraseElim ctx tag + etag <- eraseElim defs ctx tag arms <- for arms $ \(t, rhs) => do let ty' = sub1 ret (Ann (Tag t loc) etag.type loc) - rhs' <- eraseTerm ctx ty' rhs + rhs' <- eraseTerm defs ctx ty' rhs pure (t, rhs') pure $ EraRes ty $ CaseEnum etag.term arms loc @@ -382,12 +393,12 @@ eraseElim ctx e@(CaseEnum qty tag ret arms loc) = do -- caseρ n return z ⇒ R of {0 ⇒ z; succ m, 0.ih ⇒ s} -- ⤋ -- case n' of {0 ⇒ z'; succ m ⇒ s'[⌷/ih]} ⇒ R[n/z] -eraseElim ctx (CaseNat qty qtyIH nat ret zero succ loc) = do +eraseElim defs ctx (CaseNat qty qtyIH nat ret zero succ loc) = do let ty = sub1 ret nat - enat <- eraseElim ctx nat - zero <- eraseTerm ctx (sub1 ret (Ann (Zero loc) (NAT loc) loc)) zero + enat <- eraseElim defs ctx nat + zero <- eraseTerm defs ctx (sub1 ret (Ann (Zero loc) (NAT loc) loc)) zero let [< p, ih] = succ.names - succ' <- eraseTerm + succ' <- eraseTerm defs (extendTyN [< (qty, p, NAT loc), (qtyIH, ih, sub1 (ret // shift 1) (BV 0 loc))] ctx) (sub1 (ret // shift 2) (Ann (Succ (BVT 1 loc) loc) (NAT loc) loc)) @@ -404,56 +415,56 @@ eraseElim ctx (CaseNat qty qtyIH nat ret zero succ loc) = do -- b ⇒ [π.A] x : A | 0.x ⊢ s ⤋ s' ⇐ R[[x]∷[0.A]/z] πρ = 0 -- ------------------------------------------------------------- -- caseρ b return z ⇒ R of {[x] ⇒ s} ⤋ s'[⌷/x] ⇒ R[b/z] -eraseElim ctx (CaseBox qty box ret body loc) = do - tbox <- computeElimType ctx SOne box -- [fixme] is there any way to avoid this? - (pi, tinner) <- wrapExpect `(expectBOX) ctx loc tbox +eraseElim defs ctx (CaseBox qty box ret body loc) = do + tbox <- computeElimType defs ctx SOne box + (pi, tinner) <- wrapExpect `(expectBOX) defs ctx loc tbox let ctx' = extendTy (pi * qty) body.name tinner ctx bty = sub1 (ret // shift 1) $ Ann (Box (BVT 0 loc) loc) (weakT 1 tbox) loc case isErased $ qty * pi of Kept => do - ebox <- eraseElim ctx box - ebody <- eraseTerm ctx' bty body.term + ebox <- eraseElim defs ctx box + ebody <- eraseTerm defs ctx' bty body.term pure $ EraRes (sub1 ret box) $ Let body.name ebox.term ebody loc Erased => do - body' <- eraseTerm ctx' bty body.term + body' <- eraseTerm defs ctx' bty body.term pure $ EraRes (sub1 ret box) $ body' // one (Erased loc) -- f ⤋ f' ⇒ Eq (𝑖 ⇒ A) l r -- ------------------------------ -- f @r ⤋ f' ⇒ A‹r/𝑖› -eraseElim ctx (DApp fun arg loc) = do - efun <- eraseElim ctx fun - a <- fst <$> wrapExpect `(expectEq) ctx loc efun.type +eraseElim defs ctx (DApp fun arg loc) = do + efun <- eraseElim defs ctx fun + a <- fst <$> wrapExpect `(expectEq) defs ctx loc efun.type pure $ EraRes (dsub1 a arg) efun.term -- s ⤋ s' ⇐ A -- ---------------- -- s ∷ A ⤋ s' ⇒ A -eraseElim ctx (Ann tm ty loc) = - EraRes ty <$> eraseTerm ctx ty tm +eraseElim defs ctx (Ann tm ty loc) = + EraRes ty <$> eraseTerm defs ctx ty tm -- s ⤋ s' ⇐ A‹p/𝑖› -- ----------------------------------- -- coe (𝑖 ⇒ A) @p @q s ⤋ s' ⇒ A‹q/𝑖› -eraseElim ctx (Coe ty p q val loc) = do - val <- eraseTerm ctx (dsub1 ty p) val +eraseElim defs ctx (Coe ty p q val loc) = do + val <- eraseTerm defs ctx (dsub1 ty p) val pure $ EraRes (dsub1 ty q) val -- s ⤋ s' ⇐ A -- -------------------------------- -- comp A @p @q s @r {⋯} ⤋ s' ⇒ A -eraseElim ctx (Comp ty p q val r zero one loc) = - EraRes ty <$> eraseTerm ctx ty val +eraseElim defs ctx (Comp ty p q val r zero one loc) = + EraRes ty <$> eraseTerm defs ctx ty val -eraseElim ctx t@(TypeCase ty ret arms def loc) = +eraseElim defs ctx t@(TypeCase ty ret arms def loc) = throw $ CompileTimeOnly ctx $ E t -eraseElim ctx (CloE (Sub term th)) = - eraseElim ctx $ pushSubstsWith' id th term +eraseElim defs ctx (CloE (Sub term th)) = + eraseElim defs ctx $ pushSubstsWith' id th term -eraseElim ctx (DCloE (Sub term th)) = - eraseElim ctx $ pushSubstsWith' th id term +eraseElim defs ctx (DCloE (Sub term th)) = + eraseElim defs ctx $ pushSubstsWith' th id term export @@ -539,8 +550,8 @@ trimLets (Erased loc) = Erased loc export covering -eraseDef : Name -> Q.Definition -> Eff Erase U.Definition -eraseDef name def@(MkDef qty type body scheme isMain loc) = +eraseDef : Q.Definitions -> Name -> Q.Definition -> Eff Erase U.Definition +eraseDef defs name def@(MkDef qty type body scheme isMain loc) = wrapErr (WhileErasing name def) $ case isErased qty.qty of Erased => do @@ -552,4 +563,4 @@ eraseDef name def@(MkDef qty type body scheme isMain loc) = Nothing => case body of Postulate => throw $ Postulate loc name Concrete body => KeptDef isMain . trimLets <$> - eraseTerm empty type body + eraseTerm defs empty type body diff --git a/lib/Quox/Whnf/Coercion.idr b/lib/Quox/Whnf/Coercion.idr index 0e35665..4b900bf 100644 --- a/lib/Quox/Whnf/Coercion.idr +++ b/lib/Quox/Whnf/Coercion.idr @@ -28,7 +28,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} export covering piCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val, s : Term d n) -> Loc -> - Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg)) + Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg)) piCoe sty@(S [< i] ty) p q val s loc = do -- (coe [i ⇒ π.(x : A) → B] @p @q t) s ⇝ -- coe [i ⇒ B[𝒔‹i›/x] @p @q ((t ∷ (π.(x : A) → B)‹p/i›) 𝒔‹p›) @@ -49,7 +49,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} sigCoe : (qty : Qty) -> (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> (ret : ScopeTerm d n) -> (body : ScopeTermN 2 d n) -> Loc -> - Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg)) + Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg)) sigCoe qty sty@(S [< i] ty) p q val ret body loc = do -- caseπ (coe [i ⇒ (x : A) × B] @p @q s) return z ⇒ C of { (a, b) ⇒ e } -- ⇝ @@ -74,7 +74,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} ||| reduce a pair projection `Fst (Coe ty p q val) loc` export covering fstCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> - Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg)) + Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg)) fstCoe sty@(S [< i] ty) p q val loc = do -- fst (coe (𝑖 ⇒ (x : A) × B) @p @q s) -- ⇝ @@ -91,7 +91,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} ||| reduce a pair projection `Snd (Coe ty p q val) loc` export covering sndCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> - Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg)) + Loc -> Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg)) sndCoe sty@(S [< i] ty) p q val loc = do -- snd (coe (𝑖 ⇒ (x : A) × B) @p @q s) -- ⇝ @@ -115,7 +115,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} export covering eqCoe : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) -> Loc -> - Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg)) + Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg)) eqCoe sty@(S [< j] ty) p q val r loc = do -- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r -- ⇝ @@ -133,7 +133,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} boxCoe : (qty : Qty) -> (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> (ret : ScopeTerm d n) -> (body : ScopeTerm d n) -> Loc -> - Eff Whnf (Subset (Elim d n) (No . isRedexE defs sg)) + Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx sg)) boxCoe qty sty@(S [< i] ty) p q val ret body loc = do -- caseπ (coe [i ⇒ [ρ. A]] @p @q s) return z ⇒ C of { [a] ⇒ e } -- ⇝ @@ -151,7 +151,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} pushCoe : BindName -> (ty : Term (S d) n) -> (p, q : Dim d) -> (s : Term d n) -> Loc -> (0 pc : So (canPushCoe sg ty s)) => - Eff Whnf (NonRedex Elim d n defs sg) + Eff Whnf (NonRedex Elim d n defs ctx sg) pushCoe i ty p q s loc = case ty of -- (coe ★ᵢ @_ @_ s) ⇝ (s ∷ ★ᵢ) diff --git a/lib/Quox/Whnf/ComputeElimType.idr b/lib/Quox/Whnf/ComputeElimType.idr index 441ba1e..87891ff 100644 --- a/lib/Quox/Whnf/ComputeElimType.idr +++ b/lib/Quox/Whnf/ComputeElimType.idr @@ -14,8 +14,8 @@ export covering computeElimType : CanWhnf Term Interface.isRedexT => CanWhnf Elim Interface.isRedexE => - (defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) -> - (e : Elim d n) -> (0 ne : No (isRedexE defs sg e)) => + (defs : Definitions) -> (ctx : WhnfContext d n) -> (0 sg : SQty) -> + (e : Elim d n) -> (0 ne : No (isRedexE defs ctx sg e)) => Eff Whnf (Term d n) @@ -24,8 +24,8 @@ export covering computeWhnfElimType0 : CanWhnf Term Interface.isRedexT => CanWhnf Elim Interface.isRedexE => - (defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) -> - (e : Elim d n) -> (0 ne : No (isRedexE defs sg e)) => + (defs : Definitions) -> (ctx : WhnfContext d n) -> (0 sg : SQty) -> + (e : Elim d n) -> (0 ne : No (isRedexE defs ctx sg e)) => Eff Whnf (Term d n) computeElimType defs ctx sg e = @@ -36,7 +36,7 @@ computeElimType defs ctx sg e = pure $ def.typeWithAt ctx.dimLen ctx.termLen u B i _ => - pure $ ctx.tctx !! i + pure (ctx.tctx !! i).type App f s loc => case !(computeWhnfElimType0 defs ctx sg f {ne = noOr1 ne}) of diff --git a/lib/Quox/Whnf/Interface.idr b/lib/Quox/Whnf/Interface.idr index 15a8978..d2b11da 100644 --- a/lib/Quox/Whnf/Interface.idr +++ b/lib/Quox/Whnf/Interface.idr @@ -18,13 +18,14 @@ Whnf = [Except Error, NameGen] public export 0 RedexTest : TermLike -> Type -RedexTest tm = {0 d, n : Nat} -> Definitions -> SQty -> tm d n -> Bool +RedexTest tm = + {0 d, n : Nat} -> Definitions -> WhnfContext d n -> SQty -> tm d n -> Bool public export interface CanWhnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm where whnf : (defs : Definitions) -> (ctx : WhnfContext d n) -> (q : SQty) -> - tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs q)) + tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs ctx q)) -- having isRedex be part of the class header, and needing to be explicitly -- quantified on every use since idris can't infer its type, is a little ugly. -- but none of the alternatives i've thought of so far work. e.g. in some @@ -37,19 +38,20 @@ whnf0 defs ctx q t = fst <$> whnf defs ctx q t public export 0 IsRedex, NotRedex : {isRedex : RedexTest tm} -> CanWhnf tm isRedex => - Definitions -> SQty -> Pred (tm d n) -IsRedex defs q = So . isRedex defs q -NotRedex defs q = No . isRedex defs q + Definitions -> WhnfContext d n -> SQty -> Pred (tm d n) +IsRedex defs ctx q = So . isRedex defs ctx q +NotRedex defs ctx q = No . isRedex defs ctx q public export 0 NonRedex : (tm : TermLike) -> {isRedex : RedexTest tm} -> CanWhnf tm isRedex => (d, n : Nat) -> - (defs : Definitions) -> SQty -> Type -NonRedex tm d n defs q = Subset (tm d n) (NotRedex defs q) + Definitions -> WhnfContext d n -> SQty -> Type +NonRedex tm d n defs ctx q = Subset (tm d n) (NotRedex defs ctx q) public export %inline nred : {0 isRedex : RedexTest tm} -> (0 _ : CanWhnf tm isRedex) => - (t : tm d n) -> (0 nr : NotRedex defs q t) => NonRedex tm d n defs q + (t : tm d n) -> (0 nr : NotRedex defs ctx q t) => + NonRedex tm d n defs ctx q nred t = Element t nr @@ -193,50 +195,52 @@ mutual ||| a reducible elimination ||| ||| 1. a free variable, if its definition is known - ||| 2. an elimination whose head is reducible - ||| 3. an "active" elimination: + ||| 2. a bound variable pointing to a `let` + ||| 3. an elimination whose head is reducible + ||| 4. an "active" elimination: ||| an application whose head is an annotated lambda, ||| a case expression whose head is an annotated constructor form, etc - ||| 4. a redundant annotation, or one whose term or type is reducible - ||| 5. a coercion `coe (𝑖 ⇒ A) @p @q s` where: + ||| 5. a redundant annotation, or one whose term or type is reducible + ||| 6. a coercion `coe (𝑖 ⇒ A) @p @q s` where: ||| a. `A` is reducible or a type constructor, or ||| b. `𝑖` is not mentioned in `A` ||| ([fixme] should be A‹0/𝑖› = A‹1/𝑖›), or ||| c. `p = q` - ||| 6. a composition `comp A @p @q s @r {⋯}` + ||| 7. a composition `comp A @p @q s @r {⋯}` ||| where `p = q`, `r = 0`, or `r = 1` - ||| 7. a closure + ||| 8. a closure public export isRedexE : RedexTest Elim - isRedexE defs sg (F {x, u, _}) = isJust $ lookupElim0 x u defs - isRedexE _ sg (B {}) = False - isRedexE defs sg (App {fun, _}) = - isRedexE defs sg fun || isLamHead fun - isRedexE defs sg (CasePair {pair, _}) = - isRedexE defs sg pair || isPairHead pair || isYes (sg `decEq` SZero) - isRedexE defs sg (Fst pair _) = - isRedexE defs sg pair || isPairHead pair - isRedexE defs sg (Snd pair _) = - isRedexE defs sg pair || isPairHead pair - isRedexE defs sg (CaseEnum {tag, _}) = - isRedexE defs sg tag || isTagHead tag - isRedexE defs sg (CaseNat {nat, _}) = - isRedexE defs sg nat || isNatHead nat - isRedexE defs sg (CaseBox {box, _}) = - isRedexE defs sg box || isBoxHead box - isRedexE defs sg (DApp {fun, arg, _}) = - isRedexE defs sg fun || isDLamHead fun || isK arg - isRedexE defs sg (Ann {tm, ty, _}) = - isE tm || isRedexT defs sg tm || isRedexT defs SZero ty - isRedexE defs sg (Coe {ty = S _ (N _), _}) = True - isRedexE defs sg (Coe {ty = S _ (Y ty), p, q, val, _}) = - isRedexT defs SZero ty || canPushCoe sg ty val || isYes (p `decEqv` q) - isRedexE defs sg (Comp {ty, p, q, r, _}) = + isRedexE defs ctx sg (F {x, u, _}) = isJust $ lookupElim0 x u defs + isRedexE _ ctx sg (B {i, _}) = isJust (ctx.tctx !! i).term + isRedexE defs ctx sg (App {fun, _}) = + isRedexE defs ctx sg fun || isLamHead fun + isRedexE defs ctx sg (CasePair {pair, _}) = + isRedexE defs ctx sg pair || isPairHead pair || isYes (sg `decEq` SZero) + isRedexE defs ctx sg (Fst pair _) = + isRedexE defs ctx sg pair || isPairHead pair + isRedexE defs ctx sg (Snd pair _) = + isRedexE defs ctx sg pair || isPairHead pair + isRedexE defs ctx sg (CaseEnum {tag, _}) = + isRedexE defs ctx sg tag || isTagHead tag + isRedexE defs ctx sg (CaseNat {nat, _}) = + isRedexE defs ctx sg nat || isNatHead nat + isRedexE defs ctx sg (CaseBox {box, _}) = + isRedexE defs ctx sg box || isBoxHead box + isRedexE defs ctx sg (DApp {fun, arg, _}) = + isRedexE defs ctx sg fun || isDLamHead fun || isK arg + isRedexE defs ctx sg (Ann {tm, ty, _}) = + isE tm || isRedexT defs ctx sg tm || isRedexT defs ctx SZero ty + isRedexE defs ctx sg (Coe {ty = S _ (N _), _}) = True + isRedexE defs ctx sg (Coe {ty = S [< i] (Y ty), p, q, val, _}) = + isRedexT defs (extendDim i ctx) SZero ty || + canPushCoe sg ty val || isYes (p `decEqv` q) + isRedexE defs ctx sg (Comp {ty, p, q, r, _}) = isYes (p `decEqv` q) || isK r - isRedexE defs sg (TypeCase {ty, ret, _}) = - isRedexE defs sg ty || isRedexT defs sg ret || isAnnTyCon ty - isRedexE _ _ (CloE {}) = True - isRedexE _ _ (DCloE {}) = True + isRedexE defs ctx sg (TypeCase {ty, ret, _}) = + isRedexE defs ctx sg ty || isRedexT defs ctx sg ret || isAnnTyCon ty + isRedexE _ _ _ (CloE {}) = True + isRedexE _ _ _ (DCloE {}) = True ||| a reducible term ||| @@ -248,9 +252,9 @@ mutual ||| 5. a `let` expression public export isRedexT : RedexTest Term - isRedexT _ _ (CloT {}) = True - isRedexT _ _ (DCloT {}) = True - isRedexT _ _ (Let {}) = True - isRedexT defs sg (E {e, _}) = isAnn e || isRedexE defs sg e - isRedexT _ _ (Succ p {}) = isNatConst p - isRedexT _ _ _ = False + isRedexT _ _ _ (CloT {}) = True + isRedexT _ _ _ (DCloT {}) = True + isRedexT _ _ _ (Let {}) = True + isRedexT defs ctx sg (E {e, _}) = isAnn e || isRedexE defs ctx sg e + isRedexT _ _ _ (Succ p {}) = isNatConst p + isRedexT _ _ _ _ = False diff --git a/lib/Quox/Whnf/Main.idr b/lib/Quox/Whnf/Main.idr index 9248edf..2c0a67a 100644 --- a/lib/Quox/Whnf/Main.idr +++ b/lib/Quox/Whnf/Main.idr @@ -20,7 +20,10 @@ CanWhnf Elim Interface.isRedexE where _ | Just y = whnf defs ctx sg $ setLoc loc $ injElim ctx y _ | Nothing = pure $ Element (F x u loc) $ rewrite eq in Ah - whnf _ _ _ (B i loc) = pure $ nred $ B i loc + whnf defs ctx sg (B i loc) with (ctx.tctx !! i) proof eq1 + _ | l with (l.term) proof eq2 + _ | Just y = whnf defs ctx sg $ Ann y l.type loc + _ | Nothing = pure $ Element (B i loc) $ rewrite eq1 in rewrite eq2 in Ah -- ((λ x ⇒ t) ∷ (π.x : A) → B) s ⇝ t[s∷A/x] ∷ B[s∷A/x] whnf defs ctx sg (App f s appLoc) = do diff --git a/lib/Quox/Whnf/TypeCase.idr b/lib/Quox/Whnf/TypeCase.idr index a42c0d9..2fc34ba 100644 --- a/lib/Quox/Whnf/TypeCase.idr +++ b/lib/Quox/Whnf/TypeCase.idr @@ -35,7 +35,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} ||| for an elim returns a pair of type-cases that will reduce to that; ||| for other intro forms error export covering - tycasePi : (t : Term d n) -> (0 tnf : No (isRedexT defs SZero t)) => + tycasePi : (t : Term d n) -> (0 tnf : No (isRedexT defs ctx SZero t)) => Eff Whnf (Term d n, ScopeTerm d n) tycasePi (Pi {arg, res, _}) = pure (arg, res) tycasePi (E e) {tnf} = do @@ -53,7 +53,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} ||| for an elim returns a pair of type-cases that will reduce to that; ||| for other intro forms error export covering - tycaseSig : (t : Term d n) -> (0 tnf : No (isRedexT defs SZero t)) => + tycaseSig : (t : Term d n) -> (0 tnf : No (isRedexT defs ctx SZero t)) => Eff Whnf (Term d n, ScopeTerm d n) tycaseSig (Sig {fst, snd, _}) = pure (fst, snd) tycaseSig (E e) {tnf} = do @@ -71,7 +71,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} ||| for an elim returns a type-case that will reduce to that; ||| for other intro forms error export covering - tycaseBOX : (t : Term d n) -> (0 tnf : No (isRedexT defs SZero t)) => + tycaseBOX : (t : Term d n) -> (0 tnf : No (isRedexT defs ctx SZero t)) => Eff Whnf (Term d n) tycaseBOX (BOX {ty, _}) = pure ty tycaseBOX (E e) {tnf} = do @@ -83,7 +83,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} ||| for an elim returns five type-cases that will reduce to that; ||| for other intro forms error export covering - tycaseEq : (t : Term d n) -> (0 tnf : No (isRedexT defs SZero t)) => + tycaseEq : (t : Term d n) -> (0 tnf : No (isRedexT defs ctx SZero t)) => Eff Whnf (Term d n, Term d n, DScopeTerm d n, Term d n, Term d n) tycaseEq (Eq {ty, l, r, _}) = pure (ty.zero, ty.one, ty, l, r) tycaseEq (E e) {tnf} = do @@ -107,7 +107,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} reduceTypeCase : (ty : Term d n) -> (u : Universe) -> (ret : Term d n) -> (arms : TypeCaseArms d n) -> (def : Term d n) -> (0 _ : So (isTyCon ty)) => Loc -> - Eff Whnf (Subset (Elim d n) (No . isRedexE defs SZero)) + Eff Whnf (Subset (Elim d n) (No . isRedexE defs ctx SZero)) reduceTypeCase ty u ret arms def loc = case ty of -- (type-case ★ᵢ ∷ _ return Q of { ★ ⇒ s; ⋯ }) ⇝ s ∷ Q TYPE {} => diff --git a/tests/AstExtra.idr b/tests/AstExtra.idr index f9cc1fd..76257b7 100644 --- a/tests/AstExtra.idr +++ b/tests/AstExtra.idr @@ -24,13 +24,17 @@ anys : {n : Nat} -> QContext n anys {n = 0} = [<] anys {n = S n} = anys :< Any +public export +locals : Context (Term d) n -> Context (LocalVar d) n +locals = map $ \t => MkLocal t Nothing + public export ctx, ctx01 : {n : Nat} -> Context (\n => (BindName, Term 0 n)) n -> TyContext 0 n ctx tel = let (ns, ts) = unzip tel in - MkTyContext new [<] ts ns anys + MkTyContext new [<] (locals ts) ns anys ctx01 tel = let (ns, ts) = unzip tel in - MkTyContext ZeroIsOne [<] ts ns anys + MkTyContext ZeroIsOne [<] (locals ts) ns anys export mkDef : GQty -> Term 0 0 -> Term 0 0 -> Definition diff --git a/tests/Tests/Reduce.idr b/tests/Tests/Reduce.idr index 66595cb..40c071e 100644 --- a/tests/Tests/Reduce.idr +++ b/tests/Tests/Reduce.idr @@ -33,7 +33,7 @@ parameters {0 isRedex : RedexTest tm} {auto _ : CanWhnf tm isRedex} {d, n : Nat} private ctx : {n : Nat} -> Context (\n => (BindName, Term 0 n)) n -> WhnfContext 0 n -ctx xs = let (ns, ts) = unzip xs in MkWhnfContext [<] ns ts +ctx xs = let (ns, ts) = unzip xs in MkWhnfContext [<] ns (locals ts) export From 0fdd4741be7850577f184cdf2535d4f5381b1a9b Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 7 Dec 2023 01:37:08 +0100 Subject: [PATCH 070/133] print quantity on let --- lib/Quox/Syntax/Term/Pretty.idr | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index e686a74..e51513d 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -349,9 +349,10 @@ prettyLets dnames xs lets = sequence $ snd $ go lets where go (lets :< (qty, x, rhs)) = let (ys, docs) = go lets doc = do - x <- prettyTBind x - rhs <- withPrec Outer $ assert_total prettyElim dnames ys rhs - hangDSingle (hsep [!letD, x, !cstD]) (hsep [rhs, !inD]) in + lett <- [|letD <+> prettyQty qty|] + x <- prettyTBind x + rhs <- withPrec Outer $ assert_total prettyElim dnames ys rhs + hangDSingle (hsep [lett, x, !cstD]) (hsep [rhs, !inD]) in (ys :< x, docs :< doc) From 7afcbfe258fe96d5e22f08ead1dde13b3eb2e1ed Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 21 Dec 2023 17:48:12 +0100 Subject: [PATCH 071/133] recognise nats other than 0 in eq checker --- lib/Quox/Equal.idr | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 9a69ffb..3ec9c0a 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -305,10 +305,10 @@ namespace Term (E _, Nat 0 {}) => clashT s.loc ctx nat s t (E _, Succ {}) => clashT s.loc ctx nat s t - (Nat 0 {}, t) => wrongType t.loc ctx nat t - (Succ {}, t) => wrongType t.loc ctx nat t - (E _, t) => wrongType t.loc ctx nat t - (s, _) => wrongType s.loc ctx nat s + (Nat {}, t) => wrongType t.loc ctx nat t + (Succ {}, t) => wrongType t.loc ctx nat t + (E _, t) => wrongType t.loc ctx nat t + (s, _) => wrongType s.loc ctx nat s compare0' defs ctx sg str@(STRING {}) s t = local_ Equal $ case (s, t) of From 54db7e27ef5e37ef99440e951a42a4ae6ca1da85 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 21 Dec 2023 17:53:46 +0100 Subject: [PATCH 072/133] make #[fail] run in the current namespace --- lib/Quox/Parser/FromParser.idr | 7 ++++--- 1 file changed, 4 insertions(+), 3 deletions(-) diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index b252f73..5907663 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -45,7 +45,8 @@ FromParserIO = FromParserPure ++ [LoadFile] export -fromParserPure : NameSuf -> Definitions -> +fromParserPure : {default [<] ns : Mods} -> + NameSuf -> Definitions -> Eff FromParserPure a -> Either Error (a, NameSuf, Definitions) fromParserPure suf defs act = runSTErr $ do @@ -54,7 +55,7 @@ fromParserPure suf defs act = runSTErr $ do res <- runEff act $ with Union.(::) [handleExcept (\e => stLeft e), handleStateSTRef defs, - handleStateSTRef !(liftST $ newSTRef [<]), + handleStateSTRef !(liftST $ newSTRef ns), handleStateSTRef suf] pure (res, !(liftST $ readSTRef suf), !(liftST $ readSTRef defs)) @@ -375,7 +376,7 @@ data HasFail = NoFail | AnyFail | FailWith String export covering expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error expectFail loc act = - case fromParserPure !(getAt GEN) !(getAt DEFS) act of + case fromParserPure !(getAt GEN) !(getAt DEFS) {ns = !(getAt NS)} act of Left err => pure err Right _ => throw $ ExpectedFail loc From aa4ead592a043028dae93577e30aadb3c6c88300 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 21 Dec 2023 17:54:31 +0100 Subject: [PATCH 073/133] allow "let x : A = e in s" with type annotation --- lib/Quox/Parser/Parser.idr | 20 +++++++++++++------- tests/Tests/Parser.idr | 2 ++ 2 files changed, 15 insertions(+), 7 deletions(-) diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index 6419c55..b34599c 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -593,15 +593,21 @@ letIntro fname = <|> withLoc fname (Just . PQ Any <$ res "letω") <|> Nothing <$ resC "let" -export +private letBinder : FileName -> Maybe PQty -> Grammar True (PQty, PatVar, PTerm) letBinder fname mq = do - qty <- the (Grammar False PQty) $ case mq of - Just q => pure q - Nothing => qty fname <* mustWork (resC ".") <|> defLoc fname (PQ One) - x <- patVar fname; mustWork (resC "=") - rhs <- term fname - pure $ (qty, x, rhs) + qty <- letQty fname mq + x <- patVar fname + type <- optional $ resC ":" *> term fname + rhs <- resC "=" *> term fname + pure (qty, x, makeLetRhs rhs type) +where + letQty : FileName -> Maybe PQty -> Grammar False PQty + letQty fname Nothing = qty fname <* mustWork (resC ".") <|> defLoc fname (PQ One) + letQty fname (Just q) = pure q + + makeLetRhs : PTerm -> Maybe PTerm -> PTerm + makeLetRhs tm ty = maybe tm (\t => Ann tm t (extendL tm.loc t.loc)) ty export letTerm : FileName -> Grammar True PTerm diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index e1f780a..4c0dc0f 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -422,6 +422,8 @@ tests = "parser" :- [ `(Let (PQ One _, PV "x" {}, V "y" {}) (V "z" {}) _), parseMatch term "letω x = y in z" `(Let (PQ Any _, PV "x" {}, V "y" {}) (V "z" {}) _), + parseMatch term "letω x : X = y in z" + `(Let (PQ Any _, PV "x" {}, Ann (V "y" {}) (V "X" {}) _) (V "z" {}) _), parseMatch term "let ω.x = y in z" `(Let (PQ Any _, PV "x" {}, V "y" {}) (V "z" {}) _), parseMatch term "let x = y1 y2 in z1 z2" From 48a050491cf64f3b5e6d2c9aeb7f49d0b67b9bf0 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 21 Dec 2023 18:01:17 +0100 Subject: [PATCH 074/133] fix several quantity issues MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit - contents of box intro - definition of let - non-recursive ℕ case - also make a few var names more consistent --- lib/Quox/Typechecker.idr | 31 ++++++++++++++++++------------- 1 file changed, 18 insertions(+), 13 deletions(-) diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index 53677a5..2a2ef36 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -208,16 +208,17 @@ mutual check' ctx sg (Box val loc) ty = do (q, ty) <- expectBOX !(askAt DEFS) ctx SZero ty.loc ty - -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ - valout <- checkC ctx sg val ty + -- if Ψ | Γ ⊢ σ ⨴ π · s ⇐ A ⊳ Σ + valout <- checkC ctx (subjMult sg q) val ty -- then Ψ | Γ ⊢ σ · [s] ⇐ [π.A] ⊳ πΣ pure $ q * valout check' ctx sg (Let qty rhs body loc) ty = do eres <- inferC ctx (subjMult sg qty) rhs - qout <- checkC (extendTyLet (qty * sg.qty) body.name eres.type (E rhs) ctx) + let sqty = sg.qty * qty + qout <- checkC (extendTyLet sqty body.name eres.type (E rhs) ctx) sg body.term (weakT 1 ty) - >>= popQ loc qty + >>= popQ loc sqty pure $ qty * eres.qout + qout check' ctx sg (E e) ty = do @@ -432,8 +433,8 @@ mutual checkTypeC (extendTy Zero ret.name nat ctx) ret.term Nothing -- if Ψ | Γ ⊢ σ · zer ⇐ A[0 ∷ ℕ/n] ⊳ Σz zerout <- checkC ctx sg zer $ sub1 ret $ Ann (Zero zer.loc) nat zer.loc - -- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ₁.p, ρ₂.ih - -- with ρ₂ ≤ π'σ, (ρ₁ + ρ₂) ≤ πσ + -- if Ψ | Γ, n : ℕ, ih : A ⊢ σ · suc ⇐ A[succ p ∷ ℕ/n] ⊳ Σs, ρ.p, ς.ih + -- with ς ≤ π'σ, (ρ + ς) ≤ πσ let [< p, ih] = suc.names pisg = pi * sg.qty sucCtx = extendTyN [< (pisg, p, NAT p.loc), (pi', ih, ret.term)] ctx @@ -442,24 +443,28 @@ mutual expectCompatQ loc qih (pi' * sg.qty) -- [fixme] better error here expectCompatQ loc (qp + qih) pisg - -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σz + ωΣs + -- if ς = 0, then Σb = lubs(Σz, Σs), otherwise Σb = Σz + ωςΣs + let bodyout = case qih of + Zero => lubs ctx [zerout, sucout] + _ => zerout + Any * sucout + -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ A[n] ⊳ πΣn + Σb pure $ InfRes { type = sub1 ret n, - qout = pi * nres.qout + zerout + Any * sucout + qout = pi * nres.qout + bodyout } infer' ctx sg (CaseBox pi box ret body loc) = do -- if Ψ | Γ ⊢ σ · b ⇒ [ρ.A] ⊳ Σ₁ boxres <- inferC ctx sg box - (q, ty) <- expectBOX !(askAt DEFS) ctx SZero box.loc boxres.type + (rh, ty) <- expectBOX !(askAt DEFS) ctx SZero box.loc boxres.type -- if Ψ | Γ, x : [ρ.A] ⊢₀ R ⇐ Type checkTypeC (extendTy Zero ret.name boxres.type ctx) ret.term Nothing - -- if Ψ | Γ, x : A ⊢ t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x + -- if Ψ | Γ, x : A ⊢ σ · t ⇐ R[[x] ∷ [ρ.A/x]] ⊳ Σ₂, ς·x -- with ς ≤ ρπσ - let qpisg = q * pi * sg.qty - bodyCtx = extendTy qpisg body.name ty ctx + let rhpisg = rh * pi * sg.qty + bodyCtx = extendTy rhpisg body.name ty ctx bodyType = substCaseBoxRet body.name ty ret - bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc qpisg + bodyout <- checkC bodyCtx sg body.term bodyType >>= popQ loc rhpisg -- then Ψ | Γ ⊢ caseπ ⋯ ⇒ R[b/x] ⊳ Σ₁ + Σ₂ pure $ InfRes { type = sub1 ret box, From b7074720ad1a6be51863aa1249e70f2d94197063 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 21 Dec 2023 18:03:57 +0100 Subject: [PATCH 075/133] pretty printing fixes --- lib/Quox/Pretty.idr | 6 ++-- lib/Quox/Syntax/Term/Pretty.idr | 57 ++++++++++++++++++++++++--------- lib/Quox/Typing/Context.idr | 10 +++--- lib/Quox/Typing/Error.idr | 7 ++-- lib/Quox/Untyped/Syntax.idr | 40 +++++++++-------------- 5 files changed, 71 insertions(+), 49 deletions(-) diff --git a/lib/Quox/Pretty.idr b/lib/Quox/Pretty.idr index 3472479..606ec78 100644 --- a/lib/Quox/Pretty.idr +++ b/lib/Quox/Pretty.idr @@ -308,9 +308,9 @@ export prettyApp : {opts : LayoutOpts} -> Nat -> Doc opts -> List (Doc opts) -> Doc opts prettyApp ind f args = - hsep (f :: args) - <|> hsep [f, vsep args] - <|> vsep (f :: map (indent ind) args) + ifMultiline + (hsep (f :: args)) + (f <++> vsep args <|> vsep (f :: map (indent ind) args)) export prettyAppD : {opts : LayoutOpts} -> Doc opts -> List (Doc opts) -> diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index e51513d..5a925cf 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -342,18 +342,39 @@ private covering prettyLets : {opts : LayoutOpts} -> BContext d -> BContext a -> Telescope (LetBinder d) a b -> Eff Pretty (SnocList (Doc opts)) -prettyLets dnames xs lets = sequence $ snd $ go lets where +prettyLets dnames xs lets = snd <$> go lets where + peelAnn : forall d, n. Elim d n -> Maybe (Term d n, Term d n) + peelAnn (Ann tm ty _) = Just (tm, ty) + peelAnn e = Nothing + + letHeader : Qty -> BindName -> Eff Pretty (Doc opts) + letHeader qty x = do + lett <- [|letD <+> prettyQty qty|] + x <- prettyTBind x + pure $ lett <++> x + + letBody : forall n. BContext n -> + Doc opts -> Elim d n -> Eff Pretty (Doc opts) + letBody tnames hdr e = case peelAnn e of + Just (tm, ty) => do + ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty + tm <- withPrec Outer $ assert_total prettyTerm dnames tnames tm + colon <- colonD; eq <- cstD; d <- askAt INDENT + pure $ hangSingle d (hangSingle d hdr (colon <++> ty)) (eq <++> tm) + Nothing => do + e <- withPrec Outer $ assert_total prettyElim dnames tnames e + eq <- cstD; d <- askAt INDENT + pure $ ifMultiline + (hsep [hdr, eq, e]) + (vsep [hdr, indent d $ hsep [eq, e]]) + go : forall b. Telescope (LetBinder d) a b -> - (BContext b, SnocList (Eff Pretty (Doc opts))) - go [<] = (xs, [<]) - go (lets :< (qty, x, rhs)) = - let (ys, docs) = go lets - doc = do - lett <- [|letD <+> prettyQty qty|] - x <- prettyTBind x - rhs <- withPrec Outer $ assert_total prettyElim dnames ys rhs - hangDSingle (hsep [lett, x, !cstD]) (hsep [rhs, !inD]) in - (ys :< x, docs :< doc) + Eff Pretty (BContext b, SnocList (Doc opts)) + go [<] = pure (xs, [<]) + go (lets :< (qty, x, rhs)) = do + (ys, docs) <- go lets + doc <- letBody ys !(letHeader qty x) rhs + pure (ys :< x, docs :< doc) private @@ -504,7 +525,10 @@ prettyTerm dnames tnames (Let qty rhs body _) = do let lines = toList $ heads :< body pure $ ifMultiline (hsep lines) (vsep lines) -prettyTerm dnames tnames (E e) = prettyElim dnames tnames e +prettyTerm dnames tnames (E e) = + case the (Elim d n) (pushSubsts' e) of + Ann tm _ _ => assert_total prettyTerm dnames tnames tm + _ => assert_total prettyElim dnames tnames e prettyTerm dnames tnames t0@(CloT (Sub t ph)) = prettyTerm dnames tnames $ assert_smaller t0 $ pushSubstsWith' id ph t @@ -567,9 +591,12 @@ prettyElim dnames tnames e@(DApp {}) = prettyDTApps dnames tnames f xs prettyElim dnames tnames (Ann tm ty _) = - parensIfM Outer =<< - hangDSingle !(withPrec AnnL [|prettyTerm dnames tnames tm <++> annD|]) - !(withPrec Outer (prettyTerm dnames tnames ty)) + case the (Term d n) (pushSubsts' tm) of + E e => assert_total prettyElim dnames tnames e + _ => do + tm <- withPrec AnnL $ assert_total prettyTerm dnames tnames tm + ty <- withPrec Outer $ assert_total prettyTerm dnames tnames ty + parensIfM Outer =<< hangDSingle (tm <++> !annD) ty prettyElim dnames tnames (Coe ty p q val _) = parensIfM App =<< do diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index f660a7c..36eb65c 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -340,8 +340,10 @@ export prettyTContext : {opts : _} -> BContext d -> QContext n -> BContext n -> TContext d n -> Eff Pretty (Doc opts) -prettyTContext dnames qtys tnames tys = - separateTight !commaD <$> prettyTContext' dnames qtys tnames tys +prettyTContext dnames qtys tnames tys = do + comma <- commaD + sepSingle . exceptLast (<+> comma) . toList <$> + prettyTContext' dnames qtys tnames tys export prettyTyContext : {opts : _} -> TyContext d n -> Eff Pretty (Doc opts) @@ -349,8 +351,8 @@ prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) = case dctx of C [<] => prettyTContext dnames qtys tnames tctx _ => pure $ - sep [!(prettyDimEq dnames dctx) <++> !pipeD, - !(prettyTContext dnames qtys tnames tctx)] + sepSingle [!(prettyDimEq dnames dctx) <++> !pipeD, + !(prettyTContext dnames qtys tnames tctx)] export prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts) diff --git a/lib/Quox/Typing/Error.idr b/lib/Quox/Typing/Error.idr index 0b9a4b3..c8133e1 100644 --- a/lib/Quox/Typing/Error.idr +++ b/lib/Quox/Typing/Error.idr @@ -256,7 +256,7 @@ parameters {opts : LayoutOpts} (showContext : Bool) Doc opts -> Eff Pretty (Doc opts) inContext' null ctx f doc = if showContext && not null then - pure $ vappend doc (sep ["in context", !(f ctx)]) + vappend doc <$> hangDSingle "in context" !(f ctx) else pure doc export %inline @@ -416,5 +416,6 @@ parameters {opts : LayoutOpts} (showContext : Bool) export prettyError : Error -> Eff Pretty (Doc opts) - prettyError err = sep <$> sequence - [prettyLoc err.loc, indentD =<< prettyErrorNoLoc err] + prettyError err = hangDSingle + !(prettyLoc err.loc) + !(indentD =<< prettyErrorNoLoc err) diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 5df044d..3b920bd 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -105,25 +105,17 @@ prettyArg : {opts : LayoutOpts} -> BContext n -> Term n -> Eff Pretty (Doc opts) prettyArg xs arg = withPrec Arg $ prettyTerm xs arg export covering -prettyAppHead : {opts : LayoutOpts} -> BContext n -> - Term n -> Eff Pretty (Doc opts) -prettyAppHead xs fun = withPrec App $ prettyTerm xs fun +prettyApp_ : {opts : LayoutOpts} -> BContext n -> + Doc opts -> SnocList (Term n) -> Eff Pretty (Doc opts) +prettyApp_ xs fun args = + parensIfM App =<< + prettyAppD fun (toList !(traverse (prettyArg xs) args)) -export -prettyApp' : {opts : LayoutOpts} -> - Doc opts -> SnocList (Doc opts) -> Eff Pretty (Doc opts) -prettyApp' fun args = do - d <- askAt INDENT - let args = toList args - parensIfM App $ - hsep (fun :: args) - <|> hsep [fun, vsep args] - <|> vsep (fun :: map (indent d) args) - -export covering +export covering %inline prettyApp : {opts : LayoutOpts} -> BContext n -> - Doc opts -> SnocList (Term n) -> Eff Pretty (Doc opts) -prettyApp xs fun args = prettyApp' fun =<< traverse (prettyArg xs) args + Term n -> SnocList (Term n) -> Eff Pretty (Doc opts) +prettyApp xs fun args = + prettyApp_ xs !(prettyArg xs fun) args public export record PrettyCaseArm a n where @@ -208,21 +200,21 @@ prettyTerm xs (Lam x body _) = vars <- hsep . toList' <$> traverse prettyTBind ys body <- withPrec Outer $ prettyTerm (xs . ys) body hangDSingle (hsep [!lamD, vars, !darrowD]) body -prettyTerm xs (App fun arg _) = - let (fun, args) = splitApp fun in - prettyApp xs !(prettyAppHead xs fun) (args :< arg) +prettyTerm xs (App fun arg _) = do + let (fun, args) = splitApp fun + prettyApp xs fun (args :< arg) prettyTerm xs (Pair fst snd _) = parens . separateTight !commaD =<< traverse (withPrec Outer . prettyTerm xs) (fst :: splitPair snd) -prettyTerm xs (Fst pair _) = prettyApp xs !fstD [< pair] -prettyTerm xs (Snd pair _) = prettyApp xs !sndD [< pair] +prettyTerm xs (Fst pair _) = prettyApp_ xs !fstD [< pair] +prettyTerm xs (Snd pair _) = prettyApp_ xs !sndD [< pair] prettyTerm xs (Tag tag _) = prettyTag tag prettyTerm xs (CaseEnum tag cases _) = prettyCase xs prettyTag tag $ map (\(t, rhs) => MkPrettyCaseArm t [] rhs) $ toList cases prettyTerm xs (Absurd _) = hl Syntax "absurd" prettyTerm xs (Nat n _) = hl Constant $ pshow n -prettyTerm xs (Succ nat _) = prettyApp xs !succD [< nat] +prettyTerm xs (Succ nat _) = prettyApp_ xs !succD [< nat] prettyTerm xs (CaseNat nat zer suc _) = prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)] prettyTerm xs (Str s _) = @@ -235,7 +227,7 @@ prettyTerm xs (Let x rhs body _) = let lines = toList $ heads :< body pure $ ifMultiline (hsep lines) (vsep lines) prettyTerm _ (Erased _) = - hl Syntax =<< ifUnicode "⌷" "[]" + hl Syntax =<< ifUnicode "□" "[]" export covering prettyDef : {opts : LayoutOpts} -> Name -> From a14c4ca1cb66b2a30115b81b9d33f8b368018725 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 21 Dec 2023 18:04:12 +0100 Subject: [PATCH 076/133] never inline let bindings from the original source --- lib/Quox/Untyped/Erase.idr | 18 ++++++++++-------- lib/Quox/Untyped/Scheme.idr | 2 +- lib/Quox/Untyped/Syntax.idr | 24 +++++++++++------------- 3 files changed, 22 insertions(+), 22 deletions(-) diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index c51c5f5..34a1206 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -250,7 +250,7 @@ eraseTerm' defs ctx ty (Let pi e s loc) = do Kept => do EraRes ety e' <- eraseElim defs ctx e s' <- eraseTerm defs (extendTyLet pi x ety (E e) ctx) (weakT 1 ty) s.term - pure $ Let x e' s' loc + pure $ Let True x e' s' loc -- e ⤋ e' ⇒ B -- ------------ @@ -321,9 +321,9 @@ eraseElim defs ctx (CasePair qty pair ret body loc) = do body' <- eraseTerm defs ctx' ty body.term p <- mnb "p" loc pure $ EraRes (sub1 ret pair) $ - Let p eterm - (Let x (Fst (B VZ loc) loc) - (Let y (Snd (B (VS VZ) loc) loc) + Let False p eterm + (Let False x (Fst (B VZ loc) loc) + (Let False y (Snd (B (VS VZ) loc) loc) (body' // (B VZ loc ::: B (VS VZ) loc ::: shift 3)) loc) loc) loc Erased => do @@ -425,7 +425,7 @@ eraseElim defs ctx (CaseBox qty box ret body loc) = do Kept => do ebox <- eraseElim defs ctx box ebody <- eraseTerm defs ctx' bty body.term - pure $ EraRes (sub1 ret box) $ Let body.name ebox.term ebody loc + pure $ EraRes (sub1 ret box) $ Let False body.name ebox.term ebody loc Erased => do body' <- eraseTerm defs ctx' bty body.term pure $ EraRes (sub1 ret box) $ body' // one (Erased loc) @@ -487,7 +487,7 @@ uses i (CaseNat nat zer suc _) = uses i nat + max (uses i zer) (uses' suc) uses' (NSRec _ _ s) = uses (VS (VS i)) s uses' (NSNonrec _ s) = uses (VS i) s uses i (Str {}) = 0 -uses i (Let x rhs body _) = uses i rhs + uses (VS i) body +uses i (Let _ x rhs body _) = uses i rhs + uses (VS i) body uses i (Erased {}) = 0 export @@ -539,13 +539,15 @@ trimLets (CaseNat nat zer suc loc) = trimLets' (NSRec x ih s) = NSRec x ih $ trimLets s trimLets' (NSNonrec x s) = NSNonrec x $ trimLets s trimLets (Str s loc) = Str s loc -trimLets (Let x rhs body loc) = +trimLets (Let True x rhs body loc) = + Let True x (trimLets rhs) (trimLets body) loc +trimLets (Let False x rhs body loc) = let rhs' = trimLets rhs body' = trimLets body uses = uses VZ body in if inlineable rhs' || uses == 1 || (droppable rhs' && uses == 0) then sub1 rhs' body' - else Let x rhs' body' loc + else Let False x rhs' body' loc trimLets (Erased loc) = Erased loc diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index 4998f93..aa9a6b3 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -225,7 +225,7 @@ toScheme xs (CaseNat nat zer (NSNonrec p suc) _) = Lambda [p] !(toScheme (xs :< p) suc), !(toScheme xs nat)] -toScheme xs (Let x rhs body _) = +toScheme xs (Let _ x rhs body _) = freshInB x $ \x => pure $ Let x !(toScheme xs rhs) !(toScheme (xs :< x) body) diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 3b920bd..918aa61 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -41,16 +41,14 @@ data Term where Nat : (val : Nat) -> Loc -> Term n Succ : (nat : Term n) -> Loc -> Term n - CaseNat : (nat : Term n) -> - (zer : Term n) -> - (suc : CaseNatSuc n) -> - Loc -> - Term n + CaseNat : (nat : Term n) -> (zer : Term n) -> (suc : CaseNatSuc n) -> + Loc -> Term n Str : (str : String) -> Loc -> Term n - Let : (x : BindName) -> (rhs : Term n) -> (body : Term (S n)) -> Loc -> - Term n + ||| bool is true if the let comes from the original source code + Let : (real : Bool) -> (x : BindName) -> (rhs : Term n) -> + (body : Term (S n)) -> Loc -> Term n Erased : Loc -> Term n %name Term s, t, u @@ -80,7 +78,7 @@ Located (Term n) where (Succ _ loc).loc = loc (CaseNat _ _ _ loc).loc = loc (Str _ loc).loc = loc - (Let _ _ _ loc).loc = loc + (Let _ _ _ _ loc).loc = loc (Erased loc).loc = loc @@ -165,8 +163,8 @@ splitLam ys t = Evidence _ (ys, t) export splitLet : Telescope (\i => (BindName, Term i)) a b -> Term b -> Exists $ \c => (Telescope (\i => (BindName, Term i)) a c, Term c) -splitLet ys (Let x rhs body _) = splitLet (ys :< (x, rhs)) body -splitLet ys t = Evidence _ (ys, t) +splitLet ys (Let _ x rhs body _) = splitLet (ys :< (x, rhs)) body +splitLet ys t = Evidence _ (ys, t) private covering prettyLets : {opts : LayoutOpts} -> @@ -219,7 +217,7 @@ prettyTerm xs (CaseNat nat zer suc _) = prettyCase xs pure nat [MkPrettyCaseArm !zeroD [] zer, !(sucCaseArm suc)] prettyTerm xs (Str s _) = prettyStrLit s -prettyTerm xs (Let x rhs body _) = +prettyTerm xs (Let _ x rhs body _) = parensIfM Outer =<< do let Evidence n' (lets, body) = splitLet [< (x, rhs)] body heads <- prettyLets xs lets @@ -288,8 +286,8 @@ CanSubstSelf Term where (assert_total substSuc suc th) loc Str s loc => Str s loc - Let x rhs body loc => - Let x (rhs // th) (assert_total $ body // push th) loc + Let u x rhs body loc => + Let u x (rhs // th) (assert_total $ body // push th) loc Erased loc => Erased loc where From 81783dbae000f6fa3d74e7f816953e39ac84566b Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 10 Feb 2024 10:07:06 +0100 Subject: [PATCH 077/133] fix typechecker loop when coercing boxes closes #38 --- lib/Quox/Whnf/Coercion.idr | 19 +++++++++++-------- 1 file changed, 11 insertions(+), 8 deletions(-) diff --git a/lib/Quox/Whnf/Coercion.idr b/lib/Quox/Whnf/Coercion.idr index 4b900bf..2e95742 100644 --- a/lib/Quox/Whnf/Coercion.idr +++ b/lib/Quox/Whnf/Coercion.idr @@ -218,19 +218,22 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} STRING tyLoc => whnf defs ctx sg $ Ann s (STRING tyLoc) loc - -- η expand + -- η expand.... kinda -- -- (coe (𝑖 ⇒ [π. A]) @p @q s) -- ⇝ - -- [case1 coe (𝑖 ⇒ [π. A]) @p @q s return A‹q/𝑖› of {[x] ⇒ x}] - -- ∷ [π. A]‹q/𝑖› - BOX qty inner tyLoc => + -- [case1 s ∷ [π.A]‹p/𝑖› return A‹q/𝑖› + -- of {[x] ⇒ coe (𝑖 ⇒ A) @p @q x}] ∷ [π.A]‹q/𝑖› + -- + -- a literal η expansion of `e ⇝ [case e of {[x] ⇒ x}]` causes a loop in + -- the equality checker because whnf of `case e ⋯` requires whnf of `e` + BOX qty inner tyLoc => do let inner = CaseBox { qty = One, - box = Coe (SY [< i] ty) p q s loc, - ret = SN $ ty // one q, - body = SY [< !(mnb "x" loc)] $ BVT 0 loc, + box = Ann s (ty // one p) s.loc, + ret = SN $ inner // one q, + body = SY [< !(mnb "x" loc)] $ E $ + Coe (ST [< i] $ weakT 1 inner) p q (BVT 0 s.loc) s.loc, loc } - in whnf defs ctx sg $ Ann (Box (E inner) loc) (ty // one q) loc From fb14b756c7729faede0e74b235acdcffbc245e0d Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 24 Nov 2023 17:23:06 +0100 Subject: [PATCH 078/133] add algebraic ornaments to bib --- quox.bib | 7 +++++++ 1 file changed, 7 insertions(+) diff --git a/quox.bib b/quox.bib index c2e172d..e8954ed 100644 --- a/quox.bib +++ b/quox.bib @@ -329,6 +329,13 @@ doi = {10.1109/LICS.2000.855774}, } +@misc{ornaments, + author = {Conor {McBride}}, + title = {Ornamental Algebras, Algebraic Ornaments}, + year = {2011}, + url = {https://personal.cis.strath.ac.uk/conor.mcbride/pub/OAAO/LitOrn.pdf}, +} + % Misc implementation From 47069a9316cccb3b44dda5d4e6339c0aa7c20fa8 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 24 Nov 2023 17:23:45 +0100 Subject: [PATCH 079/133] fill a stray hole --- lib/Quox/Whnf/Main.idr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Quox/Whnf/Main.idr b/lib/Quox/Whnf/Main.idr index 2c0a67a..75a1248 100644 --- a/lib/Quox/Whnf/Main.idr +++ b/lib/Quox/Whnf/Main.idr @@ -255,7 +255,7 @@ CanWhnf Term Interface.isRedexT where Left _ => case p of Nat p _ => pure $ nred $ Nat (S p) loc E (Ann (Nat p _) _ _) => pure $ nred $ Nat (S p) loc - Right nc => pure $ Element (Succ p loc) nc + Right nc => pure $ nred $ Succ p loc whnf defs ctx sg (Let _ rhs body _) = whnf defs ctx sg $ sub1 body rhs From 2cafb35bc16eb9787881a904f39127b8752df69f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 27 Nov 2023 06:43:48 +0100 Subject: [PATCH 080/133] fix some comments --- lib/Quox/Whnf/Interface.idr | 14 ++++++++------ 1 file changed, 8 insertions(+), 6 deletions(-) diff --git a/lib/Quox/Whnf/Interface.idr b/lib/Quox/Whnf/Interface.idr index d2b11da..1fccefc 100644 --- a/lib/Quox/Whnf/Interface.idr +++ b/lib/Quox/Whnf/Interface.idr @@ -83,7 +83,7 @@ isTagHead (Ann (Tag {}) (Enum {}) _) = True isTagHead (Coe {}) = True isTagHead _ = False -||| an expression like `0 ∷ ℕ` or `suc n ∷ ℕ` +||| an expression like `𝑘 ∷ ℕ` for a natural constant 𝑘, or `suc n ∷ ℕ` public export %inline isNatHead : Elim {} -> Bool isNatHead (Ann (Nat {}) (NAT {}) _) = True @@ -160,11 +160,13 @@ isK (K {}) = True isK _ = False -||| if `ty` is a type constructor, and `val` is a value of that type where a -||| coercion can be reduced. which is the case if any of: -||| - `ty` is an atomic type -||| - `ty` has η -||| - `val` is a constructor form +||| true if `ty` is a type constructor, and `val` is a value of that type where +||| a coercion can be reduced +||| +||| 1. `ty` is an atomic type +||| 2. `ty` has an η law that is usable in this context +||| (e.g. η for pairs only exists when σ=0, not when σ=1) +||| 3. `val` is a constructor form public export %inline canPushCoe : SQty -> (ty, val : Term {}) -> Bool canPushCoe sg (TYPE {}) _ = True From 103f019dbdf1236148d9e5b99286df0b003769ac Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 27 Nov 2023 07:37:38 +0100 Subject: [PATCH 081/133] move NDefinition to Quox.Definition and add an untyped one --- lib/Quox/Definition.idr | 6 +++++- lib/Quox/Parser/FromParser.idr | 5 ----- lib/Quox/Untyped/Syntax.idr | 4 ++++ 3 files changed, 9 insertions(+), 6 deletions(-) diff --git a/lib/Quox/Definition.idr b/lib/Quox/Definition.idr index 1fc19aa..900536d 100644 --- a/lib/Quox/Definition.idr +++ b/lib/Quox/Definition.idr @@ -89,12 +89,16 @@ isZero g = g.qty == GZero public export -data DefEnvTag = DEFS +NDefinition : Type +NDefinition = (Name, Definition) public export Definitions : Type Definitions = SortedMap Name Definition +public export +data DefEnvTag = DEFS + public export DefsReader : Type -> Type DefsReader = ReaderL DEFS Definitions diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 5907663..42b8d57 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -27,11 +27,6 @@ import Data.IORef %default total -public export -NDefinition : Type -NDefinition = (Name, Definition) - - public export data StateTag = NS | SEEN diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index 918aa61..bed1927 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -93,6 +93,10 @@ public export 0 Definitions : Type Definitions = SortedMap Name Definition +public export +0 NDefinition : Type +NDefinition = (Name, Definition) + export covering prettyTerm : {opts : LayoutOpts} -> BContext n -> From 1f01cec322ec3d6a676ab8de4fe6434d90cd2b34 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 27 Nov 2023 07:39:17 +0100 Subject: [PATCH 082/133] refactor Main a whole lot --- exe/Main.idr | 229 +++++++++++++++++++++++++----------- exe/Options.idr | 75 ++++++++---- lib/Quox/Untyped/Scheme.idr | 2 +- 3 files changed, 214 insertions(+), 92 deletions(-) diff --git a/exe/Main.idr b/exe/Main.idr index 177f438..9385eeb 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -1,22 +1,21 @@ module Main import Quox.Syntax as Q -import Quox.Parser import Quox.Definition as Q -import Quox.Pretty import Quox.Untyped.Syntax as U +import Quox.Parser import Quox.Untyped.Erase import Quox.Untyped.Scheme +import Quox.Pretty import Options -import Data.IORef -import Data.SortedSet -import Text.Show.PrettyVal -import Text.Show.Pretty import System import System.File +import Data.IORef import Control.Eff +%default total + %hide Doc.(>>=) %hide Core.(>>=) @@ -36,13 +35,9 @@ hlFor Term _ = highlightSGR hlFor Html _ = highlightHtml private -runPretty : Options -> Eff Pretty a -> a -runPretty opts act = - runPrettyWith Outer opts.flavor (hlFor opts.hlType opts.outFile) 2 act - -private -putErrLn : HasIO io => String -> io () -putErrLn = ignore . fPutStrLn stderr +runPretty : Options -> OutFile -> Eff Pretty a -> a +runPretty opts file act = + runPrettyWith Outer opts.flavor (hlFor opts.hlType file) 2 act private record State where @@ -92,6 +87,13 @@ prettyError (MultipleMains xs) = prettyError (WriteError file e) = pure $ hangSingle 2 (text "couldn't write file \{file}:") (pshow e) +private +dieError : Options -> Error -> IO a +dieError opts e = + die (Opts opts.width) $ + runPretty ({outFile := Console} opts) Console $ + prettyError e + private data CompileTag = OPTS | STATE @@ -102,7 +104,7 @@ Compile = ReaderL STATE State, ReaderL OPTS Options, LoadFile, IO] -private +private covering runCompile : Options -> State -> Eff Compile a -> IO (Either Error a) runCompile opts state act = fromIOErr $ runEff act $ with Union.(::) @@ -130,38 +132,57 @@ stopHere = failAt STOP private -FlexDoc : Type -FlexDoc = {opts : LayoutOpts} -> Doc opts - +data ConsoleChannel = COut | CErr private -outputStr : Lazy String -> Eff Compile () -outputStr str = - case !(asksAt OPTS outFile) of - NoOut => pure () - Console => putStr str - File f => do - res <- withFile f WriteTruncate pure $ \h => fPutStr h str - rethrow $ mapFst (WriteError f) res +data OpenFile = OConsole ConsoleChannel | OFile String File | ONone private -outputDocs : (opts : Options) -> - ({opts : LayoutOpts} -> List (Doc opts)) -> Eff Compile () -outputDocs opts doc = - outputStr $ concat $ map (render (Opts opts.width)) doc +rethrowFile : String -> Either FileError a -> Eff Compile a +rethrowFile f = rethrow . mapFst (WriteError f) private -outputDocStopIf : Phase -> - ({opts : LayoutOpts} -> Eff Pretty (List (Doc opts))) -> - Eff CompileStop () -outputDocStopIf p docs = do +toOutFile : OpenFile -> OutFile +toOutFile (OConsole _) = Console +toOutFile (OFile f _) = File f +toOutFile ONone = NoOut + +private +withFileC : String -> (OpenFile -> Eff Compile a) -> Eff Compile a +withFileC f act = + withFile f WriteTruncate pure (Prelude.map Right . act . OFile f) >>= + rethrowFile f + +private +withOutFile : ConsoleChannel -> OutFile -> + (OpenFile -> Eff Compile a) -> Eff Compile a +withOutFile _ (File f) act = withFileC f act +withOutFile ch Console act = act $ OConsole ch +withOutFile _ NoOut act = act ONone + +private +outputStr : OpenFile -> Lazy String -> Eff Compile () +outputStr ONone _ = pure () +outputStr (OConsole COut) str = putStr str +outputStr (OConsole CErr) str = fPutStr stderr str >>= rethrowFile "" +outputStr (OFile f h) str = fPutStr h str >>= rethrowFile f + +private +outputDocs : OpenFile -> + ({opts : LayoutOpts} -> Eff Pretty (List (Doc opts))) -> + Eff Compile () +outputDocs file docs = do opts <- askAt OPTS - when (opts.until == Just p) $ Prelude.do - lift $ outputDocs !(askAt OPTS) (runPretty opts docs) - stopHere + for_ (runPretty opts (toOutFile file) docs) $ \x => + outputStr file $ render (Opts opts.width) x private -liftFromParser : Eff FromParserIO a -> Eff CompileStop a +outputDoc : OpenFile -> + ({opts : LayoutOpts} -> Eff Pretty (Doc opts)) -> Eff Compile () +outputDoc file doc = outputDocs file $ singleton <$> doc + +private +liftFromParser : Eff FromParserIO a -> Eff Compile a liftFromParser act = runEff act $ with Union.(::) [handleExcept $ \err => throw $ FromParserError err, @@ -171,14 +192,14 @@ liftFromParser act = \g => send g] private -liftErase : Q.Definitions -> Eff Erase a -> Eff CompileStop a +liftErase : Q.Definitions -> Eff Erase a -> Eff Compile a liftErase defs act = runEff act [handleExcept $ \err => throw $ EraseError err, handleStateIORef !(asksAt STATE suf)] private -liftScheme : Eff Scheme a -> Eff CompileStop (a, List Id) +liftScheme : Eff Scheme a -> Eff Compile (a, List Id) liftScheme act = do runEff [|MkPair act (getAt MAIN)|] [handleStateIORef !(newIORef empty), @@ -186,49 +207,110 @@ liftScheme act = do private -oneMain : Has (Except Error) fs => List Id -> Eff fs Id -oneMain [] = throw NoMain -oneMain [x] = pure x -oneMain mains = throw $ MultipleMains mains +Step : Type -> Type -> Type +Step i o = OpenFile -> i -> Eff Compile o +-- private +-- processFile : String -> Eff Compile () +-- processFile file = withEarlyStop $ do +-- Just ast <- loadFile noLoc file +-- | Nothing => pure () +-- -- putErrLn "checking \{file}" +-- when (!(asksAt OPTS until) == Just Parse) $ do +-- lift $ outputStr $ show ast +-- stopHere +-- defList <- liftFromParser $ concat <$> traverse fromPTopLevel ast +-- outputDocStopIf Check $ +-- traverse (uncurry Q.prettyDef) defList +-- let defs = SortedMap.fromList defList +-- erased <- liftErase defs $ +-- traverse (\(x, d) => (x,) <$> eraseDef defs x d) defList +-- outputDocStopIf Erase $ +-- traverse (uncurry U.prettyDef) erased +-- (scheme, mains) <- liftScheme $ map catMaybes $ +-- traverse (uncurry defToScheme) erased +-- outputDocStopIf Scheme $ +-- intersperse empty <$> traverse prettySexp scheme private -processFile : String -> Eff Compile () -processFile file = withEarlyStop $ do - Just ast <- loadFile noLoc file - | Nothing => pure () - -- putErrLn "checking \{file}" - when (!(asksAt OPTS until) == Just Parse) $ do - lift $ outputStr $ show ast - stopHere - defList <- liftFromParser $ concat <$> traverse fromPTopLevel ast - outputDocStopIf Check $ - traverse (uncurry Q.prettyDef) defList - let defs = SortedMap.fromList defList - erased <- liftErase defs $ - traverse (\(x, d) => (x,) <$> eraseDef defs x d) defList - outputDocStopIf Erase $ - traverse (uncurry U.prettyDef) erased - (scheme, mains) <- liftScheme $ map catMaybes $ - traverse (uncurry defToScheme) erased - outputDocStopIf Scheme $ - intersperse empty <$> traverse prettySexp scheme +step : {default CErr console : ConsoleChannel} -> + Phase -> OutFile -> Step i o -> i -> Eff CompileStop o +step phase file act x = do opts <- askAt OPTS - main <- oneMain mains - lift $ outputDocs opts $ intersperse empty $ runPretty opts $ do - res <- traverse prettySexp scheme + res <- lift $ withOutFile console file $ \h => act h x + when (opts.until == Just phase) stopHere + pure res + + +private covering +parse : Step String PFile +parse h file = do + Just ast <- loadFile noLoc file + | Nothing => pure [] + outputStr h $ show ast + pure ast + +private covering +check : Step PFile (List Q.NDefinition) +check h decls = + map concat $ for decls $ \decl => do + defs <- liftFromParser $ fromPTopLevel decl + outputDocs h $ traverse (\(x, d) => prettyDef x d) defs + pure defs + +private covering +erase : Step (List Q.NDefinition) (List U.NDefinition) +erase h defList = + for defList $ \(x, def) => do + def <- liftErase defs $ eraseDef defs x def + outputDoc h $ U.prettyDef x def + pure (x, def) +where defs = SortedMap.fromList defList + +private covering +scheme : Step (List U.NDefinition) (List Sexp, Id) +scheme h defs = do + sexps' <- for defs $ \(x, d) => do + (msexp, mains) <- liftScheme $ defToScheme x d + outputDoc h $ maybe (sayErased x) prettySexp msexp + pure (msexp, mains) + bitraverse (pure . catMaybes) (oneMain . concat) $ unzip sexps' +where + sayErased : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts) + sayErased x = pure $ hsep [";;", prettyName x, "erased"] + + oneMain : List Id -> Eff Compile Id + oneMain [m] = pure m + oneMain [] = throw NoMain + oneMain ms = throw $ MultipleMains ms + +private covering +output : Step (List Sexp, Id) () +output h (sexps, main) = + lift $ outputDocs h $ do + res <- traverse prettySexp sexps runner <- makeRunMain main pure $ text Scheme.prelude :: res ++ [runner] -export +private covering +processFile : String -> Eff Compile () +processFile file = withEarlyStop $ pipeline !(askAt OPTS) file where + pipeline : Options -> String -> Eff CompileStop () + pipeline opts = + step Parse opts.dump.parse Main.parse >=> + step Check opts.dump.check Main.check >=> + step Erase opts.dump.erase Main.erase >=> + step Scheme opts.dump.scheme Main.scheme >=> + step End opts.outFile Main.output {console = COut} + + +export covering main : IO () main = do (_, opts, files) <- options case !(runCompile opts !newState $ traverse_ processFile files) of Right () => pure () - Left e => die (Opts opts.width) $ - runPretty ({outFile := Console} opts) $ - prettyError e + Left e => dieError opts e ----------------------------------- @@ -244,6 +326,13 @@ text _ = #" /_/"#, ""] +-- ["", +-- #" __ _ _ _ _____ __"#, +-- #"/ _` | || / _ \ \ /"#, +-- #"\__, |\_,_\___/_\_\"#, +-- #" |_|"#, +-- ""] + private qtuwu : PrettyOpts -> List String qtuwu opts = diff --git a/exe/Options.idr b/exe/Options.idr index a4f329f..256bca5 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -16,27 +16,35 @@ data OutFile = File String | Console | NoOut %runElab derive "OutFile" [Eq, Ord, Show] public export -data Phase = Parse | Check | Erase | Scheme +data Phase = Parse | Check | Erase | Scheme | End %name Phase p %runElab derive "Phase" [Eq, Ord, Show] -||| a list of all `Phase`s +||| a list of all intermediate `Phase`s (excluding `End`) public export %inline allPhases : List Phase allPhases = %runElab do -- as a script so it stays up to date cs <- getCons $ fst !(lookupName "Phase") - traverse (check . var) cs + traverse (check . var) $ fromMaybe [] $ init' cs -||| "guess" is Term for a terminal and NoHL for a file +||| `Guess` is `Term` for a terminal and `NoHL` for a file public export data HLType = Guess | NoHL | Term | Html %runElab derive "HLType" [Eq, Ord, Show] +public export +record Dump where + constructor MkDump + parse, check, erase, scheme : OutFile +%name Dump dump +%runElab derive "Dump" [Show] + public export record Options where constructor MkOpts hlType : HLType + dump : Dump outFile : OutFile until : Maybe Phase flavor : Pretty.Flavor @@ -55,6 +63,7 @@ export defaultOpts : IO Options defaultOpts = pure $ MkOpts { hlType = Guess, + dump = MkDump NoOut NoOut NoOut NoOut, outFile = Console, until = Nothing, flavor = Unicode, @@ -70,19 +79,31 @@ data OptAction = ShowHelp HelpType | Err String | Ok (Options -> Options) %name OptAction act private -toOutFile : String -> OptAction -toOutFile "" = Ok {outFile := NoOut} -toOutFile "-" = Ok {outFile := Console} -toOutFile f = Ok {outFile := File f} +toOutFile : String -> OutFile +toOutFile "" = NoOut +toOutFile "-" = Console +toOutFile f = File f private toPhase : String -> OptAction toPhase str = let lstr = toLower str in case find (\p => toLower (show p) == lstr) allPhases of - Just p => Ok {until := Just p} + Just p => Ok $ setPhase p Nothing => Err "unknown phase name \{show str}\nphases: \{phaseNames}" -where phaseNames = joinBy ", " $ map (toLower . show) allPhases +where + phaseNames = joinBy ", " $ map (toLower . show) allPhases + + defConsole : OutFile -> OutFile + defConsole NoOut = Console + defConsole f = f + + setPhase : Phase -> Options -> Options + setPhase Parse = {until := Just Parse, dump.parse $= defConsole} + setPhase Check = {until := Just Check, dump.check $= defConsole} + setPhase Erase = {until := Just Erase, dump.erase $= defConsole} + setPhase Scheme = {until := Just Scheme, dump.scheme $= defConsole} + setPhase End = id private toWidth : String -> OptAction @@ -96,17 +117,24 @@ toHLType str = case toLower str of "none" => Ok {hlType := NoHL} "term" => Ok {hlType := Term} "html" => Ok {hlType := Html} - _ => Err "unknown highlighting type \{str}\ntypes: term, html, none" + _ => Err "unknown highlighting type \{show str}\ntypes: term, html, none" + +||| like ghc, -i '' clears the search path; -i a:b:c adds a,b,c to the end +private +dirListFlag : String -> List String -> List String +dirListFlag arg val = + if null arg then [] else val ++ toList (split (== ':') arg) private commonOptDescrs' : List (OptDescr OptAction) commonOptDescrs' = [ - MkOpt ['i'] ["include"] (ReqArg (\i => Ok {include $= (i ::)}) "") - "add a directory to look for source files", - MkOpt ['o'] ["output"] (ReqArg toOutFile "") + MkOpt ['i'] ["include"] + (ReqArg (\is => Ok {include $= dirListFlag is}) ":...") + "add directories to look for source files", + MkOpt ['o'] ["output"] (ReqArg (\s => Ok {outFile := toOutFile s}) "") "output file (\"-\" for stdout, \"\" for no output)", MkOpt ['P'] ["phase"] (ReqArg toPhase "") - "phase to stop at (by default go as far as exists)" + "stop after the given phase" ] private @@ -119,7 +147,16 @@ extraOptDescrs = [ MkOpt [] ["width"] (ReqArg toWidth "") "max output width (defaults to terminal width)", MkOpt [] ["color", "colour"] (ReqArg toHLType "") - "select highlighting type" + "select highlighting type", + + MkOpt [] ["dparse"] (ReqArg (\s => Ok {dump.parse := toOutFile s}) "") + "dump AST", + MkOpt [] ["dcheck"] (ReqArg (\s => Ok {dump.check := toOutFile s}) "") + "dump typechecker output", + MkOpt [] ["derase"] (ReqArg (\s => Ok {dump.erase := toOutFile s}) "") + "dump erasure output", + MkOpt [] ["dscheme"] (ReqArg (\s => Ok {dump.scheme := toOutFile s}) "") + "dump scheme output (without prelude)" ] private @@ -152,10 +189,6 @@ applyAction opts (ShowHelp All) = usage allOptDescrs applyAction opts (Err err) = die err applyAction opts (Ok f) = pure $ f opts -private -finalise : Options -> Options -finalise = {include $= reverse} - export options : IO (String, Options, List String) options = do @@ -167,4 +200,4 @@ options = do unless (null res.unrecognized) $ die "unrecognised options: \{joinBy ", " res.unrecognized}" opts <- foldlM applyAction !defaultOpts res.options - pure (app, finalise opts, res.nonOptions) + pure (app, opts, res.nonOptions) diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index aa9a6b3..c5a528d 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -70,7 +70,7 @@ public export data Id = I String Nat %runElab derive "Id" [Eq, Ord] -private +export prettyId' : {opts : LayoutOpts} -> Id -> Doc opts prettyId' (I str 0) = text $ escId str prettyId' (I str k) = text $ escId "\{str}:\{show k}" From f3376258013e5f4eaa05208be41f643823e260eb Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 27 Nov 2023 21:01:36 +0100 Subject: [PATCH 083/133] remove most noLocs --- lib/Quox/FreeVars.idr | 16 +-- lib/Quox/Loc.idr | 18 +++ lib/Quox/Parser/FromParser.idr | 2 +- lib/Quox/Scoped.idr | 19 +++ lib/Quox/Syntax/DimEq.idr | 10 +- lib/Quox/Syntax/Subst.idr | 12 +- lib/Quox/Syntax/Term/Base.idr | 205 +++++++++++++++----------------- lib/Quox/Syntax/Term/Pretty.idr | 2 +- lib/Quox/Syntax/Term/Subst.idr | 10 +- lib/Quox/Typechecker.idr | 2 +- lib/Quox/Typing.idr | 2 +- lib/Quox/Typing/Context.idr | 2 +- lib/Quox/Untyped/Syntax.idr | 11 +- lib/Quox/Var.idr | 3 - lib/Quox/Whnf/Coercion.idr | 11 +- lib/Quox/Whnf/TypeCase.idr | 14 +-- 16 files changed, 178 insertions(+), 161 deletions(-) diff --git a/lib/Quox/FreeVars.idr b/lib/Quox/FreeVars.idr index 29c08ca..de52813 100644 --- a/lib/Quox/FreeVars.idr +++ b/lib/Quox/FreeVars.idr @@ -229,27 +229,27 @@ HasFreeVars (Elim d) where private -expandDShift : {d1 : Nat} -> Shift d1 d2 -> Context' (Dim d2) d1 -expandDShift by = tabulateLT d1 (\i => BV i noLoc // by) +expandDShift : {d1 : Nat} -> Shift d1 d2 -> Loc -> Context' (Dim d2) d1 +expandDShift by loc = tabulateLT d1 (\i => BV i loc // by) private -expandDSubst : {d1 : Nat} -> DSubst d1 d2 -> Context' (Dim d2) d1 -expandDSubst (Shift by) = expandDShift by -expandDSubst (t ::: th) = expandDSubst th :< t +expandDSubst : {d1 : Nat} -> DSubst d1 d2 -> Loc -> Context' (Dim d2) d1 +expandDSubst (Shift by) loc = expandDShift by loc +expandDSubst (t ::: th) loc = expandDSubst th loc :< t private -fdvSubst' : {d1, d2, n : Nat} -> HasFreeDVars tm => +fdvSubst' : {d1, d2, n : Nat} -> (Located2 tm, HasFreeDVars tm) => tm d1 n -> DSubst d1 d2 -> FreeVars d2 fdvSubst' t th = - fold $ zipWith maybeOnly (fdv t).vars (expandDSubst th) + fold $ zipWith maybeOnly (fdv t).vars (expandDSubst th t.loc) where maybeOnly : {d : Nat} -> Bool -> Dim d -> FreeVars d maybeOnly True (B i _) = only i maybeOnly _ _ = none private -fdvSubst : {d, n : Nat} -> HasFreeDVars tm => +fdvSubst : {d, n : Nat} -> (Located2 tm, HasFreeDVars tm) => WithSubst (\d => tm d n) Dim d -> FreeVars d fdvSubst (Sub t th) = let Val from = getFrom th in fdvSubst' t th diff --git a/lib/Quox/Loc.idr b/lib/Quox/Loc.idr index 5776ec9..7aeb229 100644 --- a/lib/Quox/Loc.idr +++ b/lib/Quox/Loc.idr @@ -118,6 +118,11 @@ export %inline or : Loc -> Loc -> Loc or (L l1) (L l2) = L $ l1 `or_` l2 +export %inline +extendOr : Loc -> Loc -> Loc +extendOr l1 l2 = (l1 `extendL` l2) `or` l2 + + public export interface Located a where (.loc) : a -> Loc @@ -126,9 +131,22 @@ public export 0 Located1 : (a -> Type) -> Type Located1 f = forall x. Located (f x) +public export +0 Located2 : (a -> b -> Type) -> Type +Located2 f = forall x, y. Located (f x y) + public export interface Located a => Relocatable a where setLoc : Loc -> a -> a public export 0 Relocatable1 : (a -> Type) -> Type Relocatable1 f = forall x. Relocatable (f x) + +public export +0 Relocatable2 : (a -> b -> Type) -> Type +Relocatable2 f = forall x, y. Relocatable (f x y) + + +export +locs : Located a => Foldable t => t a -> Loc +locs = foldl (\loc, y => loc `extendOr` y.loc) noLoc diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 42b8d57..ce22ae2 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -302,7 +302,7 @@ mutual Eff FromParserPure (DScopeTermN s d n) fromPTermDScope ds ns xs t = if all isUnused xs then - SN <$> fromPTermWith ds ns t + SN {f = \d => Term d n} <$> fromPTermWith ds ns t else DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t diff --git a/lib/Quox/Scoped.idr b/lib/Quox/Scoped.idr index be43cfe..ea575cf 100644 --- a/lib/Quox/Scoped.idr +++ b/lib/Quox/Scoped.idr @@ -38,3 +38,22 @@ export %inline export %inline %hint ShowScoped : (forall n. Show (f n)) => Show (Scoped s f n) ShowScoped = deriveShow + + +||| scope which ignores all its binders +public export %inline +SN : Located1 f => {s : Nat} -> f n -> Scoped s f n +SN body = S (replicate s $ BN Unused body.loc) $ N body + +||| scope which uses its binders +public export %inline +SY : BContext s -> f (s + n) -> Scoped s f n +SY ns = S ns . Y + +public export %inline +name : Scoped 1 f n -> BindName +name (S [< x] _) = x + +public export %inline +(.name) : Scoped 1 f n -> BindName +s.name = name s diff --git a/lib/Quox/Syntax/DimEq.idr b/lib/Quox/Syntax/DimEq.idr index 574414f..020b947 100644 --- a/lib/Quox/Syntax/DimEq.idr +++ b/lib/Quox/Syntax/DimEq.idr @@ -71,13 +71,13 @@ toMaybe (Just x) = Just x export -fromGround' : Context' DimConst d -> DimEq' d -fromGround' [<] = [<] -fromGround' (ctx :< e) = fromGround' ctx :< Just (K e noLoc) +fromGround' : BContext d -> Context' DimConst d -> DimEq' d +fromGround' [<] [<] = [<] +fromGround' (xs :< x) (ctx :< e) = fromGround' xs ctx :< Just (K e x.loc) export -fromGround : Context' DimConst d -> DimEq d -fromGround = C . fromGround' +fromGround : BContext d -> Context' DimConst d -> DimEq d +fromGround = C .: fromGround' public export %inline diff --git a/lib/Quox/Syntax/Subst.idr b/lib/Quox/Syntax/Subst.idr index d5c2ed8..aebe6a4 100644 --- a/lib/Quox/Syntax/Subst.idr +++ b/lib/Quox/Syntax/Subst.idr @@ -96,18 +96,18 @@ map f (t ::: th) = f t ::: map f th public export %inline -push : CanSubstSelf f => Subst f from to -> Subst f (S from) (S to) -push th = fromVar VZ ::: (th . shift 1) +push : CanSubstSelf f => Loc -> Subst f from to -> Subst f (S from) (S to) +push loc th = fromVarLoc VZ loc ::: (th . shift 1) -- [fixme] a better way to do this? public export -pushN : CanSubstSelf f => (s : Nat) -> +pushN : CanSubstSelf f => (s : Nat) -> Loc -> Subst f from to -> Subst f (s + from) (s + to) -pushN 0 th = th -pushN (S s) th = +pushN 0 _ th = th +pushN (S s) loc th = rewrite plusSuccRightSucc s from in rewrite plusSuccRightSucc s to in - pushN s $ fromVar VZ ::: (th . shift 1) + pushN s loc $ fromVarLoc VZ loc ::: (th . shift 1) public export drop1 : Subst f (S from) to -> Subst f from to diff --git a/lib/Quox/Syntax/Term/Base.idr b/lib/Quox/Syntax/Term/Base.idr index 36715d4..88e7b07 100644 --- a/lib/Quox/Syntax/Term/Base.idr +++ b/lib/Quox/Syntax/Term/Base.idr @@ -236,117 +236,6 @@ mutual ShowElim : Show (Elim d n) ShowElim = assert_total {a = Show (Elim d n)} deriveShow -||| scope which ignores all its binders -public export %inline -SN : {s : Nat} -> f n -> Scoped s f n -SN = S (replicate s $ BN Unused noLoc) . N - -||| scope which uses its binders -public export %inline -SY : BContext s -> f (s + n) -> Scoped s f n -SY ns = S ns . Y - -public export %inline -name : Scoped 1 f n -> BindName -name (S [< x] _) = x - -public export %inline -(.name) : Scoped 1 f n -> BindName -s.name = name s - -||| more convenient Pi -public export %inline -PiY : (qty : Qty) -> (x : BindName) -> - (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n -PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc} - -||| more convenient Lam -public export %inline -LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n -LamY {x, body, loc} = Lam {body = SY [< x] body, loc} - -public export %inline -LamN : (body : Term d n) -> (loc : Loc) -> Term d n -LamN {body, loc} = Lam {body = SN body, loc} - -||| non dependent function type -public export %inline -Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n -Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc} - -||| more convenient Sig -public export %inline -SigY : (x : BindName) -> (fst : Term d n) -> - (snd : Term d (S n)) -> (loc : Loc) -> Term d n -SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc} - -||| non dependent pair type -public export %inline -And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n -And {fst, snd, loc} = Sig {fst, snd = SN snd, loc} - -||| more convenient Eq -public export %inline -EqY : (i : BindName) -> (ty : Term (S d) n) -> - (l, r : Term d n) -> (loc : Loc) -> Term d n -EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc} - -||| more convenient DLam -public export %inline -DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n -DLamY {i, body, loc} = DLam {body = SY [< i] body, loc} - -public export %inline -DLamN : (body : Term d n) -> (loc : Loc) -> Term d n -DLamN {body, loc} = DLam {body = SN body, loc} - -||| non dependent equality type -public export %inline -Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n -Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc} - -||| same as `F` but as a term -public export %inline -FT : Name -> Universe -> Loc -> Term d n -FT x u loc = E $ F x u loc - -||| same as `B` but as a term -public export %inline -BT : Var n -> (loc : Loc) -> Term d n -BT i loc = E $ B i loc - -||| abbreviation for a bound variable like `BV 4` instead of -||| `B (VS (VS (VS (VS VZ))))` -public export %inline -BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim d n -BV i loc = B (V i) loc - -||| same as `BV` but as a term -public export %inline -BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n -BVT i loc = E $ BV i loc - -public export %inline -Zero : Loc -> Term d n -Zero = Nat 0 - -public export %inline -enum : List TagVal -> Loc -> Term d n -enum ts loc = Enum (SortedSet.fromList ts) loc - -public export %inline -typeCase : Elim d n -> Term d n -> - List (TypeCaseArm d n) -> Term d n -> Loc -> Elim d n -typeCase ty ret arms def loc = TypeCase ty ret (fromList arms) def loc - -public export %inline -typeCase1Y : Elim d n -> Term d n -> - (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) -> - (loc : Loc) -> - {default (NAT loc) def : Term d n} -> - Elim d n -typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc - export Located (Elim d n) where @@ -463,3 +352,97 @@ Relocatable1 f => Relocatable (ScopedBody s f n) where export Relocatable1 f => Relocatable (Scoped s f n) where setLoc loc (S names body) = S (setLoc loc <$> names) (setLoc loc body) + + +||| more convenient Pi +public export %inline +PiY : (qty : Qty) -> (x : BindName) -> + (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n +PiY {qty, x, arg, res, loc} = Pi {qty, arg, res = SY [< x] res, loc} + +||| more convenient Lam +public export %inline +LamY : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n +LamY {x, body, loc} = Lam {body = SY [< x] body, loc} + +public export %inline +LamN : (body : Term d n) -> (loc : Loc) -> Term d n +LamN {body, loc} = Lam {body = SN body, loc} + +||| non dependent function type +public export %inline +Arr : (qty : Qty) -> (arg, res : Term d n) -> (loc : Loc) -> Term d n +Arr {qty, arg, res, loc} = Pi {qty, arg, res = SN res, loc} + +||| more convenient Sig +public export %inline +SigY : (x : BindName) -> (fst : Term d n) -> + (snd : Term d (S n)) -> (loc : Loc) -> Term d n +SigY {x, fst, snd, loc} = Sig {fst, snd = SY [< x] snd, loc} + +||| non dependent pair type +public export %inline +And : (fst, snd : Term d n) -> (loc : Loc) -> Term d n +And {fst, snd, loc} = Sig {fst, snd = SN snd, loc} + +||| more convenient Eq +public export %inline +EqY : (i : BindName) -> (ty : Term (S d) n) -> + (l, r : Term d n) -> (loc : Loc) -> Term d n +EqY {i, ty, l, r, loc} = Eq {ty = SY [< i] ty, l, r, loc} + +||| more convenient DLam +public export %inline +DLamY : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n +DLamY {i, body, loc} = DLam {body = SY [< i] body, loc} + +public export %inline +DLamN : (body : Term d n) -> (loc : Loc) -> Term d n +DLamN {body, loc} = DLam {body = SN body, loc} + +||| non dependent equality type +public export %inline +Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n +Eq0 {ty, l, r, loc} = Eq {ty = SN ty, l, r, loc} + +||| same as `F` but as a term +public export %inline +FT : Name -> Universe -> Loc -> Term d n +FT x u loc = E $ F x u loc + +||| same as `B` but as a term +public export %inline +BT : Var n -> (loc : Loc) -> Term d n +BT i loc = E $ B i loc + +||| abbreviation for a bound variable like `BV 4` instead of +||| `B (VS (VS (VS (VS VZ))))` +public export %inline +BV : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Elim d n +BV i loc = B (V i) loc + +||| same as `BV` but as a term +public export %inline +BVT : (i : Nat) -> (0 _ : LT i n) => (loc : Loc) -> Term d n +BVT i loc = E $ BV i loc + +public export %inline +Zero : Loc -> Term d n +Zero = Nat 0 + +public export %inline +enum : List TagVal -> Loc -> Term d n +enum ts loc = Enum (SortedSet.fromList ts) loc + +public export %inline +typeCase : Elim d n -> Term d n -> + List (TypeCaseArm d n) -> Term d n -> Loc -> Elim d n +typeCase ty ret arms def loc = TypeCase ty ret (fromList arms) def loc + +public export %inline +typeCase1Y : Elim d n -> Term d n -> + (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) -> + (loc : Loc) -> + {default (NAT loc) def : Term d n} -> + Elim d n +typeCase1Y ty ret k ns body loc = typeCase ty ret [(k ** SY ns body)] def loc diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index 5a925cf..a5d06b1 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -608,7 +608,7 @@ prettyElim dnames tnames (Coe ty p q val _) = prettyElim dnames tnames e@(Comp ty p q val r zero one _) = parensIfM App =<< do - ty <- prettyTypeLine dnames tnames $ assert_smaller e $ SN ty + ty <- assert_total $ prettyTypeLine dnames tnames $ SN ty pq <- sep <$> sequence [prettyDArg dnames p, prettyDArg dnames q] val <- prettyTArg dnames tnames val r <- prettyDArg dnames r diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index 330a10e..316b2bb 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -56,12 +56,12 @@ namespace DSubst.DScopeTermN (//) : {s : Nat} -> DScopeTermN s d1 n -> Lazy (DSubst d1 d2) -> DScopeTermN s d2 n - S ns (Y body) // th = S ns $ Y $ body // pushN s th + S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th S ns (N body) // th = S ns $ N $ body // th export %inline FromVar (Elim d) where fromVarLoc = B -export %inline FromVar (Term d) where fromVarLoc = E .: fromVar +export %inline FromVar (Term d) where fromVarLoc = E .: fromVarLoc ||| does the minimal reasonable work: @@ -104,7 +104,7 @@ namespace ScopeTermN (//) : {s : Nat} -> ScopeTermN s d n1 -> Lazy (TSubst d n1 n2) -> ScopeTermN s d n2 - S ns (Y body) // th = S ns $ Y $ body // pushN s th + S ns (Y body) // th = S ns $ Y $ body // pushN s (locs $ toList' ns) th S ns (N body) // th = S ns $ N $ body // th namespace DScopeTermN @@ -189,11 +189,11 @@ dsub1 t p = dsubN t [< p] public export %inline -(.zero) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n +(.zero) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n body.zero = dsub1 body $ K Zero loc public export %inline -(.one) : DScopeTerm d n -> {default noLoc loc : Loc} -> Term d n +(.one) : (body : DScopeTerm d n) -> {default body.loc loc : Loc} -> Term d n body.one = dsub1 body $ K One loc diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index 2a2ef36..a25e3cd 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -304,7 +304,7 @@ mutual infres <- inferC ctx SZero e -- if Ψ | Γ ⊢ Type ℓ <: Type 𝓀 case u of - Just u => lift $ subtype e.loc ctx infres.type (TYPE u noLoc) + Just u => lift $ subtype e.loc ctx infres.type (TYPE u e.loc) Nothing => ignore $ expectTYPE !(askAt DEFS) ctx SZero e.loc infres.type -- then Ψ | Γ ⊢₀ E ⇐ Type 𝓀 diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index 5d62e8a..46238b4 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -54,7 +54,7 @@ substCasePairRet [< x, y] dty retty = public export substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n) substCaseSuccRet [< p, ih] retty = - let arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT noLoc) $ p.loc `extendL` ih.loc + let arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT p.loc) $ p.loc `extendL` ih.loc in retty.term // (arg ::: shift 2) diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index 36eb65c..671a06c 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -272,7 +272,7 @@ namespace EqContext toTyContext : (e : EqContext n) -> TyContext e.dimLen n toTyContext (MkEqContext {dimLen, dassign, dnames, tctx, tnames, qtys}) = MkTyContext { - dctx = fromGround dassign, + dctx = fromGround dnames dassign, tctx = map (subD $ shift0 dimLen) tctx, dnames, tnames, qtys } diff --git a/lib/Quox/Untyped/Syntax.idr b/lib/Quox/Untyped/Syntax.idr index bed1927..06f02f0 100644 --- a/lib/Quox/Untyped/Syntax.idr +++ b/lib/Quox/Untyped/Syntax.idr @@ -266,7 +266,7 @@ CanSubstSelf Term where B i loc => getLoc th i loc Lam x body loc => - Lam x (assert_total $ body // push th) loc + Lam x (assert_total $ body // push x.loc th) loc App fun arg loc => App (fun // th) (arg // th) loc Pair fst snd loc => @@ -286,19 +286,18 @@ CanSubstSelf Term where Succ nat loc => Succ (nat // th) loc CaseNat nat zer suc loc => - CaseNat (nat // th) (zer // th) - (assert_total substSuc suc th) loc + CaseNat (nat // th) (zer // th) (assert_total substSuc suc th) loc Str s loc => Str s loc Let u x rhs body loc => - Let u x (rhs // th) (assert_total $ body // push th) loc + Let u x (rhs // th) (assert_total $ body // push x.loc th) loc Erased loc => Erased loc where substSuc : forall from, to. CaseNatSuc from -> USubst from to -> CaseNatSuc to - substSuc (NSRec x ih t) th = NSRec x ih $ t // pushN 2 th - substSuc (NSNonrec x t) th = NSNonrec x $ t // push th + substSuc (NSRec x ih t) th = NSRec x ih $ t // pushN 2 x.loc th + substSuc (NSNonrec x t) th = NSNonrec x $ t // push x.loc th public export subN : SnocVect s (Term n) -> Term (s + n) -> Term n diff --git a/lib/Quox/Var.idr b/lib/Quox/Var.idr index ed52579..732b012 100644 --- a/lib/Quox/Var.idr +++ b/lib/Quox/Var.idr @@ -141,9 +141,6 @@ weakIsSpec p i = toNatInj $ trans (weakCorrect p i) (sym $ weakSpecCorrect p i) public export interface FromVar f where %inline fromVarLoc : Var n -> Loc -> f n -public export %inline -fromVar : FromVar f => Var n -> {default noLoc loc : Loc} -> f n -fromVar x = fromVarLoc x loc public export FromVar Var where fromVarLoc x _ = x diff --git a/lib/Quox/Whnf/Coercion.idr b/lib/Quox/Whnf/Coercion.idr index 2e95742..f8c0e12 100644 --- a/lib/Quox/Whnf/Coercion.idr +++ b/lib/Quox/Whnf/Coercion.idr @@ -63,11 +63,11 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty (tfst, tsnd) <- tycaseSig defs ctx1 ty let [< x, y] = body.names - a' = CoeT i (weakT 2 tfst) p q (BVT 1 noLoc) x.loc + a' = CoeT i (weakT 2 tfst) p q (BVT 1 x.loc) x.loc tsnd' = tsnd.term // - (CoeT i (weakT 2 $ tfst // (B VZ noLoc ::: shift 2)) - (weakD 1 p) (B VZ noLoc) (BVT 1 noLoc) y.loc ::: shift 2) - b' = CoeT i tsnd' p q (BVT 0 noLoc) y.loc + (CoeT i (weakT 2 $ tfst // (B VZ tsnd.loc ::: shift 2)) + (weakD 1 p) (B VZ i.loc) (BVT 1 tsnd.loc) y.loc ::: shift 2) + b' = CoeT i tsnd' p q (BVT 0 y.loc) y.loc whnf defs ctx sg $ CasePair qty (Ann val (ty // one p) val.loc) ret (ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc @@ -141,7 +141,8 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} let ctx1 = extendDim i ctx Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty ta <- tycaseBOX defs ctx1 ty - let a' = CoeT i (weakT 1 ta) p q (BVT 0 noLoc) body.name.loc + let xloc = body.name.loc + let a' = CoeT i (weakT 1 ta) p q (BVT 0 xloc) xloc whnf defs ctx sg $ CaseBox qty (Ann val (ty // one p) val.loc) ret (ST body.names $ body.term // (a' ::: shift 1)) loc diff --git a/lib/Quox/Whnf/TypeCase.idr b/lib/Quox/Whnf/TypeCase.idr index 2fc34ba..9b3645f 100644 --- a/lib/Quox/Whnf/TypeCase.idr +++ b/lib/Quox/Whnf/TypeCase.idr @@ -120,9 +120,9 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} -- (type-case π.(x : A) → B ∷ ★ᵢ return Q of { (a → b) ⇒ s; ⋯ }) ⇝ -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q Pi {arg, res, loc = piLoc, _} => - let arg' = Ann arg (TYPE u noLoc) arg.loc + let arg' = Ann arg (TYPE u arg.loc) arg.loc res' = Ann (Lam res res.loc) - (Arr Zero arg (TYPE u noLoc) arg.loc) res.loc + (Arr Zero arg (TYPE u arg.loc) arg.loc) res.loc in whnf defs ctx SZero $ Ann (subN (tycaseRhsDef def KPi arms) [< arg', res']) ret loc @@ -130,9 +130,9 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} -- (type-case (x : A) × B ∷ ★ᵢ return Q of { (a × b) ⇒ s; ⋯ }) ⇝ -- s[(A ∷ ★ᵢ)/a, ((λ x ⇒ B) ∷ 0.A → ★ᵢ)/b] ∷ Q Sig {fst, snd, loc = sigLoc, _} => - let fst' = Ann fst (TYPE u noLoc) fst.loc + let fst' = Ann fst (TYPE u fst.loc) fst.loc snd' = Ann (Lam snd snd.loc) - (Arr Zero fst (TYPE u noLoc) fst.loc) snd.loc + (Arr Zero fst (TYPE u fst.loc) fst.loc) snd.loc in whnf defs ctx SZero $ Ann (subN (tycaseRhsDef def KSig arms) [< fst', snd']) ret loc @@ -150,8 +150,8 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} let a0 = a.zero; a1 = a.one in whnf defs ctx SZero $ Ann (subN (tycaseRhsDef def KEq arms) - [< Ann a0 (TYPE u noLoc) a.loc, Ann a1 (TYPE u noLoc) a.loc, - Ann (DLam a a.loc) (Eq0 (TYPE u noLoc) a0 a1 a.loc) a.loc, + [< Ann a0 (TYPE u a.loc) a.loc, Ann a1 (TYPE u a.loc) a.loc, + Ann (DLam a a.loc) (Eq0 (TYPE u a.loc) a0 a1 a.loc) a.loc, Ann l a0 l.loc, Ann r a1 r.loc]) ret loc @@ -166,5 +166,5 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} -- (type-case [π.A] ∷ ★ᵢ return Q of { [a] ⇒ s; ⋯ }) ⇝ s[(A ∷ ★ᵢ)/a] ∷ Q BOX {ty = a, loc = boxLoc, _} => whnf defs ctx SZero $ Ann - (sub1 (tycaseRhsDef def KBOX arms) (Ann a (TYPE u noLoc) a.loc)) + (sub1 (tycaseRhsDef def KBOX arms) (Ann a (TYPE u a.loc) a.loc)) ret loc From 1c8c50f3e23dcd8988c6d629557b20e751fedd9f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 30 Nov 2023 14:46:45 +0100 Subject: [PATCH 084/133] remove some unneeded Ord impls --- exe/Options.idr | 7 +++---- 1 file changed, 3 insertions(+), 4 deletions(-) diff --git a/exe/Options.idr b/exe/Options.idr index 256bca5..1c444e2 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -13,25 +13,24 @@ import Derive.Prelude public export data OutFile = File String | Console | NoOut %name OutFile f -%runElab derive "OutFile" [Eq, Ord, Show] +%runElab derive "OutFile" [Eq, Show] public export data Phase = Parse | Check | Erase | Scheme | End %name Phase p -%runElab derive "Phase" [Eq, Ord, Show] +%runElab derive "Phase" [Eq, Show] ||| a list of all intermediate `Phase`s (excluding `End`) public export %inline allPhases : List Phase allPhases = %runElab do - -- as a script so it stays up to date cs <- getCons $ fst !(lookupName "Phase") traverse (check . var) $ fromMaybe [] $ init' cs ||| `Guess` is `Term` for a terminal and `NoHL` for a file public export data HLType = Guess | NoHL | Term | Html -%runElab derive "HLType" [Eq, Ord, Show] +%runElab derive "HLType" [Eq, Show] public export record Dump where From 05a688d49e3bc45ec276127c36075ef671ff2db8 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 30 Nov 2023 14:47:27 +0100 Subject: [PATCH 085/133] reject "" in NatExtra.fromHex --- lib/Quox/NatExtra.idr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Quox/NatExtra.idr b/lib/Quox/NatExtra.idr index 64248ec..714add1 100644 --- a/lib/Quox/NatExtra.idr +++ b/lib/Quox/NatExtra.idr @@ -82,7 +82,7 @@ namespace Int export %inline fromHex : String -> Maybe Int - fromHex = fromHex' 0 + fromHex str = do guard $ str /= ""; fromHex' 0 str namespace Nat export From 642ac25a716f9123d7952dde604a2ee1eae9ae5f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 4 Jan 2024 13:11:13 +0100 Subject: [PATCH 086/133] happy new year [pack update. also idris 0.7.0] --- pack.toml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pack.toml b/pack.toml index 9843384..71aa281 100644 --- a/pack.toml +++ b/pack.toml @@ -1,4 +1,4 @@ -collection = "nightly-231020" +collection = "nightly-240101" [custom.all.tap] type = "git" From 325e128063216a51fd857945a0b7a70ff9bcc492 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 10 Feb 2024 11:39:07 +0100 Subject: [PATCH 087/133] =?UTF-8?q?add=20=CE=B7=20for=20False=20and=20True?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/Quox/Equal.idr | 11 ++++++----- 1 file changed, 6 insertions(+), 5 deletions(-) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 3ec9c0a..470fd2b 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -259,15 +259,16 @@ namespace Term compare0 defs ctx sg (sub1 snd (Ann s fst s.loc)) (E $ Snd e e.loc) t SOne => clashT loc ctx ty s t - compare0' defs ctx sg ty@(Enum {}) s t = local_ Equal $ + compare0' defs ctx sg ty@(Enum cases _) s t = local_ Equal $ + -- η for empty & singleton enums + if length (SortedSet.toList cases) <= 1 then pure () else case (s, t) of -- -------------------- - -- Γ ⊢ `t = `t ⇐ {ts} + -- Γ ⊢ 't = 't ⇐ {ts} -- -- t ∈ ts is in the typechecker, not here, ofc - (Tag t1 {}, Tag t2 {}) => - unless (t1 == t2) $ clashT s.loc ctx ty s t - (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f + (Tag t1 {}, Tag t2 {}) => unless (t1 == t2) $ clashT s.loc ctx ty s t + (E e, E f) => ignore $ Elim.compare0 defs ctx sg e f (Tag {}, E _) => clashT s.loc ctx ty s t (E _, Tag {}) => clashT s.loc ctx ty s t From 24ae5b85a25e776202d91514628768bd2757bef4 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 24 Feb 2024 15:45:04 +0100 Subject: [PATCH 088/133] fix a broken test???? --- tests/Tests/DimEq.idr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/tests/Tests/DimEq.idr b/tests/Tests/DimEq.idr index cbc7d34..f368991 100644 --- a/tests/Tests/DimEq.idr +++ b/tests/Tests/DimEq.idr @@ -97,7 +97,7 @@ tests = "dimension constraints" :- [ testPrettyD iijj ZeroIsOne "𝑖, 𝑗, 0 = 1", testPrettyD [<] new "" {label = "[empty output from empty context]"}, testPrettyD ii new "𝑖", - testPrettyD iijj (fromGround [< Zero, One]) + testPrettyD iijj (fromGround [< "𝑖", "𝑗"] [< Zero, One]) "𝑖, 𝑗, 𝑖 = 0, 𝑗 = 1", testPrettyD iijj (C [< Just (^K Zero), Nothing]) "𝑖, 𝑗, 𝑖 = 0", From b67162bda162fa3884b0bf7bdf26bcfc7a6b8fbb Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 24 Feb 2024 16:04:38 +0100 Subject: [PATCH 089/133] fix the other similar loops closes #38, again --- lib/Quox/Syntax/Term/Subst.idr | 18 +++++++++ lib/Quox/Typing/Context.idr | 35 +++++++++++++++-- lib/Quox/Whnf/Coercion.idr | 68 ++++++++++++++++++++-------------- 3 files changed, 89 insertions(+), 32 deletions(-) diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index 316b2bb..afc8eef 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -134,6 +134,15 @@ public export %inline dweakT : (by : Nat) -> Term d n -> Term (by + d) n dweakT by t = t // shift by +public export %inline +dweakS : (by : Nat) -> ScopeTermN s d n -> ScopeTermN s (by + d) n +dweakS by t = t // shift by + +public export %inline +dweakDS : {s : Nat} -> (by : Nat) -> + DScopeTermN s d n -> DScopeTermN s (by + d) n +dweakDS by t = t // shift by + public export %inline dweakE : (by : Nat) -> Elim d n -> Elim (by + d) n dweakE by t = t // shift by @@ -143,6 +152,15 @@ public export %inline weakT : (by : Nat) -> Term d n -> Term d (by + n) weakT by t = t // shift by +public export %inline +weakS : {s : Nat} -> (by : Nat) -> ScopeTermN s d n -> ScopeTermN s d (by + n) +weakS by t = t // shift by + +public export %inline +weakDS : {s : Nat} -> (by : Nat) -> + DScopeTermN s d n -> DScopeTermN s d (by + n) +weakDS by t = t // shift by + public export %inline weakE : (by : Nat) -> Elim d n -> Elim d (by + n) weakE by t = t // shift by diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index 671a06c..7b10046 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -26,6 +26,14 @@ CanShift (LocalVar d) where l // by = {type $= (// by), term $= map (// by)} l namespace LocalVar + export %inline + letVar : (type, term : Term d n) -> LocalVar d n + letVar type term = MkLocal {type, term = Just term} + + export %inline + lamVar : (type : Term d n) -> LocalVar d n + lamVar type = MkLocal {type, term = Nothing} + subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n subD th = {type $= (// th), term $= map (// th)} @@ -135,7 +143,7 @@ namespace TyContext export %inline extendTyN : CtxExtension d n1 n2 -> TyContext d n1 -> TyContext d n2 - extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, MkLocal s Nothing)) + extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s)) export %inline extendTyLetN0 : CtxExtensionLet0 d n1 n2 -> TyContext d n1 -> TyContext d n2 @@ -148,7 +156,7 @@ namespace TyContext export %inline extendTyLet : Qty -> BindName -> Term d n -> Term d n -> TyContext d n -> TyContext d (S n) - extendTyLet q x s e = extendTyLetN [< (q, x, MkLocal s (Just e))] + extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)] export %inline extendTy : Qty -> BindName -> Term d n -> TyContext d n -> TyContext d (S n) @@ -239,7 +247,7 @@ namespace EqContext export %inline extendTyN : CtxExtension 0 n1 n2 -> EqContext n1 -> EqContext n2 - extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, MkLocal s Nothing)) + extendTyN = extendTyLetN . map (\(q, x, s) => (q, x, lamVar s)) export %inline extendTyLetN0 : CtxExtensionLet0 0 n1 n2 -> EqContext n1 -> EqContext n2 @@ -252,7 +260,7 @@ namespace EqContext export %inline extendTyLet : Qty -> BindName -> Term 0 n -> Term 0 n -> EqContext n -> EqContext (S n) - extendTyLet q x s e = extendTyLetN [< (q, x, MkLocal s (Just e))] + extendTyLet q x s e = extendTyLetN [< (q, x, letVar s e)] export %inline extendTy : Qty -> BindName -> Term 0 n -> EqContext n -> EqContext (S n) @@ -293,6 +301,25 @@ namespace WhnfContext empty : WhnfContext 0 0 empty = MkWhnfContext [<] [<] [<] + export + extendTy' : BindName -> LocalVar d n -> WhnfContext d n -> WhnfContext d (S n) + extendTy' x var (MkWhnfContext {termLen, dnames, tnames, tctx}) = + MkWhnfContext { + dnames, + termLen = [|S termLen|], + tnames = tnames :< x, + tctx = tctx :< var + } + + export %inline + extendTy : BindName -> Term d n -> WhnfContext d n -> WhnfContext d (S n) + extendTy x ty ctx = extendTy' x (lamVar ty) ctx + + export %inline + extendTyLet : BindName -> (type, term : Term d n) -> + WhnfContext d n -> WhnfContext d (S n) + extendTyLet x type term ctx = extendTy' x (letVar {type, term}) ctx + export extendDimN : {s : Nat} -> BContext s -> WhnfContext d n -> WhnfContext (s + d) n diff --git a/lib/Quox/Whnf/Coercion.idr b/lib/Quox/Whnf/Coercion.idr index f8c0e12..c97ed91 100644 --- a/lib/Quox/Whnf/Coercion.idr +++ b/lib/Quox/Whnf/Coercion.idr @@ -119,7 +119,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} eqCoe sty@(S [< j] ty) p q val r loc = do -- (coe [j ⇒ Eq [i ⇒ A] L R] @p @q eq) @r -- ⇝ - -- comp [j ⇒ A‹r/i›] @p @q (eq ∷ (Eq [i ⇒ A] L R)‹p/j›) + -- comp [j ⇒ A‹r/i›] @p @q ((eq ∷ (Eq [i ⇒ A] L R)‹p/j›) @r) -- @r { 0 j ⇒ L; 1 j ⇒ R } let ctx1 = extendDim j ctx Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty @@ -147,6 +147,10 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} (ST body.names $ body.term // (a' ::: shift 1)) loc +-- new params block to call the above functions at different `n` +parameters {auto _ : CanWhnf Term Interface.isRedexT} + {auto _ : CanWhnf Elim Interface.isRedexE} + (defs : Definitions) (ctx : WhnfContext d n) (sg : SQty) ||| pushes a coercion inside a whnf-ed term export covering pushCoe : BindName -> @@ -163,17 +167,22 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} IOState tyLoc => whnf defs ctx sg $ Ann s (IOState tyLoc) loc - -- η expand it so that whnf for App can deal with it + -- η expand, then simplify the Coe/App in the body -- -- (coe (𝑖 ⇒ π.(x : A) → B) @p @q s) -- ⇝ -- (λ y ⇒ (coe (𝑖 ⇒ π.(x : A) → B) @p @q s) y) ∷ (π.(x : A) → B)‹q/𝑖› - Pi {} => - let inner = Coe (SY [< i] ty) p q s loc in + -- ⇝ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + -- (λ y ⇒ ⋯) ∷ (π.(x : A) → B)‹q/𝑖› -- see `piCoe` + -- + -- do the piCoe step here because otherwise equality checking keeps + -- doing the η forever + Pi {arg, res = S [< x] _, _} => do + let ctx' = extendTy x (arg // one p) ctx + body <- piCoe defs ctx' sg + (weakDS 1 $ SY [< i] ty) p q (weakT 1 s) (BVT 0 loc) loc whnf defs ctx sg $ - Ann (LamY !(mnb "y" loc) - (E $ App (weakE 1 inner) (BVT 0 loc) loc) loc) - (ty // one q) loc + Ann (LamY x (E body.fst) loc) (ty // one q) loc -- no η!!! -- push into a pair constructor, otherwise still stuck @@ -199,17 +208,23 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} Enum cases tyLoc => whnf defs ctx sg $ Ann s (Enum cases tyLoc) loc - -- η expand, same as for Π + -- η expand/simplify, same as for Π -- -- (coe (𝑖 ⇒ Eq (𝑗 ⇒ A) l r) @p @q s) -- ⇝ -- (δ 𝑘 ⇒ (coe (𝑖 ⇒ Eq (𝑗 ⇒ A) l r) @p @q s) @𝑘) ∷ (Eq (𝑗 ⇒ A) l r)‹q/𝑖› - Eq {} => - let inner = Coe (SY [< i] ty) p q s loc in + -- ⇝ ‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾‾ + -- (δ 𝑘 ⇒ ⋯) ∷ (Eq (𝑗 ⇒ A) l r)‹q/𝑖› -- see `eqCoe` + -- + -- do the eqCoe step here because otherwise equality checking keeps + -- doing the η forever + Eq {ty = S [< j] _, _} => do + let ctx' = extendDim j ctx + body <- eqCoe defs ctx' sg + (dweakDS 1 $ S [< i] $ Y ty) (weakD 1 p) (weakD 1 q) + (dweakT 1 s) (BV 0 loc) loc whnf defs ctx sg $ - Ann (DLamY !(mnb "k" loc) - (E $ DApp (dweakE 1 inner) (BV 0 loc) loc) loc) - (ty // one q) loc + Ann (DLamY i (E body.fst) loc) (ty // one q) loc -- (coe ℕ @_ @_ s) ⇝ (s ∷ ℕ) NAT tyLoc => @@ -219,22 +234,19 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} STRING tyLoc => whnf defs ctx sg $ Ann s (STRING tyLoc) loc - -- η expand.... kinda + -- η expand/simplify -- - -- (coe (𝑖 ⇒ [π. A]) @p @q s) + -- (coe (𝑖 ⇒ [π.A]) @p @q s) -- ⇝ - -- [case1 s ∷ [π.A]‹p/𝑖› return A‹q/𝑖› - -- of {[x] ⇒ coe (𝑖 ⇒ A) @p @q x}] ∷ [π.A]‹q/𝑖› + -- [case coe (𝑖 ⇒ [π.A]) @p @q s return A‹q/𝑖› of {[x] ⇒ x}] + -- ⇝ + -- [case1 s ∷ [π.A]‹p/𝑖› ⋯] ∷ [π.A]‹q/𝑖› -- see `boxCoe` -- - -- a literal η expansion of `e ⇝ [case e of {[x] ⇒ x}]` causes a loop in - -- the equality checker because whnf of `case e ⋯` requires whnf of `e` + -- do the eqCoe step here because otherwise equality checking keeps + -- doing the η forever BOX qty inner tyLoc => do - let inner = CaseBox { - qty = One, - box = Ann s (ty // one p) s.loc, - ret = SN $ inner // one q, - body = SY [< !(mnb "x" loc)] $ E $ - Coe (ST [< i] $ weakT 1 inner) p q (BVT 0 s.loc) s.loc, - loc - } - whnf defs ctx sg $ Ann (Box (E inner) loc) (ty // one q) loc + body <- boxCoe defs ctx sg qty + (SY [< i] ty) p q s + (SN $ inner // one q) + (SY [< !(mnb "inner" loc)] (BVT 0 loc)) loc + whnf defs ctx sg $ Ann (Box (E body.fst) loc) (ty // one q) loc From a8ac6f11f7f6b841d03a279c5067bfb5600c5bea Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Wed, 28 Feb 2024 16:49:15 +0100 Subject: [PATCH 090/133] fix a quantity in CaseBox --- lib/Quox/Equal.idr | 10 ++++------ 1 file changed, 4 insertions(+), 6 deletions(-) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 470fd2b..83748af 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -236,8 +236,6 @@ namespace Term -- Γ ⊢ s₁ = t₁ ⇐ A Γ ⊢ s₂ = t₂ ⇐ B{s₁/x} -- -------------------------------------------- -- Γ ⊢ (s₁, t₁) = (s₂,t₂) ⇐ (x : A) × B - -- - -- [todo] η for π ≥ 0 maybe (Pair sFst sSnd {}, Pair tFst tSnd {}) => do compare0 defs ctx sg fst sFst tFst compare0 defs ctx sg (sub1 snd (Ann sFst fst fst.loc)) sSnd tSnd @@ -331,9 +329,9 @@ namespace Term -- Γ ⊢ [s] = [t] ⇐ [π.A] (Box s _, Box t _) => compare0 defs ctx sg ty s t - -- Γ ⊢ s = (case1 e return A of {[x] ⇒ x}) ⇐ A - -- ----------------------------------------------- - -- Γ ⊢ [s] = e ⇐ [ρ.A] + -- Γ ⊢ σ⨴ρ · s = (case1 e return A of {[x] ⇒ x}) ⇐ A + -- ----------------------------------------------------- + -- Γ ⊢ σ · [s] = e ⇐ [ρ.A] (Box s loc, E f) => eta s f (E e, Box t loc) => eta t e @@ -347,7 +345,7 @@ namespace Term eta s e = do nm <- mnb "inner" e.loc let e = CaseBox One e (SN ty) (SY [< nm] (BVT 0 nm.loc)) e.loc - compare0 defs ctx sg ty s (E e) + compare0 defs ctx (sg `subjMult` q) ty s (E e) compare0' defs ctx sg ty@(E _) s t = do -- a neutral type can only be inhabited by neutral values From a9e8f14ad54823257d0930e2dca6a4df1471d9df Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 21 Mar 2024 21:29:01 +0100 Subject: [PATCH 091/133] fix a small bug in Q.Whnf.Coercion --- lib/Quox/Whnf/Coercion.idr | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/lib/Quox/Whnf/Coercion.idr b/lib/Quox/Whnf/Coercion.idr index c97ed91..91d94d2 100644 --- a/lib/Quox/Whnf/Coercion.idr +++ b/lib/Quox/Whnf/Coercion.idr @@ -199,7 +199,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} fstInSnd = CoeT !(fresh i) (tfst // (BV 0 loc ::: shift 2)) - (weakD 1 p) (BV 0 loc) (dweakT 1 s) fst.loc + (weakD 1 p) (BV 0 loc) (dweakT 1 fst) fst.loc snd' = CoeT i (sub1 tsnd fstInSnd) p q snd snd.loc whnf defs ctx sg $ Ann (Pair (E fst') (E snd') sLoc) (ty // one q) loc From 582666a254aa03a86ccdf644c55c799887892a8e Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 21 Mar 2024 21:29:13 +0100 Subject: [PATCH 092/133] comments in infer for coercions --- lib/Quox/Typechecker.idr | 11 +++++++++++ 1 file changed, 11 insertions(+) diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index a25e3cd..681aa7c 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -479,23 +479,34 @@ mutual pure $ InfRes {type = dsub1 ty dim, qout} infer' ctx sg (Coe ty p q val loc) = do + -- if Ψ, 𝑖 | Γ ⊢₀ A ⇐ Type _ checkType (extendDim ty.name ctx) ty.term Nothing + -- if Ψ | Γ ⊢ σ · s ⇐ A‹p/𝑖› ⊳ Σ qout <- checkC ctx sg val $ dsub1 ty p + -- then Ψ | Γ ⊢ σ · coe (𝑖 ⇒ A) @p @q s ⇒ A‹q/𝑖› ⊳ Σ pure $ InfRes {type = dsub1 ty q, qout} infer' ctx sg (Comp ty p q val r (S [< j0] val0) (S [< j1] val1) loc) = do + -- if Ψ | Γ ⊢₀ A ⇐ Type _ checkType ctx ty Nothing + -- if Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ qout <- checkC ctx sg val ty + -- if Ψ, 𝑗, 𝑖=0 | Γ ⊢ σ · t₀ ⇐ A ⊳ Σ₀ + -- Ψ, 𝑗, 𝑖=0, 𝑗=p | Γ ⊢ t₀ = s ⇐ A let ty' = dweakT 1 ty; val' = dweakT 1 val; p' = weakD 1 p ctx0 = extendDim j0 $ eqDim r (K Zero j0.loc) ctx val0 = getTerm val0 qout0 <- check ctx0 sg val0 ty' lift $ equal loc (eqDim (B VZ p.loc) p' ctx0) sg ty' val0 val' + -- if Ψ, 𝑗, 𝑖=1 | Γ ⊢ σ · t₁ ⇐ A ⊳ Σ₁ + -- Ψ, 𝑗, 𝑖=1, 𝑗=p | Γ ⊢ t₁ = s ⇐ A let ctx1 = extendDim j1 $ eqDim r (K One j1.loc) ctx val1 = getTerm val1 qout1 <- check ctx1 sg val1 ty' + -- if Σ = Σ₀ = Σ₁ lift $ equal loc (eqDim (B VZ p.loc) p' ctx1) sg ty' val1 val' let qouts = qout :: catMaybes [toMaybe qout0, toMaybe qout1] + -- then Ψ | Γ ⊢ comp A @p @q s @r {0 𝑗 ⇒ t₀; 1 𝑗 ⇒ t₁} ⇒ A ⊳ Σ pure $ InfRes {type = ty, qout = lubs ctx qouts} infer' ctx sg (TypeCase ty ret arms def loc) = do From 8cba73f7412debd4616c64a6f5e1dc6901fbd52b Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Wed, 27 Mar 2024 18:21:26 +0100 Subject: [PATCH 093/133] bump pack collection --- pack.toml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pack.toml b/pack.toml index 71aa281..61d7373 100644 --- a/pack.toml +++ b/pack.toml @@ -1,4 +1,4 @@ -collection = "nightly-240101" +collection = "nightly-240326" [custom.all.tap] type = "git" From efddb1aea14fb126fd7650e72f42f8b222fbe056 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Wed, 27 Mar 2024 18:21:45 +0100 Subject: [PATCH 094/133] skip broken pretty-printing tests till i fix them --- tests/Tests/PrettyTerm.idr | 1 + 1 file changed, 1 insertion(+) diff --git a/tests/Tests/PrettyTerm.idr b/tests/Tests/PrettyTerm.idr index 11356f7..7856e12 100644 --- a/tests/Tests/PrettyTerm.idr +++ b/tests/Tests/PrettyTerm.idr @@ -215,6 +215,7 @@ tests = "pretty printing terms" :- [ "type-case Nat :: Type 0 return Type 0 of { _ => Nat }" ], + skipWith "(todo: print user-written redundant annotations)" $ "annotations" :- [ testPrettyE [<] [<] (^Ann (^FT "a" 0) (^FT "A" 0)) From 41c8a92c97d604e2aa9c0d366f0c80cae05f3711 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 4 Apr 2024 19:26:13 +0200 Subject: [PATCH 095/133] bib fixes --- quox.bib | 12 ++++++------ 1 file changed, 6 insertions(+), 6 deletions(-) diff --git a/quox.bib b/quox.bib index e8954ed..f91bee2 100644 --- a/quox.bib +++ b/quox.bib @@ -20,7 +20,7 @@ @article{granule, author = {Dominic Orchard and Vilem{-}Benjamin Liepelt and Harley Eades III}, title = {Quantitative program reasoning with graded modal types}, - journal = {Proceedings of the ACM on Programming Languages}, + journal = {Proceedings of the {ACM} on Programming Languages}, volume = {3}, number = {{ICFP}}, pages = {110:1--110:30}, @@ -198,7 +198,7 @@ number = {POPL}, url = {https://doi.org/10.1145/3498670}, doi = {10.1145/3498670}, - journal = {Proc. ACM Program. Lang.}, + journal = {Proc. {ACM} Program. Lang.}, month = {jan}, articleno = {9}, numpages = {31}, @@ -239,7 +239,7 @@ for universe levels based on displacement algebras, for use in proof assistant implementations. }, - journal = {Proc. ACM Program. Lang.}, + journal = {Proc. {ACM} Program. Lang.}, month = {jan}, articleno = {57}, numpages = {27}, @@ -362,9 +362,9 @@ date = {2019-07}, doi = {10.1145/3341711}, issn = {2475-1421}, - journaltitle = {Proceedings of the ACM on Programming Languages}, + journaltitle = {Proceedings of the {ACM} on Programming Languages}, keywords = {Modal types,dependent types,normalization by evaluation,type-checking}, - number = {ICFP}, + number = {{ICFP}}, pages = {107:1--107:29}, title = {Implementing a Modal Dependent Type Theory}, volume = {3}, @@ -389,7 +389,7 @@ @article{defunc, author = {Yulong Huang and Jeremy Yallop}, title = {Defunctionalization with Dependent Types}, - journal = {Proceedings of the ACM on Programming Languages}, + journal = {Proceedings of the {ACM} on Programming Languages}, volume = {7}, number = {{PLDI}}, pages = {516--538}, From 727f968afb812c9aba4978749bf618403c58763f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 4 Apr 2024 19:26:30 +0200 Subject: [PATCH 096/133] add delimited continuations to bib --- quox.bib | 15 +++++++++++++++ 1 file changed, 15 insertions(+) diff --git a/quox.bib b/quox.bib index f91bee2..c673ea5 100644 --- a/quox.bib +++ b/quox.bib @@ -397,3 +397,18 @@ url = {https://doi.org/10.1145/3591241}, doi = {10.1145/3591241}, } + +@inproceedings{delcont-callcc, + author = {Martin Gasbichler and Michael Sperber}, + editor = {Mitchell Wand and Simon L. Peyton Jones}, + title = {Final shift for \texttt{call/cc}: + direct implementation of shift and reset}, + journaltitle = {Proceedings of the {ACM} on Programming Languages}, + number = {{ICFP}}, + pages = {271--282}, + publisher = {{ACM}}, + year = {2002}, + % url = {https://doi.org/10.1145/581478.581504}, + url = {https://www.cs.tufts.edu/~nr/cs257/archive/mike-sperber/shift-reset-direct.pdf}, + doi = {10.1145/581478.581504}, +} From ec839a1d4809c1a78a1cb27d15f144751d3869cd Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 4 Apr 2024 18:10:53 +0200 Subject: [PATCH 097/133] big Main refactor --- exe/CompileMonad.idr | 134 ++++++++++++++++++++++++ exe/Error.idr | 49 +++++++++ exe/Main.idr | 239 ++++--------------------------------------- exe/Options.idr | 31 +++--- exe/Output.idr | 59 +++++++++++ 5 files changed, 281 insertions(+), 231 deletions(-) create mode 100644 exe/CompileMonad.idr create mode 100644 exe/Error.idr create mode 100644 exe/Output.idr diff --git a/exe/CompileMonad.idr b/exe/CompileMonad.idr new file mode 100644 index 0000000..80fa2d3 --- /dev/null +++ b/exe/CompileMonad.idr @@ -0,0 +1,134 @@ +module CompileMonad + +import Quox.Syntax as Q +import Quox.Definition as Q +import Quox.Untyped.Syntax as U +import Quox.Parser +import Quox.Untyped.Erase +import Quox.Untyped.Scheme +import Quox.Pretty +import Options +import Output +import Error + +import System.File +import Data.IORef +import Control.Eff + +%default total + +%hide Doc.(>>=) +%hide Core.(>>=) + +%hide FromParser.Error +%hide Erase.Error +%hide Lexer.Error +%hide Parser.Error + + + +public export +record State where + constructor MkState + seen : IORef SeenSet + defs : IORef Q.Definitions + ns : IORef Mods + suf : IORef NameSuf +%name CompileMonad.State state + +export %inline +newState : HasIO io => io State +newState = pure $ MkState { + seen = !(newIORef empty), + defs = !(newIORef empty), + ns = !(newIORef [<]), + suf = !(newIORef 0) +} + + +public export +data CompileTag = OPTS | STATE + +public export +Compile : List (Type -> Type) +Compile = + [Except Error, + ReaderL STATE State, ReaderL OPTS Options, + LoadFile, IO] + +export covering %inline +runCompile : Options -> State -> Eff Compile a -> IO (Either Error a) +runCompile opts state act = do + fromIOErr $ runEff act $ with Union.(::) + [handleExcept (\e => ioLeft e), + handleReaderConst state, + handleReaderConst opts, + handleLoadFileIOE loadError ParseError state.seen opts.include, + liftIO] + +private %inline +rethrowFileC : String -> Either FileError a -> Eff Compile a +rethrowFileC f = rethrow . mapFst (WriteError f) + + +export %inline +outputStr : OpenFile -> Lazy String -> Eff Compile () +outputStr ONone _ = pure () +outputStr (OConsole COut) str = putStr str +outputStr (OConsole CErr) str = fPutStr stderr str >>= rethrowFileC "" +outputStr (OFile f h) str = fPutStr h str >>= rethrowFileC f + +export %inline +outputDocs : OpenFile -> + ({opts : LayoutOpts} -> Eff Pretty (List (Doc opts))) -> + Eff Compile () +outputDocs file docs = do + opts <- askAt OPTS + for_ (runPretty opts (toOutFile file) docs) $ \x => + outputStr file $ render (Opts opts.width) x + +export %inline +outputDoc : OpenFile -> + ({opts : LayoutOpts} -> Eff Pretty (Doc opts)) -> Eff Compile () +outputDoc file doc = outputDocs file $ singleton <$> doc + + +public export +data StopTag = STOP + +public export +CompileStop : List (Type -> Type) +CompileStop = FailL STOP :: Compile + +export %inline +withEarlyStop : Eff CompileStop () -> Eff Compile () +withEarlyStop = ignore . runFailAt STOP + +export %inline +stopHere : Has (FailL STOP) fs => Eff fs () +stopHere = failAt STOP + + +export %inline +liftFromParser : Eff FromParserIO a -> Eff Compile a +liftFromParser act = + runEff act $ with Union.(::) + [handleExcept $ \err => throw $ FromParserError err, + handleStateIORef !(asksAt STATE defs), + handleStateIORef !(asksAt STATE ns), + handleStateIORef !(asksAt STATE suf), + \g => send g] + +export %inline +liftErase : Q.Definitions -> Eff Erase a -> Eff Compile a +liftErase defs act = + runEff act + [handleExcept $ \err => throw $ EraseError err, + handleStateIORef !(asksAt STATE suf)] + +export %inline +liftScheme : Eff Scheme a -> Eff Compile (a, List Id) +liftScheme act = do + runEff [|MkPair act (getAt MAIN)|] + [handleStateIORef !(newIORef empty), + handleStateIORef !(newIORef [])] diff --git a/exe/Error.idr b/exe/Error.idr new file mode 100644 index 0000000..03d716c --- /dev/null +++ b/exe/Error.idr @@ -0,0 +1,49 @@ +module Error + +import Quox.Pretty +import Quox.Parser +import Quox.Untyped.Erase +import Quox.Untyped.Scheme +import Options +import Output + +import System.File + + +public export +data Error = + ParseError String Parser.Error +| FromParserError FromParser.Error +| EraseError Erase.Error +| WriteError FilePath FileError +| NoMain +| MultipleMains (List Scheme.Id) + +%hide FromParser.Error +%hide Erase.Error +%hide Lexer.Error +%hide Parser.Error + + +export +loadError : Loc -> FilePath -> FileError -> Error +loadError loc file err = FromParserError $ LoadError loc file err + +export +prettyError : {opts : LayoutOpts} -> Error -> Eff Pretty (Doc opts) +prettyError (ParseError file e) = prettyParseError file e +prettyError (FromParserError e) = FromParser.prettyError True e +prettyError (EraseError e) = Erase.prettyError True e +prettyError NoMain = pure "no #[main] function given" +prettyError (MultipleMains xs) = + pure $ sep ["multiple #[main] functions given:", + separateLoose "," !(traverse prettyId xs)] +prettyError (WriteError file e) = pure $ + hangSingle 2 (text "couldn't write file \{file}:") (pshow e) + +export +dieError : Options -> Error -> IO a +dieError opts e = + die (Opts opts.width) $ + runPretty ({outFile := Console} opts) Console $ + prettyError e diff --git a/exe/Main.idr b/exe/Main.idr index 9385eeb..192ce42 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -8,6 +8,9 @@ import Quox.Untyped.Erase import Quox.Untyped.Scheme import Quox.Pretty import Options +import Output +import Error +import CompileMonad import System import System.File @@ -19,227 +22,27 @@ import Control.Eff %hide Doc.(>>=) %hide Core.(>>=) - -private -die : HasIO io => (opts : LayoutOpts) -> Doc opts -> io a -die opts err = do - ignore $ fPutStr stderr $ render opts err - exitFailure - -private -hlFor : HLType -> OutFile -> HL -> Highlight -hlFor Guess Console = highlightSGR -hlFor Guess _ = noHighlight -hlFor NoHL _ = noHighlight -hlFor Term _ = highlightSGR -hlFor Html _ = highlightHtml - -private -runPretty : Options -> OutFile -> Eff Pretty a -> a -runPretty opts file act = - runPrettyWith Outer opts.flavor (hlFor opts.hlType file) 2 act - -private -record State where - constructor MkState - seen : IORef SeenSet - defs : IORef Q.Definitions - ns : IORef Mods - suf : IORef NameSuf -%name Main.State state - -private -newState : HasIO io => io State -newState = pure $ MkState { - seen = !(newIORef empty), - defs = !(newIORef empty), - ns = !(newIORef [<]), - suf = !(newIORef 0) -} - -private -data Error = - ParseError String Parser.Error -| FromParserError FromParser.Error -| EraseError Erase.Error -| WriteError FilePath FileError -| NoMain -| MultipleMains (List Id) %hide FromParser.Error %hide Erase.Error %hide Lexer.Error %hide Parser.Error -private -loadError : Loc -> FilePath -> FileError -> Error -loadError loc file err = FromParserError $ LoadError loc file err - -private -prettyError : {opts : LayoutOpts} -> Error -> Eff Pretty (Doc opts) -prettyError (ParseError file e) = prettyParseError file e -prettyError (FromParserError e) = FromParser.prettyError True e -prettyError (EraseError e) = Erase.prettyError True e -prettyError NoMain = pure "no #[main] function given" -prettyError (MultipleMains xs) = - pure $ sep ["multiple #[main] functions given:", - separateLoose "," !(traverse prettyId xs)] -prettyError (WriteError file e) = pure $ - hangSingle 2 (text "couldn't write file \{file}:") (pshow e) - -private -dieError : Options -> Error -> IO a -dieError opts e = - die (Opts opts.width) $ - runPretty ({outFile := Console} opts) Console $ - prettyError e - -private -data CompileTag = OPTS | STATE - -private -Compile : List (Type -> Type) -Compile = - [Except Error, - ReaderL STATE State, ReaderL OPTS Options, - LoadFile, IO] - -private covering -runCompile : Options -> State -> Eff Compile a -> IO (Either Error a) -runCompile opts state act = - fromIOErr $ runEff act $ with Union.(::) - [handleExcept (\e => ioLeft e), - handleReaderConst state, - handleReaderConst opts, - handleLoadFileIOE loadError ParseError state.seen opts.include, - liftIO] - - -private -data StopTag = STOP - -private -CompileStop : List (Type -> Type) -CompileStop = FailL STOP :: Compile - -private -withEarlyStop : Has (FailL STOP) fs => Eff fs () -> Eff (fs - FailL STOP) () -withEarlyStop = ignore . runFailAt STOP - -private -stopHere : Has (FailL STOP) fs => Eff fs () -stopHere = failAt STOP - - -private -data ConsoleChannel = COut | CErr - -private -data OpenFile = OConsole ConsoleChannel | OFile String File | ONone - -private -rethrowFile : String -> Either FileError a -> Eff Compile a -rethrowFile f = rethrow . mapFst (WriteError f) - -private -toOutFile : OpenFile -> OutFile -toOutFile (OConsole _) = Console -toOutFile (OFile f _) = File f -toOutFile ONone = NoOut - -private -withFileC : String -> (OpenFile -> Eff Compile a) -> Eff Compile a -withFileC f act = - withFile f WriteTruncate pure (Prelude.map Right . act . OFile f) >>= - rethrowFile f - -private -withOutFile : ConsoleChannel -> OutFile -> - (OpenFile -> Eff Compile a) -> Eff Compile a -withOutFile _ (File f) act = withFileC f act -withOutFile ch Console act = act $ OConsole ch -withOutFile _ NoOut act = act ONone - -private -outputStr : OpenFile -> Lazy String -> Eff Compile () -outputStr ONone _ = pure () -outputStr (OConsole COut) str = putStr str -outputStr (OConsole CErr) str = fPutStr stderr str >>= rethrowFile "" -outputStr (OFile f h) str = fPutStr h str >>= rethrowFile f - -private -outputDocs : OpenFile -> - ({opts : LayoutOpts} -> Eff Pretty (List (Doc opts))) -> - Eff Compile () -outputDocs file docs = do - opts <- askAt OPTS - for_ (runPretty opts (toOutFile file) docs) $ \x => - outputStr file $ render (Opts opts.width) x - -private -outputDoc : OpenFile -> - ({opts : LayoutOpts} -> Eff Pretty (Doc opts)) -> Eff Compile () -outputDoc file doc = outputDocs file $ singleton <$> doc - -private -liftFromParser : Eff FromParserIO a -> Eff Compile a -liftFromParser act = - runEff act $ with Union.(::) - [handleExcept $ \err => throw $ FromParserError err, - handleStateIORef !(asksAt STATE defs), - handleStateIORef !(asksAt STATE ns), - handleStateIORef !(asksAt STATE suf), - \g => send g] - -private -liftErase : Q.Definitions -> Eff Erase a -> Eff Compile a -liftErase defs act = - runEff act - [handleExcept $ \err => throw $ EraseError err, - handleStateIORef !(asksAt STATE suf)] - -private -liftScheme : Eff Scheme a -> Eff Compile (a, List Id) -liftScheme act = do - runEff [|MkPair act (getAt MAIN)|] - [handleStateIORef !(newIORef empty), - handleStateIORef !(newIORef [])] - - private Step : Type -> Type -> Type -Step i o = OpenFile -> i -> Eff Compile o - --- private --- processFile : String -> Eff Compile () --- processFile file = withEarlyStop $ do --- Just ast <- loadFile noLoc file --- | Nothing => pure () --- -- putErrLn "checking \{file}" --- when (!(asksAt OPTS until) == Just Parse) $ do --- lift $ outputStr $ show ast --- stopHere --- defList <- liftFromParser $ concat <$> traverse fromPTopLevel ast --- outputDocStopIf Check $ --- traverse (uncurry Q.prettyDef) defList --- let defs = SortedMap.fromList defList --- erased <- liftErase defs $ --- traverse (\(x, d) => (x,) <$> eraseDef defs x d) defList --- outputDocStopIf Erase $ --- traverse (uncurry U.prettyDef) erased --- (scheme, mains) <- liftScheme $ map catMaybes $ --- traverse (uncurry defToScheme) erased --- outputDocStopIf Scheme $ --- intersperse empty <$> traverse prettySexp scheme +Step a b = OpenFile -> a -> Eff Compile b private step : {default CErr console : ConsoleChannel} -> - Phase -> OutFile -> Step i o -> i -> Eff CompileStop o + Phase -> OutFile -> Step a b -> a -> Eff CompileStop b step phase file act x = do opts <- askAt OPTS - res <- lift $ withOutFile console file $ \h => act h x + res <- withOutFile console file fromError $ \h => lift $ act h x when (opts.until == Just phase) stopHere pure res +where + fromError : String -> FileError -> Eff CompileStop c + fromError file err = throw $ WriteError file err private covering @@ -268,25 +71,23 @@ erase h defList = where defs = SortedMap.fromList defList private covering -scheme : Step (List U.NDefinition) (List Sexp, Id) +scheme : Step (List U.NDefinition) (List Sexp, List Id) scheme h defs = do sexps' <- for defs $ \(x, d) => do (msexp, mains) <- liftScheme $ defToScheme x d - outputDoc h $ maybe (sayErased x) prettySexp msexp + outputDoc h $ case msexp of + Just s => prettySexp s + Nothing => pure $ hsep [";;", prettyName x, "erased"] pure (msexp, mains) - bitraverse (pure . catMaybes) (oneMain . concat) $ unzip sexps' -where - sayErased : {opts : LayoutOpts} -> Name -> Eff Pretty (Doc opts) - sayErased x = pure $ hsep [";;", prettyName x, "erased"] - - oneMain : List Id -> Eff Compile Id - oneMain [m] = pure m - oneMain [] = throw NoMain - oneMain ms = throw $ MultipleMains ms + pure $ bimap catMaybes concat $ unzip sexps' private covering -output : Step (List Sexp, Id) () -output h (sexps, main) = +output : Step (List Sexp, List Id) () +output h (sexps, mains) = do + main <- case mains of + [m] => pure m + [] => throw NoMain + _ => throw $ MultipleMains mains lift $ outputDocs h $ do res <- traverse prettySexp sexps runner <- makeRunMain main diff --git a/exe/Options.idr b/exe/Options.idr index 1c444e2..b92b668 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -1,6 +1,8 @@ module Options import Quox.Pretty +import Data.DPair +import Data.SortedMap import System import System.Console.GetOpt import System.File @@ -42,13 +44,13 @@ record Dump where public export record Options where constructor MkOpts - hlType : HLType + include : List String dump : Dump outFile : OutFile until : Maybe Phase + hlType : HLType flavor : Pretty.Flavor width : Nat - include : List String %name Options opts %runElab derive "Options" [Show] @@ -61,13 +63,13 @@ defaultWidth = do export defaultOpts : IO Options defaultOpts = pure $ MkOpts { - hlType = Guess, + include = ["."], dump = MkDump NoOut NoOut NoOut NoOut, outFile = Console, until = Nothing, + hlType = Guess, flavor = Unicode, - width = !defaultWidth, - include = ["."] + width = !defaultWidth } private @@ -118,11 +120,12 @@ toHLType str = case toLower str of "html" => Ok {hlType := Html} _ => Err "unknown highlighting type \{show str}\ntypes: term, html, none" -||| like ghc, -i '' clears the search path; -i a:b:c adds a,b,c to the end +||| like ghc, `-i ""` clears the search path; +||| `-i a:b:c` adds `a`, `b`, `c` to the end private dirListFlag : String -> List String -> List String -dirListFlag arg val = - if null arg then [] else val ++ toList (split (== ':') arg) +dirListFlag "" val = [] +dirListFlag dirs val = val ++ toList (split (== ':') dirs) private commonOptDescrs' : List (OptDescr OptAction) @@ -148,13 +151,17 @@ extraOptDescrs = [ MkOpt [] ["color", "colour"] (ReqArg toHLType "") "select highlighting type", - MkOpt [] ["dparse"] (ReqArg (\s => Ok {dump.parse := toOutFile s}) "") + MkOpt [] ["dump-parse"] + (ReqArg (\s => Ok {dump.parse := toOutFile s}) "") "dump AST", - MkOpt [] ["dcheck"] (ReqArg (\s => Ok {dump.check := toOutFile s}) "") + MkOpt [] ["dump-check"] + (ReqArg (\s => Ok {dump.check := toOutFile s}) "") "dump typechecker output", - MkOpt [] ["derase"] (ReqArg (\s => Ok {dump.erase := toOutFile s}) "") + MkOpt [] ["dump-erase"] + (ReqArg (\s => Ok {dump.erase := toOutFile s}) "") "dump erasure output", - MkOpt [] ["dscheme"] (ReqArg (\s => Ok {dump.scheme := toOutFile s}) "") + MkOpt [] ["dump-scheme"] + (ReqArg (\s => Ok {dump.scheme := toOutFile s}) "") "dump scheme output (without prelude)" ] diff --git a/exe/Output.idr b/exe/Output.idr new file mode 100644 index 0000000..77eed61 --- /dev/null +++ b/exe/Output.idr @@ -0,0 +1,59 @@ +module Output + +import Quox.Pretty +import Options + +import System.File +import System + +public export +data ConsoleChannel = COut | CErr + +export +consoleHandle : ConsoleChannel -> File +consoleHandle COut = stdout +consoleHandle CErr = stderr + +public export +data OpenFile = OConsole ConsoleChannel | OFile String File | ONone + +export +toOutFile : OpenFile -> OutFile +toOutFile (OConsole _) = Console +toOutFile (OFile f _) = File f +toOutFile ONone = NoOut + +export +withFile : HasIO m => String -> (String -> FileError -> m a) -> + (OpenFile -> m a) -> m a +withFile f catch act = Prelude.do + res <- withFile f WriteTruncate pure (Prelude.map Right . act . OFile f) + either (catch f) pure res + +export +withOutFile : HasIO m => ConsoleChannel -> OutFile -> + (String -> FileError -> m a) -> (OpenFile -> m a) -> m a +withOutFile _ (File f) catch act = withFile f catch act +withOutFile ch Console catch act = act $ OConsole ch +withOutFile _ NoOut catch act = act ONone + + + +private +hlFor : HLType -> OutFile -> HL -> Highlight +hlFor Guess Console = highlightSGR +hlFor Guess _ = noHighlight +hlFor NoHL _ = noHighlight +hlFor Term _ = highlightSGR +hlFor Html _ = highlightHtml + +export +runPretty : Options -> OutFile -> Eff Pretty a -> a +runPretty opts file act = + runPrettyWith Outer opts.flavor (hlFor opts.hlType file) 2 act + +export +die : HasIO io => (opts : LayoutOpts) -> Doc opts -> io a +die opts err = do + ignore $ fPutStr stderr $ render opts err + exitFailure From 78555711ce1f364d5766a1f94973f3c29c8a2c07 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 4 Apr 2024 18:11:26 +0200 Subject: [PATCH 098/133] add Q.Log --- lib/Control/Monad/ST/Extra.idr | 18 +++ lib/Quox/EffExtra.idr | 4 + lib/Quox/Log.idr | 240 +++++++++++++++++++++++++++++++++ lib/quox-lib.ipkg | 1 + 4 files changed, 263 insertions(+) create mode 100644 lib/Quox/Log.idr diff --git a/lib/Control/Monad/ST/Extra.idr b/lib/Control/Monad/ST/Extra.idr index 52e16ee..7ddeef1 100644 --- a/lib/Control/Monad/ST/Extra.idr +++ b/lib/Control/Monad/ST/Extra.idr @@ -62,3 +62,21 @@ export %inline HasST (STErr e) where liftST = STE . map Right export stLeft : e -> STErr e s a stLeft e = STE $ pure $ Left e + + +parameters {auto _ : HasST m} + export %inline + newSTRef' : a -> m s (STRef s a) + newSTRef' x = liftST $ newSTRef x + + export %inline + readSTRef' : STRef s a -> m s a + readSTRef' r = liftST $ readSTRef r + + export %inline + writeSTRef' : STRef s a -> a -> m s () + writeSTRef' r x = liftST $ writeSTRef r x + + export %inline + modifySTRef' : STRef s a -> (a -> a) -> m s () + modifySTRef' r f = liftST $ modifySTRef r f diff --git a/lib/Quox/EffExtra.idr b/lib/Quox/EffExtra.idr index 6d9d311..fc6da93 100644 --- a/lib/Quox/EffExtra.idr +++ b/lib/Quox/EffExtra.idr @@ -97,6 +97,10 @@ export handleReaderConst : Applicative m => r -> ReaderL lbl r a -> m a handleReaderConst x Ask = pure x +export +handleWriterST : HasST m => STRef s (SnocList w) -> WriterL lbl w a -> m s a +handleWriterST ref (Tell w) = liftST $ modifySTRef ref (:< w) + public export record IOErr e a where diff --git a/lib/Quox/Log.idr b/lib/Quox/Log.idr new file mode 100644 index 0000000..36a5ce7 --- /dev/null +++ b/lib/Quox/Log.idr @@ -0,0 +1,240 @@ +module Quox.Log + +import Quox.Loc +import Quox.Pretty + +import Data.So +import Data.DPair +import Data.Maybe +import Data.List1 +import Control.Eff +import Control.Monad.ST.Extra +import Data.IORef +import System.File +import Derive.Prelude + +%default total +%language ElabReflection + + +public export +maxLogLevel : Nat +maxLogLevel = 100 + +public export +logCategories : List String +logCategories = ["whnf", "equal", "check"] + +public export %inline +isLogLevel : Nat -> Bool +isLogLevel l = l <= maxLogLevel + +public export +IsLogLevel : Nat -> Type +IsLogLevel l = So $ isLogLevel l + +public export %inline +isLogCategory : String -> Bool +isLogCategory cat = cat `elem` logCategories + +public export +IsLogCategory : String -> Type +IsLogCategory cat = So $ isLogCategory cat + + +public export +LogLevel : Type +LogLevel = Subset Nat IsLogLevel + +public export +LogCategory : Type +LogCategory = Subset String IsLogCategory + + +public export %inline +toLogLevel : Nat -> Maybe LogLevel +toLogLevel l = + case choose $ isLogLevel l of + Left y => Just $ Element l y + Right _ => Nothing + +public export %inline +toLogCategory : String -> Maybe LogCategory +toLogCategory c = + case choose $ isLogCategory c of + Left y => Just $ Element c y + Right _ => Nothing + + +public export +LevelMap : Type +LevelMap = List (LogCategory, LogLevel) +-- i tried SortedMap first, but it is too much overhead for LevelMaps + +public export +record LogLevels where + constructor MkLogLevels + defLevel : LogLevel + levels : LevelMap +%name LogLevels lvls +%runElab derive "LogLevels" [Eq, Show] + +public export +LevelStack : Type +LevelStack = List1 LogLevels + +export %inline +defaultLogLevels : LogLevels +defaultLogLevels = MkLogLevels (Element 0 Oh) [] + +export %inline +initStack : LevelStack +initStack = singleton defaultLogLevels + +||| right biased for the default and for overlapping elements +public export %inline +mergeLevels : LogLevels -> LogLevels -> LogLevels +mergeLevels (MkLogLevels _ map1) (MkLogLevels def map2) = + MkLogLevels def $ map1 ++ map2 + +export %inline +getLevel : LogCategory -> LogLevels -> LogLevel +getLevel cat lvls = fromMaybe lvls.defLevel $ lookup cat lvls.levels + + +public export +LogDoc : Type +LogDoc = Doc (Opts {lineLength = 80}) + + +public export +data PushArg = SetDefault LogLevel | SetCats LevelMap +%name PushArg push + +export %inline +mergePush : PushArg -> LogLevels -> LogLevels +mergePush (SetDefault def) = {defLevel := def} +mergePush (SetCats map) = {levels $= (map ++)} + + +public export +record LogMsg where + constructor (:>) + level : Nat + {auto 0 levelOk : IsLogLevel level} + message : Lazy LogDoc +infix 0 :> +%name Log.LogMsg msg + +public export +data LogL : (lbl : tag) -> Type -> Type where + SayMany : (cat : LogCategory) -> (loc : Loc) -> + (msgs : List LogMsg) -> LogL lbl () + Push : (push : PushArg) -> LogL lbl () + Pop : LogL lbl () + CurLevels : LogL lbl LogLevels + +public export +Log : Type -> Type +Log = LogL () + +parameters (0 lbl : tag) {auto _ : Has (LogL lbl) fs} + public export %inline + sayManyAt : (cat : String) -> (0 catOk : IsLogCategory cat) => + Loc -> List LogMsg -> Eff fs () + sayManyAt cat loc msgs {catOk} = + send $ SayMany {lbl} (Element cat catOk) loc msgs + + public export %inline + sayAt : (cat : String) -> (0 catOk : IsLogCategory cat) => + (lvl : Nat) -> (0 lvlOk : IsLogLevel lvl) => + Loc -> Lazy LogDoc -> Eff fs () + sayAt cat lvl loc msg = sayManyAt cat loc [lvl :> msg] + + public export %inline + pushAt : PushArg -> Eff fs () + pushAt lvls = send $ Push {lbl} lvls + + public export %inline + popAt : Eff fs () + popAt = send $ Pop {lbl} + + public export %inline + curLevelsAt : Eff fs LogLevels + curLevelsAt = send $ CurLevels {lbl} + +parameters {auto _ : Has Log fs} + public export %inline + sayMany : (cat : String) -> (0 catOk : IsLogCategory cat) => + Loc -> List LogMsg -> Eff fs () + sayMany = sayManyAt () + + public export %inline + say : (cat : String) -> (0 _ : IsLogCategory cat) => + (lvl : Nat) -> (0 _ : IsLogLevel lvl) => + Loc -> Lazy LogDoc -> Eff fs () + say = sayAt () + + public export %inline + push : PushArg -> Eff fs () + push = pushAt () + + public export %inline + pop : Eff fs () + pop = popAt () + + public export %inline + curLevels : Eff fs LogLevels + curLevels = curLevelsAt () + + +export %inline +doPush : PushArg -> LevelStack -> LevelStack +doPush push list = mergePush push (head list) `cons` list + +export %inline +doPop : List1 a -> List1 a +doPop (_ ::: x :: xs) = x ::: xs +doPop (x ::: []) = x ::: [] + +export %inline +doSayMany : Applicative m => + LevelStack -> (LogDoc -> m ()) -> + LogCategory -> Loc -> List LogMsg -> m () +doSayMany (lvls ::: _) act cat loc msgs = do + let Element catLvl _ = getLevel cat lvls + loc = runPretty $ prettyLoc loc + for_ msgs $ \msg => when (msg.level <= catLvl) $ + act $ hcat [loc, text cat.fst, "@", pshow msg.level, ":"] <++> + msg.message + +export %inline +handleLogIO : HasIO m => (FileError -> m ()) -> + IORef LevelStack -> File -> LogL tag a -> m a +handleLogIO th lvls h = \case + Push push => modifyIORef lvls $ doPush push + Pop => modifyIORef lvls doPop + SayMany cat loc msgs => doSayMany !(readIORef lvls) printMsg cat loc msgs + CurLevels => head <$> readIORef lvls +where printMsg : LogDoc -> m () + printMsg msg = fPutStr h (render _ msg) >>= either th pure + +export %inline +handleLogST : (HasST m, Monad (m s)) => + STRef s (SnocList LogDoc) -> STRef s LevelStack -> + LogL tag a -> m s a +handleLogST docs lvls = \case + Push push => modifySTRef' lvls $ doPush push + Pop => modifySTRef' lvls doPop + SayMany cat loc msgs => doSayMany !(readSTRef' lvls) printMsg cat loc msgs + CurLevels => head <$> readSTRef' lvls +where printMsg : LogDoc -> m s () + printMsg msg = modifySTRef' docs (:< msg) + +export %inline +handleLogDiscard : Applicative m => LogL tag a -> m a +handleLogDiscard = \case + SayMany {} => pure () + Push {} => pure () + Pop => pure () + CurLevels => pure defaultLogLevels diff --git a/lib/quox-lib.ipkg b/lib/quox-lib.ipkg index f5d188a..62b4ee6 100644 --- a/lib/quox-lib.ipkg +++ b/lib/quox-lib.ipkg @@ -19,6 +19,7 @@ modules = Quox.PrettyValExtra, Quox.Decidable, Quox.No, + Quox.Log, Quox.Loc, Quox.Var, Quox.Scoped, From e6ad16813ec07d3b377248fd03a9de56c67f8f2c Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 4 Apr 2024 18:13:45 +0200 Subject: [PATCH 099/133] add log effects to executable --- exe/CompileMonad.idr | 35 ++++++++++++++++---- exe/Main.idr | 1 + exe/Options.idr | 79 +++++++++++++++++++++++++++++++++++--------- 3 files changed, 93 insertions(+), 22 deletions(-) diff --git a/exe/CompileMonad.idr b/exe/CompileMonad.idr index 80fa2d3..4ec2a76 100644 --- a/exe/CompileMonad.idr +++ b/exe/CompileMonad.idr @@ -7,6 +7,7 @@ import Quox.Parser import Quox.Untyped.Erase import Quox.Untyped.Scheme import Quox.Pretty +import Quox.Log import Options import Output import Error @@ -53,18 +54,38 @@ public export Compile : List (Type -> Type) Compile = [Except Error, - ReaderL STATE State, ReaderL OPTS Options, + ReaderL STATE State, ReaderL OPTS Options, Log, LoadFile, IO] +export %inline +handleLog : IORef LevelStack -> OpenFile -> LogL x a -> IOErr Error a +handleLog lvls f l = case f of + OConsole ch => handleLogIO (const $ pure ()) lvls (consoleHandle ch) l + OFile _ h => handleLogIO (const $ pure ()) lvls h l + ONone => handleLogDiscard l + +private %inline +withLogFile : Options -> + (IORef LevelStack -> OpenFile -> IO (Either Error a)) -> + IO (Either Error a) +withLogFile opts act = do + lvlStack <- newIORef $ singleton opts.logLevels + withOutFile CErr opts.logFile fromError $ act lvlStack +where + fromError : String -> FileError -> IO (Either Error a) + fromError file err = pure $ Left $ WriteError file err + export covering %inline runCompile : Options -> State -> Eff Compile a -> IO (Either Error a) runCompile opts state act = do - fromIOErr $ runEff act $ with Union.(::) - [handleExcept (\e => ioLeft e), - handleReaderConst state, - handleReaderConst opts, - handleLoadFileIOE loadError ParseError state.seen opts.include, - liftIO] + withLogFile opts $ \lvls, logFile => + fromIOErr $ runEff act $ with Union.(::) + [handleExcept (\e => ioLeft e), + handleReaderConst state, + handleReaderConst opts, + handleLog lvls logFile, + handleLoadFileIOE loadError ParseError state.seen opts.include, + liftIO] private %inline rethrowFileC : String -> Either FileError a -> Eff Compile a diff --git a/exe/Main.idr b/exe/Main.idr index 192ce42..e23184b 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -7,6 +7,7 @@ import Quox.Parser import Quox.Untyped.Erase import Quox.Untyped.Scheme import Quox.Pretty +import Quox.Log import Options import Output import Error diff --git a/exe/Options.idr b/exe/Options.idr index b92b668..f1788df 100644 --- a/exe/Options.idr +++ b/exe/Options.idr @@ -1,6 +1,7 @@ module Options import Quox.Pretty +import Quox.Log import Data.DPair import Data.SortedMap import System @@ -44,13 +45,15 @@ record Dump where public export record Options where constructor MkOpts - include : List String - dump : Dump - outFile : OutFile - until : Maybe Phase - hlType : HLType - flavor : Pretty.Flavor - width : Nat + include : List String + dump : Dump + outFile : OutFile + until : Maybe Phase + hlType : HLType + flavor : Pretty.Flavor + width : Nat + logLevels : LogLevels + logFile : OutFile %name Options opts %runElab derive "Options" [Show] @@ -63,13 +66,15 @@ defaultWidth = do export defaultOpts : IO Options defaultOpts = pure $ MkOpts { - include = ["."], - dump = MkDump NoOut NoOut NoOut NoOut, - outFile = Console, - until = Nothing, - hlType = Guess, - flavor = Unicode, - width = !defaultWidth + include = ["."], + dump = MkDump NoOut NoOut NoOut NoOut, + outFile = Console, + until = Nothing, + hlType = Guess, + flavor = Unicode, + width = !defaultWidth, + logLevels = defaultLogLevels, + logFile = Console } private @@ -127,6 +132,46 @@ dirListFlag : String -> List String -> List String dirListFlag "" val = [] dirListFlag dirs val = val ++ toList (split (== ':') dirs) +private +splitLogFlag : String -> Either String (List (Maybe LogCategory, LogLevel)) +splitLogFlag = traverse flag1 . toList . split (== ':') where + parseLogCategory : String -> Either String LogCategory + parseLogCategory cat = do + let Just cat = toLogCategory cat + | _ => let catList = joinBy ", " logCategories in + Left "unknown log category. categories are:\n\{catList}" + pure cat + + parseLogLevel : String -> Either String LogLevel + parseLogLevel lvl = do + let Just lvl = parsePositive lvl + | _ => Left "log level \{lvl} not a number" + let Just lvl = toLogLevel lvl + | _ => Left "log level \{show lvl} out of range 0–\{show maxLogLevel}" + pure lvl + + flag1 : String -> Either String (Maybe LogCategory, LogLevel) + flag1 str = do + let (first, second) = break (== '=') str + case strM second of + StrCons '=' lvl => do + cat <- parseLogCategory first + lvl <- parseLogLevel lvl + pure (Just cat, lvl) + StrNil => (Nothing,) <$> parseLogLevel first + _ => Left "invalid log flag \{str}" + +private +setLogFlag : LogLevels -> (Maybe LogCategory, LogLevel) -> LogLevels +setLogFlag lvls (Nothing, lvl) = {defLevel := lvl} lvls +setLogFlag lvls (Just name, lvl) = {levels $= ((name, lvl) ::)} lvls + +private +logFlag : String -> OptAction +logFlag str = case splitLogFlag str of + Left err => Err err + Right flags => Ok $ \o => {logLevels := foldl setLogFlag o.logLevels flags} o + private commonOptDescrs' : List (OptDescr OptAction) commonOptDescrs' = [ @@ -136,7 +181,11 @@ commonOptDescrs' = [ MkOpt ['o'] ["output"] (ReqArg (\s => Ok {outFile := toOutFile s}) "") "output file (\"-\" for stdout, \"\" for no output)", MkOpt ['P'] ["phase"] (ReqArg toPhase "") - "stop after the given phase" + "stop after the given phase", + MkOpt ['l'] ["log"] (ReqArg logFlag "[=]:...") + "set log level", + MkOpt ['L'] ["log-file"] (ReqArg (\s => Ok {logFile := toOutFile s}) "") + "set log output file" ] private From 861bd55f9463e5e583802438ad40c6f2e33657b1 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 4 Apr 2024 18:23:50 +0200 Subject: [PATCH 100/133] add log effects to FromParser --- exe/CompileMonad.idr | 1 + lib/Quox/Parser/FromParser.idr | 58 ++++++++++++++++++---------------- tests/Tests/FromPTerm.idr | 2 +- 3 files changed, 33 insertions(+), 28 deletions(-) diff --git a/exe/CompileMonad.idr b/exe/CompileMonad.idr index 4ec2a76..3f20fc7 100644 --- a/exe/CompileMonad.idr +++ b/exe/CompileMonad.idr @@ -138,6 +138,7 @@ liftFromParser act = handleStateIORef !(asksAt STATE defs), handleStateIORef !(asksAt STATE ns), handleStateIORef !(asksAt STATE suf), + \g => send g, \g => send g] export %inline diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index ce22ae2..b49976d 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -32,41 +32,44 @@ data StateTag = NS | SEEN public export FromParserPure : List (Type -> Type) -FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen] +FromParserPure = [Except Error, DefsState, StateL NS Mods, NameGen, Log] public export FromParserIO : List (Type -> Type) FromParserIO = FromParserPure ++ [LoadFile] +public export +record PureParserResult a where + constructor MkPureParserResult + val : a + suf : NameSuf + defs : Definitions + log : SnocList LogDoc + logLevels : LevelStack + export fromParserPure : {default [<] ns : Mods} -> - NameSuf -> Definitions -> - Eff FromParserPure a -> - Either Error (a, NameSuf, Definitions) -fromParserPure suf defs act = runSTErr $ do - suf <- liftST $ newSTRef suf - defs <- liftST $ newSTRef defs + NameSuf -> Definitions -> LevelStack -> + Eff FromParserPure a -> Either Error (PureParserResult a) +fromParserPure suf defs lvls act = runSTErr $ do + suf <- newSTRef' suf + defs <- newSTRef' defs + log <- newSTRef' [<] + lvls <- newSTRef' lvls res <- runEff act $ with Union.(::) - [handleExcept (\e => stLeft e), + [handleExcept $ \e => stLeft e, handleStateSTRef defs, - handleStateSTRef !(liftST $ newSTRef ns), - handleStateSTRef suf] - pure (res, !(liftST $ readSTRef suf), !(liftST $ readSTRef defs)) - - -export covering -fromParserIO : (MonadRec io, HasIO io) => - IncludePath -> IORef SeenSet -> - IORef NameSuf -> IORef Definitions -> - Eff FromParserIO a -> io (Either Error a) -fromParserIO inc seen suf defs act = - liftIO $ fromIOErr $ runEff act $ with Union.(::) - [handleExcept (\e => ioLeft e), - handleStateIORef defs, - handleStateIORef !(newIORef [<]), - handleStateIORef suf, - handleLoadFileIOE LoadError WrapParseError seen inc] + handleStateSTRef !(newSTRef' ns), + handleStateSTRef suf, + handleLogST log lvls] + pure $ MkPureParserResult { + val = res, + suf = !(readSTRef' suf), + defs = !(readSTRef' defs), + log = !(readSTRef' log), + logLevels = !(readSTRef' lvls) + } parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a) @@ -370,8 +373,9 @@ data HasFail = NoFail | AnyFail | FailWith String export covering expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error -expectFail loc act = - case fromParserPure !(getAt GEN) !(getAt DEFS) {ns = !(getAt NS)} act of +expectFail loc act = do + gen <- getAt GEN; defs <- getAt DEFS; ns <- getAt NS; lvl <- curLevels + case fromParserPure {ns} gen defs (singleton lvl) act of Left err => pure err Right _ => throw $ ExpectedFail loc diff --git a/tests/Tests/FromPTerm.idr b/tests/Tests/FromPTerm.idr index b7bbf6e..319d407 100644 --- a/tests/Tests/FromPTerm.idr +++ b/tests/Tests/FromPTerm.idr @@ -68,7 +68,7 @@ parameters {c : Bool} {auto _ : Show b} runFromParser : {default empty defs : Definitions} -> Eff FromParserPure a -> Either FromParser.Error a -runFromParser = map fst . fromParserPure 0 defs +runFromParser = map val . fromParserPure 0 defs initStack export tests : Test From 3b6ae36e4eb1d8f1e370b7c9f1b72d964eebfbc8 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 4 Apr 2024 19:23:08 +0200 Subject: [PATCH 101/133] add logging to core --- exe/CompileMonad.idr | 3 +- lib/Quox/Equal.idr | 195 +++++++++++++++++++++++------- lib/Quox/Parser/FromParser.idr | 1 + lib/Quox/Syntax/DimEq.idr | 9 +- lib/Quox/Typechecker.idr | 40 +++++- lib/Quox/Typing.idr | 49 +++++--- lib/Quox/Typing/Context.idr | 15 ++- lib/Quox/Untyped/Erase.idr | 2 +- lib/Quox/Whnf/ComputeElimType.idr | 36 +++++- lib/Quox/Whnf/Interface.idr | 16 ++- lib/Quox/Whnf/Main.idr | 109 ++++++++++------- tests/Tests/DimEq.idr | 2 +- tests/Tests/Reduce.idr | 3 +- tests/TypingImpls.idr | 5 +- 14 files changed, 353 insertions(+), 132 deletions(-) diff --git a/exe/CompileMonad.idr b/exe/CompileMonad.idr index 3f20fc7..9bdc28a 100644 --- a/exe/CompileMonad.idr +++ b/exe/CompileMonad.idr @@ -146,7 +146,8 @@ liftErase : Q.Definitions -> Eff Erase a -> Eff Compile a liftErase defs act = runEff act [handleExcept $ \err => throw $ EraseError err, - handleStateIORef !(asksAt STATE suf)] + handleStateIORef !(asksAt STATE suf), + \g => send g] export %inline liftScheme : Eff Scheme a -> Eff Compile (a, List Id) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 83748af..796b6ff 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -2,9 +2,12 @@ module Quox.Equal import Quox.BoolExtra import public Quox.Typing -import Data.Maybe -import Quox.EffExtra import Quox.FreeVars +import Quox.Pretty +import Quox.EffExtra + +import Data.List1 +import Data.Maybe %default total @@ -15,11 +18,11 @@ EqModeState = State EqMode public export Equal : List (Type -> Type) -Equal = [ErrorEff, DefsReader, NameGen] +Equal = [ErrorEff, DefsReader, NameGen, Log] public export EqualInner : List (Type -> Type) -EqualInner = [ErrorEff, NameGen, EqModeState] +EqualInner = [ErrorEff, NameGen, EqModeState, Log] export %inline @@ -74,9 +77,25 @@ sameTyCon (E {}) _ = False ||| * `[π.A]` is empty if `A` is. ||| * that's it. public export covering -isEmpty : Definitions -> EqContext n -> SQty -> Term 0 n -> - Eff EqualInner Bool -isEmpty defs ctx sg ty0 = do +isEmpty : + {default 30 logLevel : Nat} -> (0 _ : So (isLogLevel logLevel)) => + Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool + +private covering +isEmptyNoLog : + Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool + +isEmpty defs ctx sg ty = do + sayMany "equal" ty.loc + [logLevel :> "isEmpty", + 95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx], + 95 :> hsep ["sg =", runPretty $ prettyQty sg.qty], + logLevel :> hsep ["ty =", runPretty $ prettyTerm [<] ctx.tnames ty]] + res <- isEmptyNoLog defs ctx sg ty + say "equal" logLevel ty.loc $ hsep ["isEmpty ⇝", pshow res] + pure res + +isEmptyNoLog defs ctx sg ty0 = do Element ty0 nc <- whnf defs ctx sg ty0.loc ty0 let Left y = choose $ isTyConE ty0 | Right n => pure False @@ -85,16 +104,17 @@ isEmpty defs ctx sg ty0 = do IOState {} => pure False Pi {arg, res, _} => pure False Sig {fst, snd, _} => - isEmpty defs ctx sg fst `orM` - isEmpty defs (extendTy0 snd.name fst ctx) sg snd.term + isEmpty defs ctx sg fst {logLevel = 90} `orM` + isEmpty defs (extendTy0 snd.name fst ctx) sg snd.term {logLevel = 90} Enum {cases, _} => pure $ null cases Eq {} => pure False NAT {} => pure False STRING {} => pure False - BOX {ty, _} => isEmpty defs ctx sg ty + BOX {ty, _} => isEmpty defs ctx sg ty {logLevel = 90} E _ => pure False + ||| true if a type is known to be a subsingleton purely by its form. ||| a subsingleton is a type with only zero or one possible values. ||| equality/subtyping accepts immediately on values of subsingleton types. @@ -106,27 +126,42 @@ isEmpty defs ctx sg ty0 = do ||| * an enum type is a subsingleton if it has zero or one tags. ||| * a box type is a subsingleton if its content is public export covering -isSubSing : Definitions -> EqContext n -> SQty -> Term 0 n -> - Eff EqualInner Bool -isSubSing defs ctx sg ty0 = do +isSubSing : + {default 30 logLevel : Nat} -> (0 _ : So (isLogLevel logLevel)) => + Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool + +private covering +isSubSingNoLog : + Definitions -> EqContext n -> SQty -> Term 0 n -> Eff EqualInner Bool + +isSubSing defs ctx sg ty = do + sayMany "equal" ty.loc + [logLevel :> "isSubSing", + 95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx], + 95 :> hsep ["sg =", runPretty $ prettyQty sg.qty], + logLevel :> hsep ["ty =", runPretty $ prettyTerm [<] ctx.tnames ty]] + res <- isSubSingNoLog defs ctx sg ty + say "equal" logLevel ty.loc $ hsep ["isSubsing ⇝", pshow res] + pure res + +isSubSingNoLog defs ctx sg ty0 = do Element ty0 nc <- whnf defs ctx sg ty0.loc ty0 - let Left y = choose $ isTyConE ty0 - | Right n => pure False + let Left y = choose $ isTyConE ty0 | _ => pure False case ty0 of TYPE {} => pure False IOState {} => pure False Pi {arg, res, _} => - isEmpty defs ctx sg arg `orM` - isSubSing defs (extendTy0 res.name arg ctx) sg res.term + isEmpty defs ctx sg arg {logLevel = 90} `orM` + isSubSing defs (extendTy0 res.name arg ctx) sg res.term {logLevel = 90} Sig {fst, snd, _} => - isSubSing defs ctx sg fst `andM` - isSubSing defs (extendTy0 snd.name fst ctx) sg snd.term + isSubSing defs ctx sg fst {logLevel = 90} `andM` + isSubSing defs (extendTy0 snd.name fst ctx) sg snd.term {logLevel = 90} Enum {cases, _} => pure $ length (SortedSet.toList cases) <= 1 Eq {} => pure True NAT {} => pure False STRING {} => pure False - BOX {ty, _} => isSubSing defs ctx sg ty + BOX {ty, _} => isSubSing defs ctx sg ty {logLevel = 90} E _ => pure False @@ -137,12 +172,21 @@ bigger l r = gets $ \case Super => l; _ => r export -ensureTyCon : Has ErrorEff fs => - (loc : Loc) -> (ctx : EqContext n) -> (t : Term 0 n) -> - Eff fs (So (isTyConE t)) -ensureTyCon loc ctx t = case nchoose $ isTyConE t of - Left y => pure y - Right n => throw $ NotType loc (toTyContext ctx) (t // shift0 ctx.dimLen) +ensureTyCon, ensureTyConNoLog : + (Has Log fs, Has ErrorEff fs) => + (loc : Loc) -> (ctx : EqContext n) -> (t : Term 0 n) -> + Eff fs (So (isTyConE t)) +ensureTyConNoLog loc ctx ty = do + case nchoose $ isTyConE ty of + Left y => pure y + Right n => throw $ NotType loc (toTyContext ctx) (ty // shift0 ctx.dimLen) + +ensureTyCon loc ctx ty = do + sayMany "equal" ty.loc + [60 :> "ensureTyCon", + 95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx], + 60 :> hsep ["ty =", runPretty $ prettyTerm [<] ctx.tnames ty]] + ensureTyConNoLog loc ctx ty namespace Term @@ -750,7 +794,11 @@ namespace Elim namespace Term - compare0 defs ctx sg ty s t = + export covering %inline + compare0NoLog : + Definitions -> EqContext n -> SQty -> (ty, s, t : Term 0 n) -> + Eff EqualInner () + compare0NoLog defs ctx sg ty s t = wrapErr (WhileComparingT ctx !mode sg ty s t) $ do Element ty' _ <- whnf defs ctx SZero ty.loc ty Element s' _ <- whnf defs ctx sg s.loc s @@ -758,20 +806,72 @@ namespace Term tty <- ensureTyCon ty.loc ctx ty' compare0' defs ctx sg ty' s' t' + compare0 defs ctx sg ty s t = do + sayMany "equal" s.loc + [30 :> "Term.compare0", + 30 :> hsep ["mode =", pshow !mode], + 95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx], + 95 :> hsep ["sg =", runPretty $ prettyQty sg.qty], + 31 :> hsep ["ty =", runPretty $ prettyTerm [<] ctx.tnames ty], + 30 :> hsep ["s =", runPretty $ prettyTerm [<] ctx.tnames s], + 30 :> hsep ["t =", runPretty $ prettyTerm [<] ctx.tnames t]] + compare0NoLog defs ctx sg ty s t + namespace Elim - compare0 defs ctx sg e f = do + export covering %inline + compare0NoLog : + Definitions -> EqContext n -> SQty -> (e, f : Elim 0 n) -> + Eff EqualInner (Term 0 n) + compare0NoLog defs ctx sg e f = do (ty, err) <- runStateAt InnerErr Nothing $ compare0Inner defs ctx sg e f maybe (pure ty) throw err -compareType defs ctx s t = do + compare0 defs ctx sg e f = do + sayMany "equal" e.loc + [30 :> "Elim.compare0", + 30 :> hsep ["mode =", pshow !mode], + 95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx], + 95 :> hsep ["sg =", runPretty $ prettyQty sg.qty], + 30 :> hsep ["e =", runPretty $ prettyElim [<] ctx.tnames e], + 30 :> hsep ["f =", runPretty $ prettyElim [<] ctx.tnames f]] + ty <- compare0NoLog defs ctx sg e f + say "equal" 31 e.loc $ + hsep ["Elim.compare0 ⇝", runPretty $ prettyTerm [<] ctx.tnames ty] + pure ty + +export covering %inline +compareTypeNoLog : + Definitions -> EqContext n -> (s, t : Term 0 n) -> Eff EqualInner () +compareTypeNoLog defs ctx s t = do Element s' _ <- whnf defs ctx SZero s.loc s Element t' _ <- whnf defs ctx SZero t.loc t ts <- ensureTyCon s.loc ctx s' tt <- ensureTyCon t.loc ctx t' - st <- either pure (const $ clashTy s.loc ctx s' t') $ - nchoose $ sameTyCon s' t' + let Left _ = choose $ sameTyCon s' t' | _ => clashTy s.loc ctx s' t' compareType' defs ctx s' t' +compareType defs ctx s t = do + sayMany "equal" s.loc + [30 :> "compareType", + 30 :> hsep ["mode =", pshow !mode], + 95 :> hsep ["ctx =", runPretty $ prettyEqContext ctx], + 30 :> hsep ["s =", runPretty $ prettyTerm [<] ctx.tnames s], + 30 :> hsep ["t =", runPretty $ prettyTerm [<] ctx.tnames t]] + compareTypeNoLog defs ctx s t + + +private +getVars : TyContext d _ -> FreeVars d -> List BindName +getVars ctx (FV fvs) = case ctx.dctx of + ZeroIsOne => [] + C eqs => toList $ getVars' ctx.dnames eqs fvs +where + getVars' : BContext d' -> DimEq' d' -> FreeVars' d' -> SnocList BindName + getVars' (names :< name) (eqs :< eq) (fvs :< fv) = + let rest = getVars' names eqs fvs in + case eq of Nothing => rest :< name + Just _ => rest + getVars' [<] [<] [<] = [<] parameters (loc : Loc) (ctx : TyContext d n) parameters (mode : EqMode) @@ -780,9 +880,11 @@ parameters (loc : Loc) (ctx : TyContext d n) fromInner = lift . map fst . runState mode private - eachFace : Applicative f => FreeVars d -> - (EqContext n -> DSubst d 0 -> f ()) -> f () - eachFace fvs act = + eachCorner : Has Log fs => Loc -> FreeVars d -> + (EqContext n -> DSubst d 0 -> Eff fs ()) -> Eff fs () + eachCorner loc fvs act = do + say "equal" 50 loc $ + hsep $ "eachCorner: split on" :: map prettyBind' (getVars ctx fvs) for_ (splits loc ctx.dctx fvs) $ \th => act (makeEqContext ctx th) th @@ -792,31 +894,36 @@ parameters (loc : Loc) (ctx : TyContext d n) Definitions -> EqContext n -> DSubst d 0 -> Eff EqualInner () private - runCompare : FreeVars d -> CompareAction d n -> Eff Equal () - runCompare fvs act = fromInner $ eachFace fvs $ act !(askAt DEFS) + runCompare : Loc -> FreeVars d -> CompareAction d n -> Eff Equal () + runCompare loc fvs act = fromInner $ eachCorner loc fvs $ act !(askAt DEFS) private - fdvAll : HasFreeDVars t => List (t d n) -> FreeVars d - fdvAll = let Val d = ctx.dimLen in foldMap (fdvWith [|d|] ctx.termLen) + foldMap1 : Semigroup b => (a -> b) -> List1 a -> b + foldMap1 f = foldl1By (\x, y => x <+> f y) f + + private + fdvAll : HasFreeDVars t => (xs : List (t d n)) -> (0 _ : NonEmpty xs) => + FreeVars d + fdvAll (x :: xs) = foldMap1 (fdvWith ctx.dimLen ctx.termLen) (x ::: xs) namespace Term export covering compare : SQty -> (ty, s, t : Term d n) -> Eff Equal () - compare sg ty s t = runCompare (fdvAll [ty, s, t]) $ \defs, ectx, th => - compare0 defs ectx sg (ty // th) (s // th) (t // th) + compare sg ty s t = runCompare s.loc (fdvAll [ty, s, t]) $ + \defs, ectx, th => compare0 defs ectx sg (ty // th) (s // th) (t // th) export covering compareType : (s, t : Term d n) -> Eff Equal () - compareType s t = runCompare (fdvAll [s, t]) $ \defs, ectx, th => - compareType defs ectx (s // th) (t // th) + compareType s t = runCompare s.loc (fdvAll [s, t]) $ + \defs, ectx, th => compareType defs ectx (s // th) (t // th) namespace Elim ||| you don't have to pass the type in but the arguments must still be ||| of the same type!! export covering compare : SQty -> (e, f : Elim d n) -> Eff Equal () - compare sg e f = runCompare (fdvAll [e, f]) $ \defs, ectx, th => - ignore $ compare0 defs ectx sg (e // th) (f // th) + compare sg e f = runCompare e.loc (fdvAll [e, f]) $ + \defs, ectx, th => ignore $ compare0 defs ectx sg (e // th) (f // th) namespace Term export covering %inline diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index b49976d..8328272 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -331,6 +331,7 @@ liftTC : Eff TC a -> Eff FromParserPure a liftTC tc = runEff tc $ with Union.(::) [handleExcept $ \e => throw $ WrapTypeError e, handleReaderConst !(getAt DEFS), + \g => send g, \g => send g] private diff --git a/lib/Quox/Syntax/DimEq.idr b/lib/Quox/Syntax/DimEq.idr index 020b947..a224641 100644 --- a/lib/Quox/Syntax/DimEq.idr +++ b/lib/Quox/Syntax/DimEq.idr @@ -59,10 +59,15 @@ Traversable (IfConsistent eqs) where traverse f Nothing = pure Nothing traverse f (Just x) = Just <$> f x +public export +ifConsistentElse : Applicative f => (eqs : DimEq d) -> + f a -> f () -> f (IfConsistent eqs a) +ifConsistentElse ZeroIsOne yes no = Nothing <$ no +ifConsistentElse (C _) yes no = Just <$> yes + public export ifConsistent : Applicative f => (eqs : DimEq d) -> f a -> f (IfConsistent eqs a) -ifConsistent ZeroIsOne act = pure Nothing -ifConsistent (C _) act = Just <$> act +ifConsistent eqs act = ifConsistentElse eqs act (pure ()) public export toMaybe : IfConsistent eqs a -> Maybe a diff --git a/lib/Quox/Typechecker.idr b/lib/Quox/Typechecker.idr index 681aa7c..3892b27 100644 --- a/lib/Quox/Typechecker.idr +++ b/lib/Quox/Typechecker.idr @@ -3,6 +3,7 @@ module Quox.Typechecker import public Quox.Typing import public Quox.Equal import Quox.Displace +import Quox.Pretty import Data.List import Data.SnocVect @@ -14,7 +15,7 @@ import Quox.EffExtra public export 0 TC : List (Type -> Type) -TC = [ErrorEff, DefsReader, NameGen] +TC = [ErrorEff, DefsReader, NameGen, Log] parameters (loc : Loc) @@ -41,6 +42,24 @@ lubs ctx [] = zeroFor ctx lubs ctx (x :: xs) = lubs1 $ x ::: xs +private +prettyTermTC : {opts : LayoutOpts} -> + TyContext d n -> Term d n -> Eff Pretty (Doc opts) +prettyTermTC ctx s = prettyTerm ctx.dnames ctx.tnames s + + +private +checkLogs : String -> TyContext d n -> SQty -> + Term d n -> Maybe (Term d n) -> Eff TC () +checkLogs fun ctx sg subj ty = do + let tyDoc = delay $ maybe (text "none") (runPretty . prettyTermTC ctx) ty + sayMany "check" subj.loc + [10 :> text fun, + 95 :> hsep ["ctx =", runPretty $ prettyTyContext ctx], + 95 :> hsep ["sg =", runPretty $ prettyQty sg.qty], + 10 :> hsep ["subj =", runPretty $ prettyTermTC ctx subj], + 10 :> hsep ["ty =", tyDoc]] + mutual ||| "Ψ | Γ ⊢ σ · s ⇐ A ⊳ Σ" ||| @@ -53,7 +72,11 @@ mutual export covering %inline check : (ctx : TyContext d n) -> SQty -> Term d n -> Term d n -> Eff TC (CheckResult ctx.dctx n) - check ctx sg subj ty = ifConsistent ctx.dctx $ checkC ctx sg subj ty + check ctx sg subj ty = + ifConsistentElse ctx.dctx + (do checkLogs "check" ctx sg subj (Just ty) + checkC ctx sg subj ty) + (say "check" 20 subj.loc "check: 0=1") ||| "Ψ | Γ ⊢₀ s ⇐ A" ||| @@ -84,7 +107,12 @@ mutual ||| universe doesn't matter, only that a term is _a_ type, so it is optional. export covering %inline checkType : TyContext d n -> Term d n -> Maybe Universe -> Eff TC () - checkType ctx subj l = ignore $ ifConsistent ctx.dctx $ checkTypeC ctx subj l + checkType ctx subj l = do + let univ = TYPE <$> l <*> pure noLoc + ignore $ ifConsistentElse ctx.dctx + (do checkLogs "checkType" ctx SZero subj univ + checkTypeC ctx subj l) + (say "check" 20 subj.loc "checkType: 0=1") export covering %inline checkTypeC : TyContext d n -> Term d n -> Maybe Universe -> Eff TC () @@ -107,7 +135,11 @@ mutual export covering %inline infer : (ctx : TyContext d n) -> SQty -> Elim d n -> Eff TC (InferResult ctx.dctx d n) - infer ctx sg subj = ifConsistent ctx.dctx $ inferC ctx sg subj + infer ctx sg subj = do + ifConsistentElse ctx.dctx + (do checkLogs "infer" ctx sg (E subj) Nothing + inferC ctx sg subj) + (say "check" 20 subj.loc "infer: 0=1") ||| `infer`, assuming the dimension context is consistent export covering %inline diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index 46238b4..4b92a17 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -7,6 +7,7 @@ import public Quox.Typing.Error as Typing import public Quox.Syntax import public Quox.Definition import public Quox.Whnf +import public Quox.Pretty import Language.Reflection import Control.Eff @@ -46,16 +47,15 @@ lookupFree x loc defs = maybe (throw $ NotInScope loc x) pure $ lookup x defs public export substCasePairRet : BContext 2 -> Term d n -> ScopeTerm d n -> Term d (2 + n) substCasePairRet [< x, y] dty retty = - let tm = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc - arg = Ann tm (dty // fromNat 2) tm.loc - in + let tm = Pair (BVT 1 x.loc) (BVT 0 y.loc) $ x.loc `extendL` y.loc + arg = Ann tm (dty // fromNat 2) tm.loc in retty.term // (arg ::: shift 2) public export substCaseSuccRet : BContext 2 -> ScopeTerm d n -> Term d (2 + n) substCaseSuccRet [< p, ih] retty = - let arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT p.loc) $ p.loc `extendL` ih.loc - in + let loc = p.loc `extendL` ih.loc + arg = Ann (Succ (BVT 1 p.loc) p.loc) (NAT p.loc) loc in retty.term // (arg ::: shift 2) public export @@ -65,23 +65,31 @@ substCaseBoxRet x dty retty = retty.term // (arg ::: shift 1) -parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} +private +0 ExpectErrorConstructor : Type +ExpectErrorConstructor = + forall d, n. Loc -> NameContexts d n -> Term d n -> Error + +parameters (defs : Definitions) + {auto _ : (Has ErrorEff fs, Has NameGen fs, Has Log fs)} namespace TyContext parameters (ctx : TyContext d n) (sg : SQty) (loc : Loc) export covering whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => - tm d n -> Eff fs (NonRedex tm d n defs ? sg) + tm d n -> Eff fs (NonRedex tm d n defs (toWhnfContext ctx) sg) whnf tm = do let Val n = ctx.termLen; Val d = ctx.dimLen res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm rethrow res private covering %macro - expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) -> - TTImp -> TTImp -> Elab (Term d n -> Eff fs a) - expect k l r = do - f <- check `(\case ~(l) => Just ~(r); _ => Nothing) - pure $ \t => maybe (throw $ k loc ctx.names t) pure . f . fst =<< whnf t + expect : ExpectErrorConstructor -> TTImp -> TTImp -> + Elab (Term d n -> Eff fs a) + expect err pat rhs = Prelude.do + match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing) + pure $ \term => do + res <- whnf term + maybe (throw $ err loc ctx.names term) pure $ match $ fst res export covering %inline expectTYPE : Term d n -> Eff fs Universe @@ -120,19 +128,20 @@ parameters (defs : Definitions) {auto _ : (Has ErrorEff fs, Has NameGen fs)} parameters (ctx : EqContext n) (sg : SQty) (loc : Loc) export covering whnf : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => - tm 0 n -> Eff fs (NonRedex tm 0 n defs ? sg) + tm 0 n -> Eff fs (NonRedex tm 0 n defs (toWhnfContext ctx) sg) whnf tm = do res <- lift $ runExcept $ whnf defs (toWhnfContext ctx) sg tm rethrow res private covering %macro - expect : (forall d, n. Loc -> NameContexts d n -> Term d n -> Error) -> - TTImp -> TTImp -> Elab (Term 0 n -> Eff fs a) - expect k l r = do - f <- check `(\case ~(l) => Just ~(r); _ => Nothing) - pure $ \t => - let err = throw $ k loc ctx.names (t // shift0 ctx.dimLen) in - maybe err pure . f . fst =<< whnf t + expect : ExpectErrorConstructor -> TTImp -> TTImp -> + Elab (Term 0 n -> Eff fs a) + expect err pat rhs = do + match <- check `(\case ~(pat) => Just ~(rhs); _ => Nothing) + pure $ \term => do + res <- whnf term + let t0 = delay $ term // shift0 ctx.dimLen + maybe (throw $ err loc ctx.names t0) pure $ match $ fst res export covering %inline expectTYPE : Term 0 n -> Eff fs Universe diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index 7b10046..fe8322c 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -339,9 +339,10 @@ namespace WhnfContext private prettyTContextElt : {opts : _} -> BContext d -> BContext n -> - Qty -> BindName -> LocalVar d n -> Eff Pretty (Doc opts) + Doc opts -> BindName -> LocalVar d n -> + Eff Pretty (Doc opts) prettyTContextElt dnames tnames q x s = do - q <- prettyQty q; dot <- dotD + dot <- dotD x <- prettyTBind x; colon <- colonD ty <- withPrec Outer $ prettyTerm dnames tnames s.type; eq <- cstD tm <- traverse (withPrec Outer . prettyTerm dnames tnames) s.term @@ -356,7 +357,7 @@ prettyTContextElt dnames tnames q x s = do private prettyTContext' : {opts : _} -> - BContext d -> QContext n -> BContext n -> + BContext d -> Context' (Doc opts) n -> BContext n -> TContext d n -> Eff Pretty (SnocList (Doc opts)) prettyTContext' _ [<] [<] [<] = pure [<] prettyTContext' dnames (qtys :< q) (tnames :< x) (tys :< t) = @@ -369,6 +370,7 @@ prettyTContext : {opts : _} -> TContext d n -> Eff Pretty (Doc opts) prettyTContext dnames qtys tnames tys = do comma <- commaD + qtys <- traverse prettyQty qtys sepSingle . exceptLast (<+> comma) . toList <$> prettyTContext' dnames qtys tnames tys @@ -384,3 +386,10 @@ prettyTyContext (MkTyContext dctx dnames tctx tnames qtys) = export prettyEqContext : {opts : _} -> EqContext n -> Eff Pretty (Doc opts) prettyEqContext ctx = prettyTyContext $ toTyContext ctx + +export +prettyWhnfContext : {opts : _} -> WhnfContext d n -> Eff Pretty (Doc opts) +prettyWhnfContext ctx = + let Val n = ctx.termLen in + separateTight !commaD <$> + prettyTContext' ctx.dnames (replicate n "_") ctx.tnames ctx.tctx diff --git a/lib/Quox/Untyped/Erase.idr b/lib/Quox/Untyped/Erase.idr index 34a1206..54062b4 100644 --- a/lib/Quox/Untyped/Erase.idr +++ b/lib/Quox/Untyped/Erase.idr @@ -88,7 +88,7 @@ parameters {opts : LayoutOpts} (showContext : Bool) public export Erase : List (Type -> Type) -Erase = [Except Error, NameGen] +Erase = [Except Error, NameGen, Log] export liftWhnf : Eff Whnf a -> Eff Erase a diff --git a/lib/Quox/Whnf/ComputeElimType.idr b/lib/Quox/Whnf/ComputeElimType.idr index 87891ff..3661c12 100644 --- a/lib/Quox/Whnf/ComputeElimType.idr +++ b/lib/Quox/Whnf/ComputeElimType.idr @@ -2,6 +2,7 @@ module Quox.Whnf.ComputeElimType import Quox.Whnf.Interface import Quox.Displace +import Quox.Pretty %default total @@ -18,7 +19,6 @@ computeElimType : (e : Elim d n) -> (0 ne : No (isRedexE defs ctx sg e)) => Eff Whnf (Term d n) - ||| computes a type and then reduces it to whnf export covering computeWhnfElimType0 : @@ -28,7 +28,16 @@ computeWhnfElimType0 : (e : Elim d n) -> (0 ne : No (isRedexE defs ctx sg e)) => Eff Whnf (Term d n) -computeElimType defs ctx sg e = + +private covering +computeElimTypeNoLog, computeWhnfElimType0NoLog : + CanWhnf Term Interface.isRedexT => + CanWhnf Elim Interface.isRedexE => + (defs : Definitions) -> WhnfContext d n -> (0 sg : SQty) -> + (e : Elim d n) -> (0 ne : No (isRedexE defs ctx sg e)) => + Eff Whnf (Term d n) + +computeElimTypeNoLog defs ctx sg e = case e of F x u loc => do let Just def = lookup x defs @@ -39,7 +48,7 @@ computeElimType defs ctx sg e = pure (ctx.tctx !! i).type App f s loc => - case !(computeWhnfElimType0 defs ctx sg f {ne = noOr1 ne}) of + case !(computeWhnfElimType0NoLog defs ctx sg f {ne = noOr1 ne}) of Pi {arg, res, _} => pure $ sub1 res $ Ann s arg loc ty => throw $ ExpectedPi loc ctx.names ty @@ -47,12 +56,12 @@ computeElimType defs ctx sg e = pure $ sub1 ret pair Fst pair loc => - case !(computeWhnfElimType0 defs ctx sg pair {ne = noOr1 ne}) of + case !(computeWhnfElimType0NoLog defs ctx sg pair {ne = noOr1 ne}) of Sig {fst, _} => pure fst ty => throw $ ExpectedSig loc ctx.names ty Snd pair loc => - case !(computeWhnfElimType0 defs ctx sg pair {ne = noOr1 ne}) of + case !(computeWhnfElimType0NoLog defs ctx sg pair {ne = noOr1 ne}) of Sig {snd, _} => pure $ sub1 snd $ Fst pair loc ty => throw $ ExpectedSig loc ctx.names ty @@ -66,7 +75,7 @@ computeElimType defs ctx sg e = pure $ sub1 ret box DApp {fun = f, arg = p, loc} => - case !(computeWhnfElimType0 defs ctx sg f {ne = noOr1 ne}) of + case !(computeWhnfElimType0NoLog defs ctx sg f {ne = noOr1 ne}) of Eq {ty, _} => pure $ dsub1 ty p t => throw $ ExpectedEq loc ctx.names t @@ -82,5 +91,20 @@ computeElimType defs ctx sg e = TypeCase {ret, _} => pure ret +computeElimType defs ctx sg e {ne} = do + let Val n = ctx.termLen + sayMany "whnf" e.loc + [90 :> "computeElimType", + 95 :> hsep ["ctx =", runPretty $ prettyWhnfContext ctx], + 90 :> hsep ["e =", runPretty $ prettyElim ctx.dnames ctx.tnames e]] + res <- computeElimTypeNoLog defs ctx sg e {ne} + say "whnf" 91 e.loc $ + hsep ["computeElimType ⇝", + runPretty $ prettyTerm ctx.dnames ctx.tnames res] + pure res + computeWhnfElimType0 defs ctx sg e = computeElimType defs ctx sg e >>= whnf0 defs ctx SZero + +computeWhnfElimType0NoLog defs ctx sg e {ne} = + computeElimTypeNoLog defs ctx sg e {ne} >>= whnf0 defs ctx SZero diff --git a/lib/Quox/Whnf/Interface.idr b/lib/Quox/Whnf/Interface.idr index 1fccefc..e516f62 100644 --- a/lib/Quox/Whnf/Interface.idr +++ b/lib/Quox/Whnf/Interface.idr @@ -1,6 +1,7 @@ module Quox.Whnf.Interface import public Quox.No +import public Quox.Log import public Quox.Syntax import public Quox.Definition import public Quox.Typing.Context @@ -13,7 +14,7 @@ import public Control.Eff public export Whnf : List (Type -> Type) -Whnf = [Except Error, NameGen] +Whnf = [Except Error, NameGen, Log] public export @@ -24,17 +25,20 @@ RedexTest tm = public export interface CanWhnf (0 tm : TermLike) (0 isRedex : RedexTest tm) | tm where - whnf : (defs : Definitions) -> (ctx : WhnfContext d n) -> (q : SQty) -> - tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs ctx q)) + whnf, whnfNoLog : + (defs : Definitions) -> (ctx : WhnfContext d n) -> (q : SQty) -> + tm d n -> Eff Whnf (Subset (tm d n) (No . isRedex defs ctx q)) -- having isRedex be part of the class header, and needing to be explicitly -- quantified on every use since idris can't infer its type, is a little ugly. -- but none of the alternatives i've thought of so far work. e.g. in some -- cases idris can't tell that `isRedex` and `isRedexT` are the same thing public export %inline -whnf0 : {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => - Definitions -> WhnfContext d n -> SQty -> tm d n -> Eff Whnf (tm d n) -whnf0 defs ctx q t = fst <$> whnf defs ctx q t +whnf0, whnfNoLog0 : + {0 isRedex : RedexTest tm} -> CanWhnf tm isRedex => + Definitions -> WhnfContext d n -> SQty -> tm d n -> Eff Whnf (tm d n) +whnf0 defs ctx q t = fst <$> whnf defs ctx q t +whnfNoLog0 defs ctx q t = fst <$> whnfNoLog defs ctx q t public export 0 IsRedex, NotRedex : {isRedex : RedexTest tm} -> CanWhnf tm isRedex => diff --git a/lib/Quox/Whnf/Main.idr b/lib/Quox/Whnf/Main.idr index 75a1248..1c3bcc4 100644 --- a/lib/Quox/Whnf/Main.idr +++ b/lib/Quox/Whnf/Main.idr @@ -4,6 +4,7 @@ import Quox.Whnf.Interface import Quox.Whnf.ComputeElimType import Quox.Whnf.TypeCase import Quox.Whnf.Coercion +import Quox.Pretty import Quox.Displace import Data.SnocVect @@ -14,19 +15,43 @@ export covering CanWhnf Term Interface.isRedexT export covering CanWhnf Elim Interface.isRedexE +-- the String is what to call the "s" argument in logs (maybe "s", or "e") +private %inline +whnfDefault : + {0 isRedex : RedexTest tm} -> + (CanWhnf tm isRedex, Located2 tm) => + String -> + (forall d, n. WhnfContext d n -> tm d n -> Eff Pretty LogDoc) -> + (defs : Definitions) -> + (ctx : WhnfContext d n) -> + (sg : SQty) -> + (s : tm d n) -> + Eff Whnf (Subset (tm d n) (No . isRedex defs ctx sg)) +whnfDefault name ppr defs ctx sg s = do + sayMany "whnf" s.loc + [10 :> "whnf", + 95 :> hsep ["ctx =", runPretty $ prettyWhnfContext ctx], + 95 :> hsep ["sg =", runPretty $ prettyQty sg.qty], + 10 :> hsep [text name, "=", runPretty $ ppr ctx s]] + res <- whnfNoLog defs ctx sg s + say "whnf" 11 s.loc $ hsep ["whnf ⇝", runPretty $ ppr ctx res.fst] + pure res + covering CanWhnf Elim Interface.isRedexE where - whnf defs ctx sg (F x u loc) with (lookupElim0 x u defs) proof eq + whnf = whnfDefault "e" $ \ctx, e => prettyElim ctx.dnames ctx.tnames e + + whnfNoLog defs ctx sg (F x u loc) with (lookupElim0 x u defs) proof eq _ | Just y = whnf defs ctx sg $ setLoc loc $ injElim ctx y _ | Nothing = pure $ Element (F x u loc) $ rewrite eq in Ah - whnf defs ctx sg (B i loc) with (ctx.tctx !! i) proof eq1 + whnfNoLog defs ctx sg (B i loc) with (ctx.tctx !! i) proof eq1 _ | l with (l.term) proof eq2 _ | Just y = whnf defs ctx sg $ Ann y l.type loc _ | Nothing = pure $ Element (B i loc) $ rewrite eq1 in rewrite eq2 in Ah -- ((λ x ⇒ t) ∷ (π.x : A) → B) s ⇝ t[s∷A/x] ∷ B[s∷A/x] - whnf defs ctx sg (App f s appLoc) = do + whnfNoLog defs ctx sg (App f s appLoc) = do Element f fnf <- whnf defs ctx sg f case nchoose $ isLamHead f of Left _ => case f of @@ -41,7 +66,7 @@ CanWhnf Elim Interface.isRedexE where -- -- 0 · case e return p ⇒ C of { (a, b) ⇒ u } ⇝ -- u[fst e/a, snd e/b] ∷ C[e/p] - whnf defs ctx sg (CasePair pi pair ret body caseLoc) = do + whnfNoLog defs ctx sg (CasePair pi pair ret body caseLoc) = do Element pair pairnf <- whnf defs ctx sg pair case nchoose $ isPairHead pair of Left _ => case pair of @@ -64,7 +89,7 @@ CanWhnf Elim Interface.isRedexE where (pairnf `orNo` np `orNo` notYesNo n0) -- fst ((s, t) ∷ (x : A) × B) ⇝ s ∷ A - whnf defs ctx sg (Fst pair fstLoc) = do + whnfNoLog defs ctx sg (Fst pair fstLoc) = do Element pair pairnf <- whnf defs ctx sg pair case nchoose $ isPairHead pair of Left _ => case pair of @@ -76,7 +101,7 @@ CanWhnf Elim Interface.isRedexE where pure $ Element (Fst pair fstLoc) (pairnf `orNo` np) -- snd ((s, t) ∷ (x : A) × B) ⇝ t ∷ B[(s ∷ A)/x] - whnf defs ctx sg (Snd pair sndLoc) = do + whnfNoLog defs ctx sg (Snd pair sndLoc) = do Element pair pairnf <- whnf defs ctx sg pair case nchoose $ isPairHead pair of Left _ => case pair of @@ -89,7 +114,7 @@ CanWhnf Elim Interface.isRedexE where -- case 'a ∷ {a,…} return p ⇒ C of { 'a ⇒ u } ⇝ -- u ∷ C['a∷{a,…}/p] - whnf defs ctx sg (CaseEnum pi tag ret arms caseLoc) = do + whnfNoLog defs ctx sg (CaseEnum pi tag ret arms caseLoc) = do Element tag tagnf <- whnf defs ctx sg tag case nchoose $ isTagHead tag of Left _ => case tag of @@ -110,7 +135,7 @@ CanWhnf Elim Interface.isRedexE where -- -- case succ n ∷ ℕ return p ⇒ C of { succ n', π.ih ⇒ u; … } ⇝ -- u[n∷ℕ/n', (case n ∷ ℕ ⋯)/ih] ∷ C[succ n ∷ ℕ/p] - whnf defs ctx sg (CaseNat pi piIH nat ret zer suc caseLoc) = do + whnfNoLog defs ctx sg (CaseNat pi piIH nat ret zer suc caseLoc) = do Element nat natnf <- whnf defs ctx sg nat case nchoose $ isNatHead nat of Left _ => @@ -137,7 +162,7 @@ CanWhnf Elim Interface.isRedexE where -- case [t] ∷ [π.A] return p ⇒ C of { [x] ⇒ u } ⇝ -- u[t∷A/x] ∷ C[[t] ∷ [π.A]/p] - whnf defs ctx sg (CaseBox pi box ret body caseLoc) = do + whnfNoLog defs ctx sg (CaseBox pi box ret body caseLoc) = do Element box boxnf <- whnf defs ctx sg box case nchoose $ isBoxHead box of Left _ => case box of @@ -153,7 +178,7 @@ CanWhnf Elim Interface.isRedexE where -- e : Eq (𝑗 ⇒ A) t u ⊢ e @1 ⇝ u ∷ A‹1/𝑗› -- -- ((δ 𝑖 ⇒ s) ∷ Eq (𝑗 ⇒ A) t u) @𝑘 ⇝ s‹𝑘/𝑖› ∷ A‹𝑘/𝑗› - whnf defs ctx sg (DApp f p appLoc) = do + whnfNoLog defs ctx sg (DApp f p appLoc) = do Element f fnf <- whnf defs ctx sg f case nchoose $ isDLamHead f of Left _ => case f of @@ -173,7 +198,7 @@ CanWhnf Elim Interface.isRedexE where B {} => pure $ Element (DApp f p appLoc) (fnf `orNo` ndlh `orNo` Ah) -- e ∷ A ⇝ e - whnf defs ctx sg (Ann s a annLoc) = do + whnfNoLog defs ctx sg (Ann s a annLoc) = do Element s snf <- whnf defs ctx sg s case nchoose $ isE s of Left _ => let E e = s in pure $ Element e $ noOr2 snf @@ -181,7 +206,7 @@ CanWhnf Elim Interface.isRedexE where Element a anf <- whnf defs ctx SZero a pure $ Element (Ann s a annLoc) (ne `orNo` snf `orNo` anf) - whnf defs ctx sg (Coe sty p q val coeLoc) = + whnfNoLog defs ctx sg (Coe sty p q val coeLoc) = -- 𝑖 ∉ fv(A) -- ------------------------------- -- coe (𝑖 ⇒ A) @p @q s ⇝ s ∷ A @@ -201,7 +226,7 @@ CanWhnf Elim Interface.isRedexE where (_, Right ty) => whnf defs ctx sg $ Ann val ty coeLoc - whnf defs ctx sg (Comp ty p q val r zero one compLoc) = + whnfNoLog defs ctx sg (Comp ty p q val r zero one compLoc) = case p `decEqv` q of -- comp [A] @p @p s @r { ⋯ } ⇝ s ∷ A Yes y => whnf defs ctx sg $ Ann val ty compLoc @@ -213,7 +238,7 @@ CanWhnf Elim Interface.isRedexE where B {} => pure $ Element (Comp ty p q val r zero one compLoc) (notYesNo npq `orNo` Ah) - whnf defs ctx sg (TypeCase ty ret arms def tcLoc) = + whnfNoLog defs ctx sg (TypeCase ty ret arms def tcLoc) = case sg `decEq` SZero of Yes Refl => do Element ty tynf <- whnf defs ctx SZero ty @@ -226,48 +251,50 @@ CanWhnf Elim Interface.isRedexE where No _ => throw $ ClashQ tcLoc sg.qty Zero - whnf defs ctx sg (CloE (Sub el th)) = - whnf defs ctx sg $ pushSubstsWith' id th el - whnf defs ctx sg (DCloE (Sub el th)) = - whnf defs ctx sg $ pushSubstsWith' th id el + whnfNoLog defs ctx sg (CloE (Sub el th)) = + whnfNoLog defs ctx sg $ pushSubstsWith' id th el + whnfNoLog defs ctx sg (DCloE (Sub el th)) = + whnfNoLog defs ctx sg $ pushSubstsWith' th id el covering CanWhnf Term Interface.isRedexT where - whnf _ _ _ t@(TYPE {}) = pure $ nred t - whnf _ _ _ t@(IOState {}) = pure $ nred t - whnf _ _ _ t@(Pi {}) = pure $ nred t - whnf _ _ _ t@(Lam {}) = pure $ nred t - whnf _ _ _ t@(Sig {}) = pure $ nred t - whnf _ _ _ t@(Pair {}) = pure $ nred t - whnf _ _ _ t@(Enum {}) = pure $ nred t - whnf _ _ _ t@(Tag {}) = pure $ nred t - whnf _ _ _ t@(Eq {}) = pure $ nred t - whnf _ _ _ t@(DLam {}) = pure $ nred t - whnf _ _ _ t@(NAT {}) = pure $ nred t - whnf _ _ _ t@(Nat {}) = pure $ nred t - whnf _ _ _ t@(STRING {}) = pure $ nred t - whnf _ _ _ t@(Str {}) = pure $ nred t - whnf _ _ _ t@(BOX {}) = pure $ nred t - whnf _ _ _ t@(Box {}) = pure $ nred t + whnf = whnfDefault "e" $ \ctx, s => prettyTerm ctx.dnames ctx.tnames s - whnf _ _ _ (Succ p loc) = + whnfNoLog _ _ _ t@(TYPE {}) = pure $ nred t + whnfNoLog _ _ _ t@(IOState {}) = pure $ nred t + whnfNoLog _ _ _ t@(Pi {}) = pure $ nred t + whnfNoLog _ _ _ t@(Lam {}) = pure $ nred t + whnfNoLog _ _ _ t@(Sig {}) = pure $ nred t + whnfNoLog _ _ _ t@(Pair {}) = pure $ nred t + whnfNoLog _ _ _ t@(Enum {}) = pure $ nred t + whnfNoLog _ _ _ t@(Tag {}) = pure $ nred t + whnfNoLog _ _ _ t@(Eq {}) = pure $ nred t + whnfNoLog _ _ _ t@(DLam {}) = pure $ nred t + whnfNoLog _ _ _ t@(NAT {}) = pure $ nred t + whnfNoLog _ _ _ t@(Nat {}) = pure $ nred t + whnfNoLog _ _ _ t@(STRING {}) = pure $ nred t + whnfNoLog _ _ _ t@(Str {}) = pure $ nred t + whnfNoLog _ _ _ t@(BOX {}) = pure $ nred t + whnfNoLog _ _ _ t@(Box {}) = pure $ nred t + + whnfNoLog _ _ _ (Succ p loc) = case nchoose $ isNatConst p of Left _ => case p of Nat p _ => pure $ nred $ Nat (S p) loc E (Ann (Nat p _) _ _) => pure $ nred $ Nat (S p) loc Right nc => pure $ nred $ Succ p loc - whnf defs ctx sg (Let _ rhs body _) = + whnfNoLog defs ctx sg (Let _ rhs body _) = whnf defs ctx sg $ sub1 body rhs -- s ∷ A ⇝ s (in term context) - whnf defs ctx sg (E e) = do + whnfNoLog defs ctx sg (E e) = do Element e enf <- whnf defs ctx sg e case nchoose $ isAnn e of Left _ => let Ann {tm, _} = e in pure $ Element tm $ noOr1 $ noOr2 enf Right na => pure $ Element (E e) $ na `orNo` enf - whnf defs ctx sg (CloT (Sub tm th)) = - whnf defs ctx sg $ pushSubstsWith' id th tm - whnf defs ctx sg (DCloT (Sub tm th)) = - whnf defs ctx sg $ pushSubstsWith' th id tm + whnfNoLog defs ctx sg (CloT (Sub tm th)) = + whnfNoLog defs ctx sg $ pushSubstsWith' id th tm + whnfNoLog defs ctx sg (DCloT (Sub tm th)) = + whnfNoLog defs ctx sg $ pushSubstsWith' th id tm diff --git a/tests/Tests/DimEq.idr b/tests/Tests/DimEq.idr index f368991..c48729e 100644 --- a/tests/Tests/DimEq.idr +++ b/tests/Tests/DimEq.idr @@ -97,7 +97,7 @@ tests = "dimension constraints" :- [ testPrettyD iijj ZeroIsOne "𝑖, 𝑗, 0 = 1", testPrettyD [<] new "" {label = "[empty output from empty context]"}, testPrettyD ii new "𝑖", - testPrettyD iijj (fromGround [< "𝑖", "𝑗"] [< Zero, One]) + testPrettyD iijj (fromGround iijj [< Zero, One]) "𝑖, 𝑗, 𝑖 = 0, 𝑗 = 1", testPrettyD iijj (C [< Just (^K Zero), Nothing]) "𝑖, 𝑗, 𝑖 = 0", diff --git a/tests/Tests/Reduce.idr b/tests/Tests/Reduce.idr index 40c071e..f566f07 100644 --- a/tests/Tests/Reduce.idr +++ b/tests/Tests/Reduce.idr @@ -15,7 +15,8 @@ import Control.Eff runWhnf : Eff Whnf a -> Either Error a runWhnf act = runSTErr $ do runEff act [handleExcept (\e => stLeft e), - handleStateSTRef !(liftST $ newSTRef 0)] + handleStateSTRef !(liftST $ newSTRef 0), + handleLogDiscard] parameters {0 isRedex : RedexTest tm} {auto _ : CanWhnf tm isRedex} {d, n : Nat} {auto _ : (Eq (tm d n), Show (tm d n))} diff --git a/tests/TypingImpls.idr b/tests/TypingImpls.idr index 34c889a..80b2bbd 100644 --- a/tests/TypingImpls.idr +++ b/tests/TypingImpls.idr @@ -22,10 +22,11 @@ ToInfo Error where export runEqual : Definitions -> Eff Equal a -> Either Error a runEqual defs act = runSTErr $ do - runEff act + runEff act $ with Union.(::) [handleExcept (\e => stLeft e), handleReaderConst defs, - handleStateSTRef !(liftST $ newSTRef 0)] + handleStateSTRef !(liftST $ newSTRef 0), + handleLogDiscard] export runTC : Definitions -> Eff TC a -> Either Error a From 567176e0762bae16c64aed53398c4fb2c3ba00a2 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 5 Apr 2024 01:57:18 +0200 Subject: [PATCH 102/133] log refactors --- exe/CompileMonad.idr | 2 +- lib/Quox/EffExtra.idr | 14 +++- lib/Quox/Log.idr | 169 +++++++++++++++++++++++++++--------------- 3 files changed, 122 insertions(+), 63 deletions(-) diff --git a/exe/CompileMonad.idr b/exe/CompileMonad.idr index 9bdc28a..f7b28d7 100644 --- a/exe/CompileMonad.idr +++ b/exe/CompileMonad.idr @@ -62,7 +62,7 @@ handleLog : IORef LevelStack -> OpenFile -> LogL x a -> IOErr Error a handleLog lvls f l = case f of OConsole ch => handleLogIO (const $ pure ()) lvls (consoleHandle ch) l OFile _ h => handleLogIO (const $ pure ()) lvls h l - ONone => handleLogDiscard l + ONone => handleLogDiscardIO !(newIORef (length !(readIORef lvls))) l private %inline withLogFile : Options -> diff --git a/lib/Quox/EffExtra.idr b/lib/Quox/EffExtra.idr index fc6da93..4090553 100644 --- a/lib/Quox/EffExtra.idr +++ b/lib/Quox/EffExtra.idr @@ -36,6 +36,15 @@ gets : Has (State s) fs => (s -> a) -> Eff fs a gets = getsAt () +export %inline +stateAt : (0 lbl : tag) -> Has (StateL lbl s) fs => (s -> (a, s)) -> Eff fs a +stateAt lbl f = do (res, x) <- getsAt lbl f; putAt lbl x $> res + +export %inline +state : Has (State s) fs => (s -> (a, s)) -> Eff fs a +state = stateAt () + + export handleStateIORef : HasIO m => IORef st -> StateL lbl st a -> m a handleStateIORef r Get = readIORef r @@ -47,7 +56,6 @@ handleStateSTRef r Get = liftST $ readSTRef r handleStateSTRef r (Put s) = liftST $ writeSTRef r s - public export data Length : List a -> Type where Z : Length [] @@ -98,8 +106,8 @@ handleReaderConst : Applicative m => r -> ReaderL lbl r a -> m a handleReaderConst x Ask = pure x export -handleWriterST : HasST m => STRef s (SnocList w) -> WriterL lbl w a -> m s a -handleWriterST ref (Tell w) = liftST $ modifySTRef ref (:< w) +handleWriterSTRef : HasST m => STRef s (SnocList w) -> WriterL lbl w a -> m s a +handleWriterSTRef ref (Tell w) = liftST $ modifySTRef ref (:< w) public export diff --git a/lib/Quox/Log.idr b/lib/Quox/Log.idr index 36a5ce7..b979205 100644 --- a/lib/Quox/Log.idr +++ b/lib/Quox/Log.idr @@ -17,11 +17,11 @@ import Derive.Prelude %language ElabReflection -public export +public export %inline maxLogLevel : Nat maxLogLevel = 100 -public export +public export %inline logCategories : List String logCategories = ["whnf", "equal", "check"] @@ -41,11 +41,20 @@ public export IsLogCategory : String -> Type IsLogCategory cat = So $ isLogCategory cat +-- Q: why are you using `So` instead of `LT` and `Elem` +-- A: ① proof search gives up before finding a proof of e.g. ``99 `LT` 100`` +-- (i.e. `LTESucc⁹⁹ LTEZero`) +-- ② the proofs aren't looked at in any way, i just wanted to make sure the +-- list of categories was consistent everywhere + +||| a verbosity level from 0–100. higher is noisier. each log entry has a +||| verbosity level above which it will be printed, chosen, uh, based on vibes. public export LogLevel : Type LogLevel = Subset Nat IsLogLevel +||| a logging category, like "check" (type checking), "whnf", or whatever. public export LogCategory : Type LogCategory = Subset String IsLogCategory @@ -66,10 +75,14 @@ toLogCategory c = Right _ => Nothing +||| verbosity levels for each category, if they differ from the default public export LevelMap : Type LevelMap = List (LogCategory, LogLevel) --- i tried SortedMap first, but it is too much overhead for LevelMaps + +-- Q: why `List` instead of `SortedMap` +-- A: oof ouch my constant factors (maybe this one was more obvious) + public export record LogLevels where @@ -81,25 +94,33 @@ record LogLevels where public export LevelStack : Type -LevelStack = List1 LogLevels +LevelStack = List LogLevels + +public export %inline +defaultLevel : LogLevel +defaultLevel = Element 0 Oh export %inline defaultLogLevels : LogLevels -defaultLogLevels = MkLogLevels (Element 0 Oh) [] +defaultLogLevels = MkLogLevels defaultLevel [] export %inline initStack : LevelStack -initStack = singleton defaultLogLevels - -||| right biased for the default and for overlapping elements -public export %inline -mergeLevels : LogLevels -> LogLevels -> LogLevels -mergeLevels (MkLogLevels _ map1) (MkLogLevels def map2) = - MkLogLevels def $ map1 ++ map2 +initStack = [] export %inline -getLevel : LogCategory -> LogLevels -> LogLevel -getLevel cat lvls = fromMaybe lvls.defLevel $ lookup cat lvls.levels +getLevel1 : LogCategory -> LogLevels -> LogLevel +getLevel1 cat (MkLogLevels def lvls) = fromMaybe def $ lookup cat lvls + +export %inline +getLevel : LogCategory -> LevelStack -> LogLevel +getLevel cat (lvls :: _) = getLevel1 cat lvls +getLevel cat [] = defaultLevel + +export %inline +getCurLevels : LevelStack -> LogLevels +getCurLevels (lvls :: _) = lvls +getCurLevels [] = defaultLogLevels public export @@ -107,14 +128,28 @@ LogDoc : Type LogDoc = Doc (Opts {lineLength = 80}) +private %inline +replace : Eq a => a -> b -> List (a, b) -> List (a, b) +replace k v kvs = (k, v) :: filter (\y => fst y /= k) kvs + +private %inline +mergeLeft : Eq a => List (a, b) -> List (a, b) -> List (a, b) +mergeLeft l r = foldl (\lst, (k, v) => replace k v lst) r l + + public export -data PushArg = SetDefault LogLevel | SetCats LevelMap +data PushArg = SetDefault LogLevel | SetCats LevelMap | SetAll LogLevel %name PushArg push export %inline -mergePush : PushArg -> LogLevels -> LogLevels -mergePush (SetDefault def) = {defLevel := def} -mergePush (SetCats map) = {levels $= (map ++)} +applyPush : PushArg -> LogLevels -> LogLevels +applyPush (SetDefault def) = {defLevel := def} +applyPush (SetCats map) = {levels $= mergeLeft map} +applyPush (SetAll lvl) = const $ MkLogLevels lvl [] + +export %inline +fromPush : PushArg -> LogLevels +fromPush p = applyPush p defaultLogLevels public export @@ -128,10 +163,15 @@ infix 0 :> public export data LogL : (lbl : tag) -> Type -> Type where - SayMany : (cat : LogCategory) -> (loc : Loc) -> - (msgs : List LogMsg) -> LogL lbl () - Push : (push : PushArg) -> LogL lbl () - Pop : LogL lbl () + ||| print some log messages + SayMany : (cat : LogCategory) -> (loc : Loc) -> + (msgs : List LogMsg) -> LogL lbl () + ||| set some verbosity levels + Push : (push : PushArg) -> LogL lbl () + ||| restore the previous verbosity levels. + ||| returns False if the stack was already empty + Pop : LogL lbl Bool + ||| returns the current verbosity levels CurLevels : LogL lbl LogLevels public export @@ -156,7 +196,7 @@ parameters (0 lbl : tag) {auto _ : Has (LogL lbl) fs} pushAt lvls = send $ Push {lbl} lvls public export %inline - popAt : Eff fs () + popAt : Eff fs Bool popAt = send $ Pop {lbl} public export %inline @@ -180,7 +220,7 @@ parameters {auto _ : Has Log fs} push = pushAt () public export %inline - pop : Eff fs () + pop : Eff fs Bool pop = popAt () public export %inline @@ -188,53 +228,64 @@ parameters {auto _ : Has Log fs} curLevels = curLevelsAt () +||| handles a `Log` effect with an existing `State` and `Writer` export %inline -doPush : PushArg -> LevelStack -> LevelStack -doPush push list = mergePush push (head list) `cons` list +handleLogSW : (0 s : ts) -> (0 w : tw) -> + Has (StateL s LevelStack) fs => Has (WriterL w LogDoc) fs => + LogL tag a -> Eff fs a +handleLogSW s w = \case + Push push => modifyAt s $ \lst => + applyPush push (fromMaybe defaultLogLevels (head' lst)) :: lst + Pop => stateAt s $ maybe (False, []) (True,) . tail' + SayMany cat loc msgs => do + catLvl <- getsAt s $ fst . getLevel cat + let loc = runPretty $ prettyLoc loc + for_ msgs $ \(lvl :> msg) => when (lvl <= catLvl) $ tellAt w $ + hcat [loc, text cat.fst, "@", pshow lvl, ":"] <++> msg + CurLevels => + getsAt s getCurLevels export %inline -doPop : List1 a -> List1 a -doPop (_ ::: x :: xs) = x ::: xs -doPop (x ::: []) = x ::: [] +handleLogSW_ : LogL tag a -> Eff [State LevelStack, Writer LogDoc] a +handleLogSW_ = handleLogSW () () export %inline -doSayMany : Applicative m => - LevelStack -> (LogDoc -> m ()) -> - LogCategory -> Loc -> List LogMsg -> m () -doSayMany (lvls ::: _) act cat loc msgs = do - let Element catLvl _ = getLevel cat lvls - loc = runPretty $ prettyLoc loc - for_ msgs $ \msg => when (msg.level <= catLvl) $ - act $ hcat [loc, text cat.fst, "@", pshow msg.level, ":"] <++> - msg.message - -export %inline -handleLogIO : HasIO m => (FileError -> m ()) -> - IORef LevelStack -> File -> LogL tag a -> m a -handleLogIO th lvls h = \case - Push push => modifyIORef lvls $ doPush push - Pop => modifyIORef lvls doPop - SayMany cat loc msgs => doSayMany !(readIORef lvls) printMsg cat loc msgs - CurLevels => head <$> readIORef lvls +handleLogIO : HasIO m => MonadRec m => + (FileError -> m ()) -> IORef LevelStack -> File -> + LogL tag a -> m a +handleLogIO th lvls h act = + runEff (handleLogSW_ act) [handleStateIORef lvls, handleWriter {m} printMsg] where printMsg : LogDoc -> m () printMsg msg = fPutStr h (render _ msg) >>= either th pure export %inline -handleLogST : (HasST m, Monad (m s)) => +handleLogST : HasST m => MonadRec (m s) => STRef s (SnocList LogDoc) -> STRef s LevelStack -> LogL tag a -> m s a -handleLogST docs lvls = \case - Push push => modifySTRef' lvls $ doPush push - Pop => modifySTRef' lvls doPop - SayMany cat loc msgs => doSayMany !(readSTRef' lvls) printMsg cat loc msgs - CurLevels => head <$> readSTRef' lvls -where printMsg : LogDoc -> m s () - printMsg msg = modifySTRef' docs (:< msg) +handleLogST docs lvls act = + runEff (handleLogSW_ act) [handleStateSTRef lvls, handleWriterSTRef docs] export %inline -handleLogDiscard : Applicative m => LogL tag a -> m a -handleLogDiscard = \case +handleLogDiscard : (0 s : ts) -> Has (StateL s Nat) fs => + LogL tag a -> Eff fs a +handleLogDiscard s = \case + Push _ => modifyAt s S + Pop => stateAt s $ \k => (k > 0, pred k) SayMany {} => pure () - Push {} => pure () - Pop => pure () CurLevels => pure defaultLogLevels + +export %inline +handleLogDiscard_ : LogL tag a -> Eff [State Nat] a +handleLogDiscard_ = handleLogDiscard () + +export %inline +handleLogDiscardST : HasST m => MonadRec (m s) => STRef s Nat -> + LogL tag a -> m s a +handleLogDiscardST ref act = + runEff (handleLogDiscard_ act) [handleStateSTRef ref] + +export %inline +handleLogDiscardIO : HasIO m => MonadRec m => IORef Nat -> + LogL tag a -> m a +handleLogDiscardIO ref act = + runEff (handleLogDiscard_ act) [handleStateIORef ref] From 7a0bc73d25822d9e75387b590baf4298420d4042 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sat, 6 Apr 2024 20:03:51 +0200 Subject: [PATCH 103/133] approximate log stack in handleLogDiscard --- exe/CompileMonad.idr | 15 +++++++++++---- lib/Quox/Log.idr | 13 +++++++++++++ tests/Tests/Equal.idr | 2 +- tests/Tests/Reduce.idr | 7 ++++--- tests/Tests/Typechecker.idr | 4 ++-- tests/TypingImpls.idr | 4 ++-- 6 files changed, 33 insertions(+), 12 deletions(-) diff --git a/exe/CompileMonad.idr b/exe/CompileMonad.idr index f7b28d7..bc0b3e5 100644 --- a/exe/CompileMonad.idr +++ b/exe/CompileMonad.idr @@ -14,6 +14,7 @@ import Error import System.File import Data.IORef +import Data.Maybe import Control.Eff %default total @@ -57,12 +58,18 @@ Compile = ReaderL STATE State, ReaderL OPTS Options, Log, LoadFile, IO] + export %inline handleLog : IORef LevelStack -> OpenFile -> LogL x a -> IOErr Error a -handleLog lvls f l = case f of - OConsole ch => handleLogIO (const $ pure ()) lvls (consoleHandle ch) l - OFile _ h => handleLogIO (const $ pure ()) lvls h l - ONone => handleLogDiscardIO !(newIORef (length !(readIORef lvls))) l +handleLog ref f l = case f of + OConsole ch => handleLogIO (const $ pure ()) ref (consoleHandle ch) l + OFile _ h => handleLogIO (const $ pure ()) ref h l + ONone => do + lvls <- readIORef ref + lenRef <- newIORef (length lvls) + res <- handleLogDiscardIO lenRef l + writeIORef ref $ fixupDiscardedLog !(readIORef lenRef) lvls + pure res private %inline withLogFile : Options -> diff --git a/lib/Quox/Log.idr b/lib/Quox/Log.idr index b979205..faf8385 100644 --- a/lib/Quox/Log.idr +++ b/lib/Quox/Log.idr @@ -289,3 +289,16 @@ handleLogDiscardIO : HasIO m => MonadRec m => IORef Nat -> LogL tag a -> m a handleLogDiscardIO ref act = runEff (handleLogDiscard_ act) [handleStateIORef ref] + + +||| approximate the push/pop effects in a discarded log by trimming a stack or +||| repeating its most recent element +export %inline +fixupDiscardedLog : Nat -> LevelStack -> LevelStack +fixupDiscardedLog want lvls = + let len = length lvls in + case compare len want of + EQ => lvls + GT => drop (len `minus` want) lvls + LT => let new = fromMaybe defaultLogLevels $ head' lvls in + replicate (want `minus` len) new ++ lvls diff --git a/tests/Tests/Equal.idr b/tests/Tests/Equal.idr index 60f71ad..efd1b33 100644 --- a/tests/Tests/Equal.idr +++ b/tests/Tests/Equal.idr @@ -27,7 +27,7 @@ parameters (label : String) (act : Eff Equal ()) testEq = test label $ runEqual globals act testNeq : Test - testNeq = testThrows label (const True) $ runTC globals act $> "()" + testNeq = testThrows label (const True) $ runTC globals act $> "ok" parameters (ctx : TyContext d n) diff --git a/tests/Tests/Reduce.idr b/tests/Tests/Reduce.idr index f566f07..0635199 100644 --- a/tests/Tests/Reduce.idr +++ b/tests/Tests/Reduce.idr @@ -14,9 +14,10 @@ import Control.Eff runWhnf : Eff Whnf a -> Either Error a runWhnf act = runSTErr $ do - runEff act [handleExcept (\e => stLeft e), - handleStateSTRef !(liftST $ newSTRef 0), - handleLogDiscard] + runEff act $ with Union.(::) + [handleExcept (\e => stLeft e), + handleStateSTRef !(newSTRef' 0), + handleLogDiscardST !(newSTRef' 0)] parameters {0 isRedex : RedexTest tm} {auto _ : CanWhnf tm isRedex} {d, n : Nat} {auto _ : (Eq (tm d n), Show (tm d n))} diff --git a/tests/Tests/Typechecker.idr b/tests/Tests/Typechecker.idr index f99886a..42af71e 100644 --- a/tests/Tests/Typechecker.idr +++ b/tests/Tests/Typechecker.idr @@ -114,11 +114,11 @@ parameters (label : String) (act : Lazy (Eff Test ())) {default defGlobals globals : Definitions} testTC : Test testTC = test label {e = Error', a = ()} $ - extract $ runExcept $ runReaderAt DEFS globals act + runEff act [handleExcept (\e => Left e), handleReaderConst globals] testTCFail : Test testTCFail = testThrows label (const True) $ - (extract $ runExcept $ runReaderAt DEFS globals act) $> "()" + runEff act [handleExcept (\e => Left e), handleReaderConst globals] $> "ok" inferredTypeEq : TyContext d n -> (exp, got : Term d n) -> Eff Test () diff --git a/tests/TypingImpls.idr b/tests/TypingImpls.idr index 80b2bbd..c86ad66 100644 --- a/tests/TypingImpls.idr +++ b/tests/TypingImpls.idr @@ -25,8 +25,8 @@ runEqual defs act = runSTErr $ do runEff act $ with Union.(::) [handleExcept (\e => stLeft e), handleReaderConst defs, - handleStateSTRef !(liftST $ newSTRef 0), - handleLogDiscard] + handleStateSTRef !(newSTRef' 0), + handleLogDiscardST !(newSTRef' 0)] export runTC : Definitions -> Eff TC a -> Either Error a From 11b0ab6a2567935660b3b986bcc07580ecb7d01a Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 7 Apr 2024 03:20:39 +0200 Subject: [PATCH 104/133] remove default from `FromParser.fromParserPure` and `Main.step` --- exe/Main.idr | 15 +++++++-------- lib/Quox/Parser/FromParser.idr | 7 +++---- tests/Tests/FromPTerm.idr | 2 +- 3 files changed, 11 insertions(+), 13 deletions(-) diff --git a/exe/Main.idr b/exe/Main.idr index e23184b..c9e7f0b 100644 --- a/exe/Main.idr +++ b/exe/Main.idr @@ -34,9 +34,8 @@ Step : Type -> Type -> Type Step a b = OpenFile -> a -> Eff Compile b private -step : {default CErr console : ConsoleChannel} -> - Phase -> OutFile -> Step a b -> a -> Eff CompileStop b -step phase file act x = do +step : ConsoleChannel -> Phase -> OutFile -> Step a b -> a -> Eff CompileStop b +step console phase file act x = do opts <- askAt OPTS res <- withOutFile console file fromError $ \h => lift $ act h x when (opts.until == Just phase) stopHere @@ -99,11 +98,11 @@ processFile : String -> Eff Compile () processFile file = withEarlyStop $ pipeline !(askAt OPTS) file where pipeline : Options -> String -> Eff CompileStop () pipeline opts = - step Parse opts.dump.parse Main.parse >=> - step Check opts.dump.check Main.check >=> - step Erase opts.dump.erase Main.erase >=> - step Scheme opts.dump.scheme Main.scheme >=> - step End opts.outFile Main.output {console = COut} + step CErr Parse opts.dump.parse Main.parse >=> + step CErr Check opts.dump.check Main.check >=> + step CErr Erase opts.dump.erase Main.erase >=> + step CErr Scheme opts.dump.scheme Main.scheme >=> + step COut End opts.outFile Main.output export covering diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 8328272..88017fd 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -49,10 +49,9 @@ record PureParserResult a where logLevels : LevelStack export -fromParserPure : {default [<] ns : Mods} -> - NameSuf -> Definitions -> LevelStack -> +fromParserPure : Mods -> NameSuf -> Definitions -> LevelStack -> Eff FromParserPure a -> Either Error (PureParserResult a) -fromParserPure suf defs lvls act = runSTErr $ do +fromParserPure ns suf defs lvls act = runSTErr $ do suf <- newSTRef' suf defs <- newSTRef' defs log <- newSTRef' [<] @@ -376,7 +375,7 @@ export covering expectFail : Loc -> Eff FromParserPure a -> Eff FromParserPure Error expectFail loc act = do gen <- getAt GEN; defs <- getAt DEFS; ns <- getAt NS; lvl <- curLevels - case fromParserPure {ns} gen defs (singleton lvl) act of + case fromParserPure ns gen defs (singleton lvl) act of Left err => pure err Right _ => throw $ ExpectedFail loc diff --git a/tests/Tests/FromPTerm.idr b/tests/Tests/FromPTerm.idr index 319d407..de7bd24 100644 --- a/tests/Tests/FromPTerm.idr +++ b/tests/Tests/FromPTerm.idr @@ -68,7 +68,7 @@ parameters {c : Bool} {auto _ : Show b} runFromParser : {default empty defs : Definitions} -> Eff FromParserPure a -> Either FromParser.Error a -runFromParser = map val . fromParserPure 0 defs initStack +runFromParser = map val . fromParserPure [<] 0 defs initStack export tests : Test From fca75377a07543690b318b30367113e45d588115 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 11 Apr 2024 22:08:07 +0200 Subject: [PATCH 105/133] =?UTF-8?q?MakeName=20=E2=87=92=20MkName=20for=20c?= =?UTF-8?q?onsistency?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/Quox/Name.idr | 18 +++++++++--------- lib/Quox/Parser/FromParser.idr | 2 +- lib/Quox/Parser/Parser.idr | 6 +++--- lib/Quox/Untyped/Scheme.idr | 8 ++++---- tests/Tests/Lexer.idr | 10 +++++----- tests/Tests/Parser.idr | 8 ++++---- tests/Tests/PrettyTerm.idr | 4 ++-- 7 files changed, 28 insertions(+), 28 deletions(-) diff --git a/lib/Quox/Name.idr b/lib/Quox/Name.idr index 6c81091..8686e54 100644 --- a/lib/Quox/Name.idr +++ b/lib/Quox/Name.idr @@ -43,14 +43,14 @@ Mods = SnocList String public export record Name where - constructor MakeName + constructor MkName mods : Mods base : BaseName %runElab derive "Name" [Eq, Ord] public export %inline unq : BaseName -> Name -unq = MakeName [<] +unq = MkName [<] ||| add some namespaces to the beginning of a name public export %inline @@ -64,31 +64,31 @@ PBaseName = String public export record PName where - constructor MakePName + constructor MkPName mods : Mods base : PBaseName %runElab derive "PName" [Eq, Ord, PrettyVal] export %inline fromPName : PName -> Name -fromPName p = MakeName p.mods $ UN p.base +fromPName p = MkName p.mods $ UN p.base export %inline toPName : Name -> PName -toPName p = MakePName p.mods $ baseStr p.base +toPName p = MkPName p.mods $ baseStr p.base export %inline fromPBaseName : PBaseName -> Name -fromPBaseName = MakeName [<] . UN +fromPBaseName = MkName [<] . UN export Show PName where - show (MakePName mods base) = + show (MkPName mods base) = show $ concat $ intersperse "." $ toList $ mods :< base export Show Name where show = show . toPName -export FromString PName where fromString = MakePName [<] +export FromString PName where fromString = MkPName [<] export FromString Name where fromString = fromPBaseName @@ -116,7 +116,7 @@ export fromListP : List1 String -> PName fromListP (x ::: xs) = go [<] x xs where go : SnocList String -> String -> List String -> PName - go mods x [] = MakePName mods x + go mods x [] = MkPName mods x go mods x (y :: ys) = go (mods :< x) y ys export %inline diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 88017fd..08a7210 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -75,7 +75,7 @@ parameters {auto _ : Functor m} (b : Var n -> m a) (f : PName -> m a) (xs : Context' PatVar n) private fromBaseName : PBaseName -> m a - fromBaseName x = maybe (f $ MakePName [<] x) b $ + fromBaseName x = maybe (f $ MkPName [<] x) b $ Context.find (\y => y.name == Just x) xs private diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index b34599c..44b5833 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -124,7 +124,7 @@ qname = terminalMatch "name" `(Name n) `(n) ||| unqualified name export baseName : Grammar True PBaseName -baseName = terminalMatch "unqualified name" `(Name (MakePName [<] b)) `(b) +baseName = terminalMatch "unqualified name" `(Name (MkPName [<] b)) `(b) ||| dimension constant (0 or 1) export @@ -152,8 +152,8 @@ qty fname = withLoc fname [|PQ qtyVal|] export exactName : String -> Grammar True () exactName name = terminal "expected '\{name}'" $ \case - Name (MakePName [<] x) => guard $ x == name - _ => Nothing + Name (MkPName [<] x) => guard $ x == name + _ => Nothing ||| pattern var (unqualified name or _) diff --git a/lib/Quox/Untyped/Scheme.idr b/lib/Quox/Untyped/Scheme.idr index c5a528d..b193598 100644 --- a/lib/Quox/Untyped/Scheme.idr +++ b/lib/Quox/Untyped/Scheme.idr @@ -113,13 +113,13 @@ makeIdBase mods str = joinBy "." $ toList $ mods :< str export makeId : Name -> Id -makeId (MakeName mods (UN str)) = I (makeIdBase mods str) 0 -makeId (MakeName mods (MN str k)) = I (makeIdBase mods str) 0 -makeId (MakeName mods Unused) = I (makeIdBase mods "_") 0 +makeId (MkName mods (UN str)) = I (makeIdBase mods str) 0 +makeId (MkName mods (MN str k)) = I (makeIdBase mods str) 0 +makeId (MkName mods Unused) = I (makeIdBase mods "_") 0 export makeIdB : BindName -> Id -makeIdB (BN name _) = makeId $ MakeName [<] name +makeIdB (BN name _) = makeId $ MkName [<] name private bump : Id -> Id diff --git a/tests/Tests/Lexer.idr b/tests/Tests/Lexer.idr index 549de46..40fd9a8 100644 --- a/tests/Tests/Lexer.idr +++ b/tests/Tests/Lexer.idr @@ -71,7 +71,7 @@ tests = "lexer" :- [ lexes "δελτα" [Name "δελτα"], lexes "★★" [Name "★★"], lexes "Types" [Name "Types"], - lexes "a.b.c.d.e" [Name $ MakePName [< "a","b","c","d"] "e"], + lexes "a.b.c.d.e" [Name $ MkPName [< "a","b","c","d"] "e"], lexes "normalïse" [Name "normalïse"], -- ↑ replace i + combining ¨ with precomposed ï lexes "map#" [Name "map#"], @@ -90,16 +90,16 @@ tests = "lexer" :- [ lexes "***" [Name "***"], lexes "+**" [Name "+**"], lexes "+#" [Name "+#"], - lexes "+.+.+" [Name $ MakePName [< "+", "+"] "+"], - lexes "a.+" [Name $ MakePName [< "a"] "+"], - lexes "+.a" [Name $ MakePName [< "+"] "a"], + lexes "+.+.+" [Name $ MkPName [< "+", "+"] "+"], + lexes "a.+" [Name $ MkPName [< "a"] "+"], + lexes "+.a" [Name $ MkPName [< "+"] "a"], lexes "+a" [Name "+", Name "a"], lexes "x." [Name "x", Reserved "."], lexes "&." [Name "&", Reserved "."], lexes ".x" [Reserved ".", Name "x"], - lexes "a.b.c." [Name $ MakePName [< "a", "b"] "c", Reserved "."], + lexes "a.b.c." [Name $ MkPName [< "a", "b"] "c", Reserved "."], lexes "case" [Reserved "case"], lexes "caseω" [Reserved "caseω"], diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index 4c0dc0f..e4f6d88 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -63,9 +63,9 @@ tests = "parser" :- [ "names" :- [ parsesAs (const qname) "x" - (MakePName [<] "x"), + (MkPName [<] "x"), parsesAs (const qname) "Data.List.length" - (MakePName [< "Data", "List"] "length"), + (MkPName [< "Data", "List"] "length"), parseFails (const qname) "_" ], @@ -124,7 +124,7 @@ tests = "parser" :- [ parseMatch term "f" `(V "f" {}), parseMatch term "f.x.y" - `(V (MakePName [< "f", "x"] "y") {}), + `(V (MkPName [< "f", "x"] "y") {}), parseMatch term "f x" `(App (V "f" {}) (V "x" {}) _), parseMatch term "f x y" @@ -526,7 +526,7 @@ tests = "parser" :- [ PSucceed False Nothing _] PSucceed _), PD (PDef $ MkPDef (PQ Any _) "y" - (PConcrete Nothing (V (MakePName [< "a"] "x") Nothing _)) + (PConcrete Nothing (V (MkPName [< "a"] "x") Nothing _)) PSucceed False Nothing _)]), parseMatch input #" load "a.quox"; def b = a.b "# `([PLoad "a.quox" _, diff --git a/tests/Tests/PrettyTerm.idr b/tests/Tests/PrettyTerm.idr index 7856e12..b15cadc 100644 --- a/tests/Tests/PrettyTerm.idr +++ b/tests/Tests/PrettyTerm.idr @@ -37,8 +37,8 @@ tests = "pretty printing terms" :- [ "free vars" :- [ testPrettyE1 [<] [<] (^F "x" 0) "x", testPrettyE [<] [<] (^F "x" 1) "x¹" "x^1", - testPrettyE1 [<] [<] (^F (MakeName [< "A", "B", "C"] "x") 0) "A.B.C.x", - testPrettyE [<] [<] (^F (MakeName [< "A", "B", "C"] "x") 2) + testPrettyE1 [<] [<] (^F (MkName [< "A", "B", "C"] "x") 0) "A.B.C.x", + testPrettyE [<] [<] (^F (MkName [< "A", "B", "C"] "x") 2) "A.B.C.x²" "A.B.C.x^2" ], From f56f5948391895279540650e26ee2a336be358fd Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 11 Apr 2024 22:09:49 +0200 Subject: [PATCH 106/133] push multiple loglevel changes at once --- lib/Quox/Log.idr | 31 +++++++++++++++++++++---------- 1 file changed, 21 insertions(+), 10 deletions(-) diff --git a/lib/Quox/Log.idr b/lib/Quox/Log.idr index faf8385..bfe5d26 100644 --- a/lib/Quox/Log.idr +++ b/lib/Quox/Log.idr @@ -138,18 +138,21 @@ mergeLeft l r = foldl (\lst, (k, v) => replace k v lst) r l public export -data PushArg = SetDefault LogLevel | SetCats LevelMap | SetAll LogLevel +data PushArg = + SetDefault LogLevel + | SetCat LogCategory LogLevel + | SetAll LogLevel %name PushArg push export %inline -applyPush : PushArg -> LogLevels -> LogLevels -applyPush (SetDefault def) = {defLevel := def} -applyPush (SetCats map) = {levels $= mergeLeft map} -applyPush (SetAll lvl) = const $ MkLogLevels lvl [] +applyPush : LogLevels -> PushArg -> LogLevels +applyPush lvls (SetDefault def) = {defLevel := def} lvls +applyPush lvls (SetCat cat lvl) = {levels $= replace cat lvl} lvls +applyPush lvls (SetAll lvl) = MkLogLevels lvl [] export %inline fromPush : PushArg -> LogLevels -fromPush p = applyPush p defaultLogLevels +fromPush = applyPush defaultLogLevels public export @@ -167,7 +170,7 @@ data LogL : (lbl : tag) -> Type -> Type where SayMany : (cat : LogCategory) -> (loc : Loc) -> (msgs : List LogMsg) -> LogL lbl () ||| set some verbosity levels - Push : (push : PushArg) -> LogL lbl () + Push : (push : List PushArg) -> LogL lbl () ||| restore the previous verbosity levels. ||| returns False if the stack was already empty Pop : LogL lbl Bool @@ -192,9 +195,13 @@ parameters (0 lbl : tag) {auto _ : Has (LogL lbl) fs} sayAt cat lvl loc msg = sayManyAt cat loc [lvl :> msg] public export %inline - pushAt : PushArg -> Eff fs () + pushAt : List PushArg -> Eff fs () pushAt lvls = send $ Push {lbl} lvls + public export %inline + push1At : PushArg -> Eff fs () + push1At lvl = pushAt [lvl] + public export %inline popAt : Eff fs Bool popAt = send $ Pop {lbl} @@ -216,9 +223,13 @@ parameters {auto _ : Has Log fs} say = sayAt () public export %inline - push : PushArg -> Eff fs () + push : List PushArg -> Eff fs () push = pushAt () + public export %inline + push1 : PushArg -> Eff fs () + push1 = push1At () + public export %inline pop : Eff fs Bool pop = popAt () @@ -235,7 +246,7 @@ handleLogSW : (0 s : ts) -> (0 w : tw) -> LogL tag a -> Eff fs a handleLogSW s w = \case Push push => modifyAt s $ \lst => - applyPush push (fromMaybe defaultLogLevels (head' lst)) :: lst + foldl applyPush (fromMaybe defaultLogLevels (head' lst)) push :: lst Pop => stateAt s $ maybe (False, []) (True,) . tail' SayMany cat loc msgs => do catLvl <- getsAt s $ fst . getLevel cat From 9d60f366cf7ac3727ec09ec0ee2daff394001413 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 12 Apr 2024 21:49:15 +0200 Subject: [PATCH 107/133] add #![log] pragma --- lib/Quox/Log.idr | 4 +- lib/Quox/Parser/FromParser.idr | 4 ++ lib/Quox/Parser/Lexer.idr | 2 +- lib/Quox/Parser/Parser.idr | 107 +++++++++++++++++++++++++-------- lib/Quox/Parser/Syntax.idr | 23 +++++-- lib/Quox/PrettyValExtra.idr | 10 +++ tests/Tests/Parser.idr | 48 ++++++++++++++- 7 files changed, 164 insertions(+), 34 deletions(-) diff --git a/lib/Quox/Log.idr b/lib/Quox/Log.idr index bfe5d26..6630bb6 100644 --- a/lib/Quox/Log.idr +++ b/lib/Quox/Log.idr @@ -2,6 +2,7 @@ module Quox.Log import Quox.Loc import Quox.Pretty +import Quox.PrettyValExtra import Data.So import Data.DPair @@ -90,7 +91,7 @@ record LogLevels where defLevel : LogLevel levels : LevelMap %name LogLevels lvls -%runElab derive "LogLevels" [Eq, Show] +%runElab derive "LogLevels" [Eq, Show, PrettyVal] public export LevelStack : Type @@ -142,6 +143,7 @@ data PushArg = SetDefault LogLevel | SetCat LogCategory LogLevel | SetAll LogLevel +%runElab derive "PushArg" [Eq, Ord, Show, PrettyVal] %name PushArg push export %inline diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 08a7210..ddf8671 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -398,6 +398,10 @@ fromPDecl (PDef def) = fromPDecl (PNs ns) = maybeFail ns.fail ns.loc $ localAt NS (<+> ns.name) $ concat <$> traverse fromPDecl ns.decls +fromPDecl (PPrag prag) = + case prag of + PLogPush p _ => Log.push p $> [] + PLogPop _ => Log.pop $> [] mutual export covering diff --git a/lib/Quox/Parser/Lexer.idr b/lib/Quox/Parser/Lexer.idr index afd6df5..f4a4ee0 100644 --- a/lib/Quox/Parser/Lexer.idr +++ b/lib/Quox/Parser/Lexer.idr @@ -247,7 +247,7 @@ public export reserved : List Reserved reserved = [Punc1 "(", Punc1 ")", Punc1 "[", Punc1 "]", Punc1 "{", Punc1 "}", - Punc1 ",", Punc1 ";", Punc1 "#[", + Punc1 ",", Punc1 ";", Punc1 "#[", Punc1 "#![", Sym1 "@", Sym1 ":", Sym "⇒" `Or` Sym "=>", diff --git a/lib/Quox/Parser/Parser.idr b/lib/Quox/Parser/Parser.idr index 44b5833..6035d57 100644 --- a/lib/Quox/Parser/Parser.idr +++ b/lib/Quox/Parser/Parser.idr @@ -626,14 +626,19 @@ term fname = lamTerm fname export -attr : FileName -> Grammar True PAttr -attr fname = withLoc fname $ do - resC "#[" +attr' : FileName -> (o : String) -> (0 _ : IsReserved o) => + Grammar True PAttr +attr' fname o = withLoc fname $ do + resC o name <- baseName args <- many $ termArg fname mustWork $ resC "]" pure $ PA name args +export %inline +attr : FileName -> Grammar True PAttr +attr fname = attr' fname "#[" + export findDups : List PAttr -> List String findDups attrs = @@ -658,44 +663,48 @@ attrList fname = do noDups res $> res public export -data AttrMatch a = Matched a | NoMatch String | Malformed String String +data AttrMatch a = + Matched a + | NoMatch String (List String) + | Malformed String String export Functor AttrMatch where map f (Matched x) = Matched $ f x - map f (NoMatch s) = NoMatch s + map f (NoMatch s w) = NoMatch s w map f (Malformed a e) = Malformed a e export (<|>) : AttrMatch a -> AttrMatch a -> AttrMatch a Matched x <|> _ = Matched x -NoMatch _ <|> y = y +NoMatch {} <|> y = y Malformed a e <|> _ = Malformed a e export -isFail : PAttr -> AttrMatch PFail -isFail (PA "fail" [] _) = Matched PFailAny -isFail (PA "fail" [Str s _] _) = Matched $ PFailMatch s -isFail (PA "fail" _ _) = Malformed "fail" "be absent or a string literal" -isFail a = NoMatch a.name +isFail : PAttr -> List String -> AttrMatch PFail +isFail (PA "fail" [] _) _ = Matched PFailAny +isFail (PA "fail" [Str s _] _) _ = Matched $ PFailMatch s +isFail (PA "fail" _ _) _ = Malformed "fail" "be absent or a string literal" +isFail a w = NoMatch a.name w export -isMain : PAttr -> AttrMatch () -isMain (PA "main" [] _) = Matched () -isMain (PA "main" _ _) = Malformed "main" "have no arguments" -isMain a = NoMatch a.name +isMain : PAttr -> List String -> AttrMatch () +isMain (PA "main" [] _) _ = Matched () +isMain (PA "main" _ _) _ = Malformed "main" "have no arguments" +isMain a w = NoMatch a.name w export -isScheme : PAttr -> AttrMatch String -isScheme (PA "compile-scheme" [Str s _] _) = Matched s -isScheme (PA "compile-scheme" _ _) = +isScheme : PAttr -> List String -> AttrMatch String +isScheme (PA "compile-scheme" [Str s _] _) _ = Matched s +isScheme (PA "compile-scheme" _ _) _ = Malformed "compile-scheme" "be a string literal" -isScheme a = NoMatch a.name +isScheme a w = NoMatch a.name w export matchAttr : String -> AttrMatch a -> Either String a matchAttr _ (Matched x) = Right x -matchAttr d (NoMatch a) = Left "unrecognised \{d} attribute \{a}" +matchAttr d (NoMatch a w) = Left $ unlines + ["unrecognised \{d} attribute \{a}", "expected one of: \{show w}"] matchAttr _ (Malformed a s) = Left $ unlines ["invalid \{a} attribute", "(should \{s})"] @@ -710,10 +719,12 @@ where data PDefAttr = DefFail PFail | DefMain | DefScheme String isDefAttr : PAttr -> Either String PDefAttr - isDefAttr attr = matchAttr "definition" $ - DefFail <$> isFail attr - <|> DefMain <$ isMain attr - <|> DefScheme <$> isScheme attr + isDefAttr attr = + let defAttrs = ["fail", "main", "compile-scheme"] in + matchAttr "definition" $ + DefFail <$> isFail attr defAttrs + <|> DefMain <$ isMain attr defAttrs + <|> DefScheme <$> isScheme attr defAttrs addAttr : PDefinition -> PAttr -> Either String PDefinition addAttr def attr = @@ -730,7 +741,7 @@ mkPNamespace attrs name decls = do res <- foldlM addAttr start attrs pure $ \l => {loc_ := l} (the PNamespace res) where - isNsAttr = matchAttr "namespace" . isFail + isNsAttr a = matchAttr "namespace" $ isFail a ["fail"] addAttr : PNamespace -> PAttr -> Either String PNamespace addAttr ns attr = pure $ {fail := !(isNsAttr attr)} ns @@ -785,6 +796,48 @@ export nsname : Grammar True Mods nsname = do ns <- qname; pure $ ns.mods :< ns.base +export +pragma : FileName -> Grammar True PPragma +pragma fname = do + a <- attr' fname "#![" + either fatalError pure $ case a.name of + "log" => logArgs a.args a.loc + _ => Left $ + #"unrecognised pragma "\#{a.name}"\n"# ++ + #"known pragmas: ["log"]"# +where + levelOOB : Nat -> Either String a + levelOOB n = Left $ + "log level \{show n} out of bounds\n" ++ + "expected number in range 0–\{show maxLogLevel} inclusive" + + toLevel : Nat -> Either String LogLevel + toLevel lvl = maybe (levelOOB lvl) Right $ toLogLevel lvl + + unknownCat : String -> Either String a + unknownCat cat = Left $ + "unknown log category \{show cat}\n" ++ + "known categories: \{show $ ["all", "default"] ++ logCategories}" + + toCat : String -> Either String LogCategory + toCat cat = maybe (unknownCat cat) Right $ toLogCategory cat + + fromPair : PTerm -> Either String (String, Nat) + fromPair (Pair (V (MkPName [<] x) Nothing _) (Nat n _) _) = Right (x, n) + fromPair _ = Left "invalid argument to log pragma" + + logCatArg : (String, Nat) -> Either String Log.PushArg + logCatArg ("default", lvl) = [|SetDefault $ toLevel lvl|] + logCatArg ("all", lvl) = [|SetAll $ toLevel lvl|] + logCatArg (cat, lvl) = [|SetCat (toCat cat) (toLevel lvl)|] + + logArgs : List PTerm -> Loc -> Either String PPragma + logArgs [] _ = Left "missing arguments to log pragma" + logArgs [V "pop" Nothing _] loc = Right $ PLogPop loc + logArgs other loc = do + args <- traverse (logCatArg <=< fromPair) other + pure $ PLogPush args loc + export decl : FileName -> Grammar True PDecl @@ -806,7 +859,9 @@ declBody fname attrs = [|PDef $ definition fname attrs|] <|> [|PNs $ namespace_ fname attrs|] -- decl : FileName -> Grammar True PDecl -decl fname = attrList fname >>= declBody fname +decl fname = + (attrList fname >>= declBody fname) + <|> PPrag <$> pragma fname export load : FileName -> Grammar True PTopLevel diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index 4011ac5..9c8609f 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -4,6 +4,7 @@ import public Quox.Loc import public Quox.Syntax import public Quox.Definition import Quox.PrettyValExtra +import public Quox.Log import Derive.Prelude %hide TT.Name @@ -184,6 +185,18 @@ record PDefinition where export Located PDefinition where def.loc = def.loc_ +public export +data PPragma = + PLogPush (List Log.PushArg) Loc + | PLogPop Loc +%name PPragma prag +%runElab derive "PPragma" [Eq, Ord, Show, PrettyVal] + +export +Located PPragma where + (PLogPush _ loc).loc = loc + (PLogPop loc).loc = loc + mutual public export record PNamespace where @@ -196,8 +209,9 @@ mutual public export data PDecl = - PDef PDefinition - | PNs PNamespace + PDef PDefinition + | PNs PNamespace + | PPrag PPragma %name PDecl decl %runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal] @@ -205,8 +219,9 @@ export Located PNamespace where ns.loc = ns.loc_ export Located PDecl where - (PDef d).loc = d.loc - (PNs ns).loc = ns.loc + (PDef d).loc = d.loc + (PNs ns).loc = ns.loc + (PPrag prag).loc = prag.loc public export data PTopLevel = PD PDecl | PLoad String Loc diff --git a/lib/Quox/PrettyValExtra.idr b/lib/Quox/PrettyValExtra.idr index afd210e..8ef7366 100644 --- a/lib/Quox/PrettyValExtra.idr +++ b/lib/Quox/PrettyValExtra.idr @@ -1,5 +1,6 @@ module Quox.PrettyValExtra +import Data.DPair import Derive.Prelude import public Text.Show.Value import public Text.Show.PrettyVal @@ -8,3 +9,12 @@ import public Text.Show.PrettyVal.Derive %language ElabReflection %runElab derive "SnocList" [PrettyVal] + + +export %inline +PrettyVal a => PrettyVal (Subset a p) where + prettyVal (Element x _) = Con "Element" [prettyVal x, Con "_" []] + +export %inline +(forall x. PrettyVal (p x)) => PrettyVal (Exists p) where + prettyVal (Evidence _ p) = Con "Evidence" [Con "_" [], prettyVal p] diff --git a/tests/Tests/Parser.idr b/tests/Tests/Parser.idr index e4f6d88..7bbca5d 100644 --- a/tests/Tests/Parser.idr +++ b/tests/Tests/Parser.idr @@ -531,7 +531,51 @@ tests = "parser" :- [ parseMatch input #" load "a.quox"; def b = a.b "# `([PLoad "a.quox" _, PD (PDef $ MkPDef (PQ Any _) "b" - (PConcrete Nothing (V (MakePName [< "a"] "b") Nothing _)) - PSucceed False Nothing _)]) + (PConcrete Nothing (V (MkPName [< "a"] "b") Nothing _)) + PSucceed False Nothing _)]), + parseMatch input #" #[main] postulate hi : String "# + `([PD (PDef $ MkPDef (PQ Any _) "hi" + (PPostulate (STRING _)) + PSucceed True Nothing _)]), + parseMatch input #" #[compile-scheme "hi"] postulate hi : String "# + `([PD (PDef $ MkPDef (PQ Any _) "hi" + (PPostulate (STRING _)) + PSucceed False (Just "hi") _)]), + parseMatch input #" #[main] #[compile-scheme "hi"] postulate hi : String "# + `([PD (PDef $ MkPDef (PQ Any _) "hi" + (PPostulate (STRING _)) + PSucceed True (Just "hi") _)]), + parseMatch input #" #[fail] def hi = "hi!!!! uwu" "# + `([PD (PDef $ MkPDef (PQ Any _) "hi" + (PConcrete Nothing (Str "hi!!!! uwu" _)) + PFailAny False Nothing _)]), + parseMatch input #" #[fail "type"] def hi = "hi!!!! uwu" "# + `([PD (PDef $ MkPDef (PQ Any _) "hi" + (PConcrete Nothing (Str "hi!!!! uwu" _)) + (PFailMatch "type") False Nothing _)]), + parseMatch input #" #[fail] namespace ns { } "# + `([PD (PNs $ MkPNamespace [< "ns"] [] PFailAny _)]), + parseFails input #" #[fail 69] namespace ns { } "#, + parseFails input "#[main]", + parseFails input "#[main] namespace a { } ", + parseFails input #" #[not-an-attr] postulate hi : String "#, + parseFails input #" #[log pop] postulate hi : String "#, + parseMatch input #" #![log pop] "# + `([PD (PPrag (PLogPop _))]), + parseMatch input #" #![log (all, 5)] "# + `([PD (PPrag (PLogPush [SetAll (Element 5 _)] _))]), + parseMatch input #" #![log (default, 69)] "# + `([PD (PPrag (PLogPush [SetDefault (Element 69 _)] _))]), + parseMatch input #" #![log (whnf, 100)] "# + `([PD (PPrag (PLogPush [SetCat (Element "whnf" _) (Element 100 _)] _))]), + parseMatch input #" #![log (all, 5) (default, 69) (whnf, 100)] "# + `([PD (PPrag (PLogPush + [SetAll (Element 5 _), SetDefault (Element 69 _), + SetCat (Element "whnf" _) (Element 100 _)] _))]), + parseFails input #" #![log] "#, + parseFails input #" #![log (non-category, 5)] "#, + parseFails input #" #![log (whnf, 50000000)] "#, + parseFails input #" #![log [0.★⁵]] "#, + parseFails input #" #![main] "# ] ] From a1d8fd4ab5eae022769e7abba5f8e7b7058c72a4 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 12 Apr 2024 21:52:36 +0200 Subject: [PATCH 108/133] %inline --- lib/Quox/Parser/Syntax.idr | 22 +++++++++++----------- 1 file changed, 11 insertions(+), 11 deletions(-) diff --git a/lib/Quox/Parser/Syntax.idr b/lib/Quox/Parser/Syntax.idr index 9c8609f..9197efe 100644 --- a/lib/Quox/Parser/Syntax.idr +++ b/lib/Quox/Parser/Syntax.idr @@ -18,7 +18,7 @@ data PatVar = Unused Loc | PV PBaseName Loc %name PatVar v %runElab derive "PatVar" [Eq, Ord, Show, PrettyVal] -export +export %inline Located PatVar where (Unused loc).loc = loc (PV _ loc).loc = loc @@ -42,7 +42,7 @@ record PQty where %name PQty qty %runElab derive "PQty" [Eq, Ord, Show, PrettyVal] -export Located PQty where q.loc = q.loc_ +export %inline Located PQty where q.loc = q.loc_ namespace PDim public export @@ -50,7 +50,7 @@ namespace PDim %name PDim p, q %runElab derive "PDim" [Eq, Ord, Show, PrettyVal] -export +export %inline Located PDim where (K _ loc).loc = loc (V _ loc).loc = loc @@ -119,7 +119,7 @@ namespace PTerm %runElab deriveMutual ["PTerm", "PCaseBody"] [Eq, Ord, Show, PrettyVal] -export +export %inline Located PTerm where (TYPE _ loc).loc = loc (IOState loc).loc = loc @@ -149,7 +149,7 @@ Located PTerm where (Comp _ _ _ _ _ _ _ loc).loc = loc (Let _ _ loc).loc = loc -export +export %inline Located PCaseBody where (CasePair _ _ loc).loc = loc (CaseEnum _ loc).loc = loc @@ -183,7 +183,7 @@ record PDefinition where %name PDefinition def %runElab derive "PDefinition" [Eq, Ord, Show, PrettyVal] -export Located PDefinition where def.loc = def.loc_ +export %inline Located PDefinition where def.loc = def.loc_ public export data PPragma = @@ -192,7 +192,7 @@ data PPragma = %name PPragma prag %runElab derive "PPragma" [Eq, Ord, Show, PrettyVal] -export +export %inline Located PPragma where (PLogPush _ loc).loc = loc (PLogPop loc).loc = loc @@ -215,9 +215,9 @@ mutual %name PDecl decl %runElab deriveMutual ["PNamespace", "PDecl"] [Eq, Ord, Show, PrettyVal] -export Located PNamespace where ns.loc = ns.loc_ +export %inline Located PNamespace where ns.loc = ns.loc_ -export +export %inline Located PDecl where (PDef d).loc = d.loc (PNs ns).loc = ns.loc @@ -228,7 +228,7 @@ data PTopLevel = PD PDecl | PLoad String Loc %name PTopLevel t %runElab derive "PTopLevel" [Eq, Ord, Show, PrettyVal] -export +export %inline Located PTopLevel where (PD decl).loc = decl.loc (PLoad _ loc).loc = loc @@ -243,7 +243,7 @@ record PAttr where %name PAttr attr %runElab derive "PAttr" [Eq, Ord, Show, PrettyVal] -export Located PAttr where attr.loc = attr.loc_ +export %inline Located PAttr where attr.loc = attr.loc_ public export From 7883a3cae76f9dea58067f66515fc5996b339af8 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 12 Apr 2024 21:52:51 +0200 Subject: [PATCH 109/133] pretty printing fixes --- lib/Quox/Syntax/Term/Pretty.idr | 24 ++++++++---------------- lib/Quox/Typing/Context.idr | 4 ++-- 2 files changed, 10 insertions(+), 18 deletions(-) diff --git a/lib/Quox/Syntax/Term/Pretty.idr b/lib/Quox/Syntax/Term/Pretty.idr index a5d06b1..36d9320 100644 --- a/lib/Quox/Syntax/Term/Pretty.idr +++ b/lib/Quox/Syntax/Term/Pretty.idr @@ -229,7 +229,6 @@ prettyDTApps dnames tnames f xs = do private record CaseArm opts d n where constructor MkCaseArm - {0 dinner, ninner : Nat} pat : Doc opts dbinds : BTelescope d dinner -- 🍴 tbinds : BTelescope n ninner @@ -297,7 +296,7 @@ prettyCase_ : {opts : _} -> Doc opts -> Elim d n -> ScopeTerm d n -> List (CaseArm opts d n) -> Eff Pretty (Doc opts) prettyCase_ dnames tnames intro head ret body = do - head <- assert_total prettyElim dnames tnames head + head <- withPrec Outer $ assert_total prettyElim dnames tnames head ret <- prettyCaseRet dnames tnames ret bodys <- prettyCaseBody dnames tnames body return <- returnD; of_ <- ofD @@ -325,11 +324,6 @@ private LetExpr : Nat -> Nat -> Nat -> Type LetExpr d n n' = (Telescope (LetBinder d) n n', Term d n') -private -PrettyLetResult : LayoutOpts -> Nat -> Type -PrettyLetResult opts d = - Exists $ \n => (BContext n, Term d n, SnocList (Doc opts)) - -- [todo] factor out this and the untyped version somehow export splitLet : Telescope (LetBinder d) n n' -> Term d n' -> Exists (LetExpr d n) @@ -364,9 +358,10 @@ prettyLets dnames xs lets = snd <$> go lets where Nothing => do e <- withPrec Outer $ assert_total prettyElim dnames tnames e eq <- cstD; d <- askAt INDENT + inn <- inD pure $ ifMultiline - (hsep [hdr, eq, e]) - (vsep [hdr, indent d $ hsep [eq, e]]) + (hsep [hdr, eq, e, inn]) + (vsep [hdr, indent d $ hsep [eq, e, inn]]) go : forall b. Telescope (LetBinder d) a b -> Eff Pretty (BContext b, SnocList (Doc opts)) @@ -437,13 +432,10 @@ prettyDisp u = map Just $ hl Universe =<< ifUnicode (text $ superscript $ show u) (text $ "^" ++ show u) -prettyTerm dnames tnames (TYPE l _) = - case !(askAt FLAVOR) of - Unicode => do - star <- hl Syntax "★" - level <- hl Universe $ text $ superscript $ show l - pure $ hcat [star, level] - Ascii => [|hl Syntax "Type" <++> hl Universe (text $ show l)|] +prettyTerm dnames tnames (TYPE l _) = do + type <- hl Syntax . text =<< ifUnicode "★" "Type" + level <- prettyDisp l + pure $ maybe type (type <+>) level prettyTerm dnames tnames (IOState _) = ioStateD diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index fe8322c..7a54387 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -391,5 +391,5 @@ export prettyWhnfContext : {opts : _} -> WhnfContext d n -> Eff Pretty (Doc opts) prettyWhnfContext ctx = let Val n = ctx.termLen in - separateTight !commaD <$> - prettyTContext' ctx.dnames (replicate n "_") ctx.tnames ctx.tctx + sepSingle . exceptLast (<+> comma) . toList <$> + prettyTContext' ctx.dnames (replicate n "_") ctx.tnames ctx.tctx From 95a0b38d7489bdf260b220869a46712b04af6354 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Fri, 12 Apr 2024 22:00:08 +0200 Subject: [PATCH 110/133] update pretty-printing tests --- tests/Tests/PrettyTerm.idr | 24 ++++++++++++------------ 1 file changed, 12 insertions(+), 12 deletions(-) diff --git a/tests/Tests/PrettyTerm.idr b/tests/Tests/PrettyTerm.idr index b15cadc..551a444 100644 --- a/tests/Tests/PrettyTerm.idr +++ b/tests/Tests/PrettyTerm.idr @@ -105,8 +105,8 @@ tests = "pretty printing terms" :- [ ], "type universes" :- [ - testPrettyT [<] [<] (^TYPE 0) "★⁰" "Type 0", - testPrettyT [<] [<] (^TYPE 100) "★¹⁰⁰" "Type 100" + testPrettyT [<] [<] (^TYPE 0) "★" "Type", + testPrettyT [<] [<] (^TYPE 100) "★¹⁰⁰" "Type^100" ], "function types" :- [ @@ -120,8 +120,8 @@ tests = "pretty printing terms" :- [ "1.(x : A) -> B x", testPrettyT [<] [<] (^PiY Zero "A" (^TYPE 0) (^Arr Any (^BVT 0) (^BVT 0))) - "0.(A : ★⁰) → ω.A → A" - "0.(A : Type 0) -> #.A -> A", + "0.(A : ★) → ω.A → A" + "0.(A : Type) -> #.A -> A", testPrettyT [<] [<] (^Arr Any (^Arr Any (^FT "A" 0) (^FT "A" 0)) (^FT "A" 0)) "ω.(ω.A → A) → A" @@ -133,8 +133,8 @@ tests = "pretty printing terms" :- [ testPrettyT [<] [<] (^PiY Zero "P" (^Arr Zero (^FT "A" 0) (^TYPE 0)) (E $ ^App (^BV 0) (^FT "a" 0))) - "0.(P : 0.A → ★⁰) → P a" - "0.(P : 0.A -> Type 0) -> P a" + "0.(P : 0.A → ★) → P a" + "0.(P : 0.A -> Type) -> P a" ], "pair types" :- [ @@ -193,8 +193,8 @@ tests = "pretty printing terms" :- [ "case" :- [ testPrettyE [<] [<] (^CasePair One (^F "a" 0) (SN $ ^TYPE 1) (SN $ ^TYPE 0)) - "case1 a return ★¹ of { (_, _) ⇒ ★⁰ }" - "case1 a return Type 1 of { (_, _) => Type 0 }", + "case1 a return ★¹ of { (_, _) ⇒ ★ }" + "case1 a return Type^1 of { (_, _) => Type }", testPrettyT [<] [<] (^LamY "u" (E $ ^CaseEnum One (^F "u" 0) @@ -209,10 +209,10 @@ tests = "pretty printing terms" :- [ "type-case" :- [ testPrettyE [<] [<] - {label = "type-case ℕ ∷ ★⁰ return ★⁰ of { ⋯ }"} + {label = "type-case ℕ ∷ ★ return ★ of { ⋯ }"} (^TypeCase (^Ann (^NAT) (^TYPE 0)) (^TYPE 0) empty (^NAT)) - "type-case ℕ ∷ ★⁰ return ★⁰ of { _ ⇒ ℕ }" - "type-case Nat :: Type 0 return Type 0 of { _ => Nat }" + "type-case ℕ ∷ ★ return ★ of { _ ⇒ ℕ }" + "type-case Nat :: Type return Type of { _ => Nat }" ], skipWith "(todo: print user-written redundant annotations)" $ @@ -236,6 +236,6 @@ tests = "pretty printing terms" :- [ testPrettyE [<] [<] (^Ann (^Arr One (^FT "A" 0) (^FT "A" 0)) (^TYPE 7)) "(1.A → A) ∷ ★⁷" - "(1.A -> A) :: Type 7" + "(1.A -> A) :: Type^7" ] ] From 32b9fe124fe4809678ad6cdfbce7bcb519c5ea8c Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 14 Apr 2024 15:48:10 +0200 Subject: [PATCH 111/133] minor tweaks in Q.Typing.Context --- lib/Quox/Typing/Context.idr | 27 +++++++++++++++++---------- 1 file changed, 17 insertions(+), 10 deletions(-) diff --git a/lib/Quox/Typing/Context.idr b/lib/Quox/Typing/Context.idr index 7a54387..d231694 100644 --- a/lib/Quox/Typing/Context.idr +++ b/lib/Quox/Typing/Context.idr @@ -21,10 +21,6 @@ record LocalVar d n where term : Maybe (Term d n) -- if from a `let` %runElab deriveIndexed "LocalVar" [Show] -export -CanShift (LocalVar d) where - l // by = {type $= (// by), term $= map (// by)} l - namespace LocalVar export %inline letVar : (type, term : Term d n) -> LocalVar d n @@ -34,15 +30,25 @@ namespace LocalVar lamVar : (type : Term d n) -> LocalVar d n lamVar type = MkLocal {type, term = Nothing} - subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n - subD th = {type $= (// th), term $= map (// th)} + export %inline + mapVar : (Term d n -> Term d' n') -> LocalVar d n -> LocalVar d' n' + mapVar f = {type $= f, term $= map f} + export %inline + subD : DSubst d1 d2 -> LocalVar d1 n -> LocalVar d2 n + subD th = mapVar (// th) + + export %inline weakD : LocalVar d n -> LocalVar (S d) n weakD = subD $ shift 1 +export %inline CanShift (LocalVar d) where l // by = mapVar (// by) l +export %inline CanDSubst LocalVar where l // by = mapVar (// by) l +export %inline CanTSubst LocalVar where l // by = mapVar (// by) l + public export TContext : TermLike -TContext d = Context (\n => LocalVar d n) +TContext d = Context (LocalVar d) public export QOutput : Nat -> Type @@ -59,7 +65,7 @@ record TyContext d n where {auto dimLen : Singleton d} {auto termLen : Singleton n} dctx : DimEq d - dnames : BContext d + dnames : BContext d -- only used for printing tctx : TContext d n tnames : BContext n -- only used for printing qtys : QContext n -- only used for printing @@ -122,8 +128,9 @@ CtxExtensionLet0 d = Telescope ((BindName,) . LocalVar d) namespace TyContext public export %inline empty : TyContext 0 0 - empty = - MkTyContext {dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<]} + empty = MkTyContext { + dctx = new, dnames = [<], tctx = [<], tnames = [<], qtys = [<] + } public export %inline null : TyContext d n -> Bool From dd697ba56e7679a82130af4d1894e373537342c1 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 14 Apr 2024 15:48:43 +0200 Subject: [PATCH 112/133] add CheckBuiltin --- lib/Quox/CheckBuiltin.idr | 33 ++++++++++++++ lib/Quox/Syntax.idr | 1 + lib/Quox/Syntax/Builtin.idr | 27 ++++++++++++ lib/Quox/Typing.idr | 8 ++++ lib/Quox/Typing/Error.idr | 88 +++++++++++++++++++++++-------------- lib/quox-lib.ipkg | 2 + 6 files changed, 126 insertions(+), 33 deletions(-) create mode 100644 lib/Quox/CheckBuiltin.idr create mode 100644 lib/Quox/Syntax/Builtin.idr diff --git a/lib/Quox/CheckBuiltin.idr b/lib/Quox/CheckBuiltin.idr new file mode 100644 index 0000000..44b4f08 --- /dev/null +++ b/lib/Quox/CheckBuiltin.idr @@ -0,0 +1,33 @@ +||| check that special functions (e.g. `main`) have the expected type +module Quox.CheckBuiltin + +import Quox.Syntax +import Quox.Typing +import Quox.Whnf + +%default total + + +export covering +expectSingleEnum : Definitions -> TyContext d n -> SQty -> Loc -> + Term d n -> Eff Whnf () +expectSingleEnum defs ctx sg loc s = do + let err = delay $ ExpectedSingleEnum loc ctx.names s + cases <- wrapErr (const err) $ expectEnum defs ctx sg loc s + unless (length (SortedSet.toList cases) == 1) $ throw err + +||| `main` should have a type `1.IOState → {𝑎} × IOState`, +||| for some (single) tag `𝑎` +export covering +expectMainType : Definitions -> Term 0 0 -> Eff Whnf () +expectMainType defs ty = + wrapErr (WrongBuiltinType Main) $ do + let ctx = TyContext.empty + (qty, arg, res) <- expectPi defs ctx SZero ty.loc ty + expectEqualQ ty.loc qty One + expectIOState defs ctx SZero arg.loc arg + let ctx = extendTy qty res.name arg ctx + (ret, st) <- expectSig defs ctx SZero res.loc res.term + expectSingleEnum defs ctx SZero ret.loc ret + let ctx = extendTy qty st.name ret ctx + expectIOState defs ctx SZero st.loc st.term diff --git a/lib/Quox/Syntax.idr b/lib/Quox/Syntax.idr index 19bb4d0..7ee6b44 100644 --- a/lib/Quox/Syntax.idr +++ b/lib/Quox/Syntax.idr @@ -6,4 +6,5 @@ import public Quox.Syntax.Qty import public Quox.Syntax.Shift import public Quox.Syntax.Subst import public Quox.Syntax.Term +import public Quox.Syntax.Builtin import public Quox.Var diff --git a/lib/Quox/Syntax/Builtin.idr b/lib/Quox/Syntax/Builtin.idr new file mode 100644 index 0000000..09ac392 --- /dev/null +++ b/lib/Quox/Syntax/Builtin.idr @@ -0,0 +1,27 @@ +module Quox.Syntax.Builtin + +import Derive.Prelude +import Quox.PrettyValExtra +import Quox.Pretty +import Quox.Syntax.Term + + +%default total +%language ElabReflection + +public export +data Builtin += Main +%runElab derive "Builtin" [Eq, Ord, Show, PrettyVal] + +public export +builtinDesc : Builtin -> String +builtinDesc Main = "a function declared as #[main]" + +public export +builtinTypeDoc : {opts : LayoutOpts} -> Builtin -> Eff Pretty (Doc opts) +builtinTypeDoc Main = + prettyTerm [<] [<] $ + Pi One (IOState noLoc) + (SN $ Sig (Enum (fromList [!(ifUnicode "𝑎" "a")]) noLoc) + (SN (IOState noLoc)) noLoc) noLoc diff --git a/lib/Quox/Typing.idr b/lib/Quox/Typing.idr index 4b92a17..2ebed73 100644 --- a/lib/Quox/Typing.idr +++ b/lib/Quox/Typing.idr @@ -123,6 +123,10 @@ parameters (defs : Definitions) expectBOX : Term d n -> Eff fs (Qty, Term d n) expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty)) + export covering %inline + expectIOState : Term d n -> Eff fs () + expectIOState = expect ExpectedIOState `(IOState {}) `(()) + namespace EqContext parameters (ctx : EqContext n) (sg : SQty) (loc : Loc) @@ -174,3 +178,7 @@ parameters (defs : Definitions) export covering %inline expectBOX : Term 0 n -> Eff fs (Qty, Term 0 n) expectBOX = expect ExpectedBOX `(BOX {qty, ty, _}) `((qty, ty)) + + export covering %inline + expectIOState : Term 0 n -> Eff fs () + expectIOState = expect ExpectedIOState `(IOState {}) `(()) diff --git a/lib/Quox/Typing/Error.idr b/lib/Quox/Typing/Error.idr index c8133e1..502757c 100644 --- a/lib/Quox/Typing/Error.idr +++ b/lib/Quox/Typing/Error.idr @@ -2,6 +2,7 @@ module Quox.Typing.Error import Quox.Loc import Quox.Syntax +import Quox.Syntax.Builtin import Quox.Typing.Context import Quox.Typing.EqMode import Quox.Pretty @@ -62,18 +63,19 @@ namespace WhnfContext public export data Error -= ExpectedTYPE Loc (NameContexts d n) (Term d n) -| ExpectedPi Loc (NameContexts d n) (Term d n) -| ExpectedSig Loc (NameContexts d n) (Term d n) -| ExpectedEnum Loc (NameContexts d n) (Term d n) -| ExpectedEq Loc (NameContexts d n) (Term d n) -| ExpectedNAT Loc (NameContexts d n) (Term d n) -| ExpectedSTRING Loc (NameContexts d n) (Term d n) -| ExpectedBOX Loc (NameContexts d n) (Term d n) -| BadUniverse Loc Universe Universe -| TagNotIn Loc TagVal (SortedSet TagVal) -| BadCaseEnum Loc (SortedSet TagVal) (SortedSet TagVal) -| BadQtys Loc String (TyContext d n) (List (QOutput n, Term d n)) += ExpectedTYPE Loc (NameContexts d n) (Term d n) +| ExpectedPi Loc (NameContexts d n) (Term d n) +| ExpectedSig Loc (NameContexts d n) (Term d n) +| ExpectedEnum Loc (NameContexts d n) (Term d n) +| ExpectedEq Loc (NameContexts d n) (Term d n) +| ExpectedNAT Loc (NameContexts d n) (Term d n) +| ExpectedSTRING Loc (NameContexts d n) (Term d n) +| ExpectedBOX Loc (NameContexts d n) (Term d n) +| ExpectedIOState Loc (NameContexts d n) (Term d n) +| BadUniverse Loc Universe Universe +| TagNotIn Loc TagVal (SortedSet TagVal) +| BadCaseEnum Loc (SortedSet TagVal) (SortedSet TagVal) +| BadQtys Loc String (TyContext d n) (List (QOutput n, Term d n)) -- first term arg of ClashT is the type | ClashT Loc (EqContext n) EqMode (Term 0 n) (Term 0 n) (Term 0 n) @@ -86,6 +88,9 @@ data Error | NotType Loc (TyContext d n) (Term d n) | WrongType Loc (EqContext n) (Term 0 n) (Term 0 n) +| WrongBuiltinType Builtin Error +| ExpectedSingleEnum Loc (NameContexts d n) (Term d n) + | MissingEnumArm Loc TagVal (List TagVal) -- extra context @@ -122,27 +127,30 @@ ErrorEff = Except Error export Located Error where - (ExpectedTYPE loc _ _).loc = loc - (ExpectedPi loc _ _).loc = loc - (ExpectedSig loc _ _).loc = loc - (ExpectedEnum loc _ _).loc = loc - (ExpectedEq loc _ _).loc = loc - (ExpectedNAT loc _ _).loc = loc - (ExpectedSTRING loc _ _).loc = loc - (ExpectedBOX loc _ _).loc = loc - (BadUniverse loc _ _).loc = loc - (TagNotIn loc _ _).loc = loc - (BadCaseEnum loc _ _).loc = loc - (BadQtys loc _ _ _).loc = loc - (ClashT loc _ _ _ _ _).loc = loc - (ClashTy loc _ _ _ _).loc = loc - (ClashE loc _ _ _ _).loc = loc - (ClashU loc _ _ _).loc = loc - (ClashQ loc _ _).loc = loc - (NotInScope loc _).loc = loc - (NotType loc _ _).loc = loc - (WrongType loc _ _ _).loc = loc - (MissingEnumArm loc _ _).loc = loc + (ExpectedTYPE loc _ _).loc = loc + (ExpectedPi loc _ _).loc = loc + (ExpectedSig loc _ _).loc = loc + (ExpectedEnum loc _ _).loc = loc + (ExpectedEq loc _ _).loc = loc + (ExpectedNAT loc _ _).loc = loc + (ExpectedSTRING loc _ _).loc = loc + (ExpectedBOX loc _ _).loc = loc + (ExpectedIOState loc _ _).loc = loc + (BadUniverse loc _ _).loc = loc + (TagNotIn loc _ _).loc = loc + (BadCaseEnum loc _ _).loc = loc + (BadQtys loc _ _ _).loc = loc + (ClashT loc _ _ _ _ _).loc = loc + (ClashTy loc _ _ _ _).loc = loc + (ClashE loc _ _ _ _).loc = loc + (ClashU loc _ _ _).loc = loc + (ClashQ loc _ _).loc = loc + (NotInScope loc _).loc = loc + (NotType loc _ _).loc = loc + (WrongType loc _ _ _).loc = loc + (WrongBuiltinType _ err).loc = err.loc + (ExpectedSingleEnum loc _ _).loc = loc + (MissingEnumArm loc _ _).loc = loc (WhileChecking _ _ _ _ err).loc = err.loc (WhileCheckingTy _ _ _ err).loc = err.loc (WhileInferring _ _ _ err).loc = err.loc @@ -306,6 +314,10 @@ parameters {opts : LayoutOpts} (showContext : Bool) hangDSingle "expected a box type, but got" !(prettyTerm ctx.dnames ctx.tnames s) + ExpectedIOState _ ctx s => + hangDSingle "expected IOState, but got" + !(prettyTerm ctx.dnames ctx.tnames s) + BadUniverse _ k l => pure $ sep ["the universe level" <++> !(prettyUniverse k), "is not strictly less than" <++> !(prettyUniverse l)] @@ -364,6 +376,16 @@ parameters {opts : LayoutOpts} (showContext : Bool) [hangDSingle "the term" !(prettyTerm [<] ctx.tnames s), hangDSingle "cannot have type" !(prettyTerm [<] ctx.tnames ty)] + WrongBuiltinType b err => pure $ + vappend + (sep [sep ["when checking", text $ builtinDesc b], + sep ["has type", !(builtinTypeDoc b)]]) + !(prettyErrorNoLoc err) + + ExpectedSingleEnum _ ctx s => + hangDSingle "expected an enumeration type with one case, but got" + !(prettyTerm ctx.dnames ctx.tnames s) + MissingEnumArm _ tag tags => pure $ sep [hsep ["the tag", !(prettyTag tag), "is not contained in"], !(prettyTerm [<] [<] $ Enum (fromList tags) noLoc)] diff --git a/lib/quox-lib.ipkg b/lib/quox-lib.ipkg index 62b4ee6..f715226 100644 --- a/lib/quox-lib.ipkg +++ b/lib/quox-lib.ipkg @@ -26,6 +26,7 @@ modules = Quox.OPE, Quox.Pretty, Quox.Syntax, + Quox.Syntax.Builtin, Quox.Syntax.Dim, Quox.Syntax.DimEq, Quox.Syntax.Qty, @@ -54,6 +55,7 @@ modules = Quox.Typing.Error, Quox.Typing, Quox.Typechecker, + Quox.CheckBuiltin, Quox.Parser.Lexer, Quox.Parser.Syntax, Quox.Parser.Parser, From b7dc5ffdc4d1328f405547437aced359fc3f0b73 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 14 Apr 2024 16:20:40 +0200 Subject: [PATCH 113/133] add check for #[main] type --- lib/Quox/Parser/FromParser.idr | 19 +++++++++++++++---- 1 file changed, 15 insertions(+), 4 deletions(-) diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index ddf8671..5a4edc7 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -8,6 +8,7 @@ import Quox.Parser.Syntax import Quox.Parser.Parser import public Quox.Parser.LoadFile import Quox.Typechecker +import Quox.CheckBuiltin import Data.List import Data.Maybe @@ -333,6 +334,13 @@ liftTC tc = runEff tc $ with Union.(::) \g => send g, \g => send g] +private +liftWhnf : Eff Whnf a -> Eff FromParserPure a +liftWhnf tc = runEff tc $ with Union.(::) + [handleExcept $ \e => throw $ WrapTypeError e, + \g => send g, + \g => send g] + private addDef : Has DefsState fs => Name -> Definition -> Eff fs NDefinition addDef name def = do @@ -344,7 +352,8 @@ export covering fromPDef : PDefinition -> Eff FromParserPure NDefinition fromPDef def = do name <- fromPBaseNameNS def.name - when !(getsAt DEFS $ isJust . lookup name) $ do + defs <- getAt DEFS + when (isJust $ lookup name defs) $ do throw $ AlreadyExists def.loc name gqty <- globalPQty def.qty let sqty = globalToSubj gqty @@ -352,17 +361,19 @@ fromPDef def = do PConcrete ptype pterm => do type <- traverse fromPTerm ptype term <- fromPTerm pterm - case type of + type <- case type of Just type => do ignore $ liftTC $ do checkTypeC empty type Nothing checkC empty sqty term type - addDef name $ mkDef gqty type term def.scheme def.main def.loc + pure type Nothing => do let E elim = term | _ => throw $ AnnotationNeeded term.loc empty term res <- liftTC $ inferC empty sqty elim - addDef name $ mkDef gqty res.type term def.scheme def.main def.loc + pure res.type + when def.main $ liftWhnf $ expectMainType defs type + addDef name $ mkDef gqty type term def.scheme def.main def.loc PPostulate ptype => do type <- fromPTerm ptype addDef name $ mkPostulate gqty type def.scheme def.main def.loc From 88231549732606721b887f50adbfce373cdbc9aa Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 14 Apr 2024 20:47:59 +0200 Subject: [PATCH 114/133] add golden test stuff --- .gitignore | 2 ++ golden-tests/Tests.idr | 15 +++++++++++++++ golden-tests/quox-golden-tests.ipkg | 4 ++++ golden-tests/run-tests.sh | 10 ++++++++++ golden-tests/tests/empty/empty.quox | 0 golden-tests/tests/empty/expected | 0 golden-tests/tests/empty/run | 2 ++ golden-tests/tests/file-not-found/expected | 3 +++ golden-tests/tests/file-not-found/run | 2 ++ golden-tests/tests/hello/expected | 12 ++++++++++++ golden-tests/tests/hello/hello.quox | 7 +++++++ golden-tests/tests/hello/run | 2 ++ golden-tests/tests/ill-typed-main/expected | 3 +++ .../tests/ill-typed-main/ill-typed-main.quox | 2 ++ golden-tests/tests/ill-typed-main/run | 2 ++ golden-tests/tests/it-5/expected | 4 ++++ golden-tests/tests/it-5/five.quox | 1 + golden-tests/tests/it-5/run | 2 ++ golden-tests/tests/lib.sh | 18 ++++++++++++++++++ golden-tests/tests/load/expected | 16 ++++++++++++++++ golden-tests/tests/load/lib.quox | 8 ++++++++ golden-tests/tests/load/main.quox | 4 ++++ golden-tests/tests/load/run | 2 ++ pack.toml | 5 +++++ 24 files changed, 126 insertions(+) create mode 100644 golden-tests/Tests.idr create mode 100644 golden-tests/quox-golden-tests.ipkg create mode 100755 golden-tests/run-tests.sh create mode 100644 golden-tests/tests/empty/empty.quox create mode 100644 golden-tests/tests/empty/expected create mode 100644 golden-tests/tests/empty/run create mode 100644 golden-tests/tests/file-not-found/expected create mode 100644 golden-tests/tests/file-not-found/run create mode 100644 golden-tests/tests/hello/expected create mode 100644 golden-tests/tests/hello/hello.quox create mode 100644 golden-tests/tests/hello/run create mode 100644 golden-tests/tests/ill-typed-main/expected create mode 100644 golden-tests/tests/ill-typed-main/ill-typed-main.quox create mode 100644 golden-tests/tests/ill-typed-main/run create mode 100644 golden-tests/tests/it-5/expected create mode 100644 golden-tests/tests/it-5/five.quox create mode 100644 golden-tests/tests/it-5/run create mode 100644 golden-tests/tests/lib.sh create mode 100644 golden-tests/tests/load/expected create mode 100644 golden-tests/tests/load/lib.quox create mode 100644 golden-tests/tests/load/main.quox create mode 100644 golden-tests/tests/load/run diff --git a/.gitignore b/.gitignore index 221f1d8..683c569 100644 --- a/.gitignore +++ b/.gitignore @@ -5,3 +5,5 @@ result *~ quox quox-tests +quox-golden-tests/tests/*/output +quox-golden-tests/tests/*/*.ss diff --git a/golden-tests/Tests.idr b/golden-tests/Tests.idr new file mode 100644 index 0000000..60c7895 --- /dev/null +++ b/golden-tests/Tests.idr @@ -0,0 +1,15 @@ +module Tests + +import Test.Golden +import Language.Reflection +import System +import System.Path + +%language ElabReflection + +projDir = %runElab idrisDir ProjectDir +testDir = projDir "tests" + +tests = testsInDir { poolName = "quox golden tests", dirName = testDir } + +main = runner [!tests] diff --git a/golden-tests/quox-golden-tests.ipkg b/golden-tests/quox-golden-tests.ipkg new file mode 100644 index 0000000..cd89728 --- /dev/null +++ b/golden-tests/quox-golden-tests.ipkg @@ -0,0 +1,4 @@ +package quox-golden-tests +depends = quox, contrib, test +executable = quox-golden-tests +main = Tests diff --git a/golden-tests/run-tests.sh b/golden-tests/run-tests.sh new file mode 100755 index 0000000..67d86a1 --- /dev/null +++ b/golden-tests/run-tests.sh @@ -0,0 +1,10 @@ +#!/bin/bash + +set -e + +quox="$PWD/../exe/build/exec/quox" +run_tests="$PWD/build/exec/quox-golden-tests" +test -f "$quox" || pack build quox +test -f "$run_tests" || pack build quox-golden-tests + +"$run_tests" "$quox" "$@" diff --git a/golden-tests/tests/empty/empty.quox b/golden-tests/tests/empty/empty.quox new file mode 100644 index 0000000..e69de29 diff --git a/golden-tests/tests/empty/expected b/golden-tests/tests/empty/expected new file mode 100644 index 0000000..e69de29 diff --git a/golden-tests/tests/empty/run b/golden-tests/tests/empty/run new file mode 100644 index 0000000..195c208 --- /dev/null +++ b/golden-tests/tests/empty/run @@ -0,0 +1,2 @@ +. ../lib.sh +scheme "$1" empty.quox diff --git a/golden-tests/tests/file-not-found/expected b/golden-tests/tests/file-not-found/expected new file mode 100644 index 0000000..33ee368 --- /dev/null +++ b/golden-tests/tests/file-not-found/expected @@ -0,0 +1,3 @@ +no location: +couldn't load file nonexistent.quox +File Not Found diff --git a/golden-tests/tests/file-not-found/run b/golden-tests/tests/file-not-found/run new file mode 100644 index 0000000..b164730 --- /dev/null +++ b/golden-tests/tests/file-not-found/run @@ -0,0 +1,2 @@ +. ../lib.sh +check "$1" nonexistent.quox diff --git a/golden-tests/tests/hello/expected b/golden-tests/tests/hello/expected new file mode 100644 index 0000000..7aea232 --- /dev/null +++ b/golden-tests/tests/hello/expected @@ -0,0 +1,12 @@ +0.IO : 1.★ → ★ +ω.print : 1.String → IO {ok} +ω.main : IO {ok} +IO = □ +print = scheme:(lambda (str) (builtin-io (display str) (newline))) +#[main] main = print "hello 🐉" +;; IO erased +(define print + (lambda (str) (builtin-io (display str) (newline)))) +(define main + (print "hello \x1f409;")) +hello 🐉 diff --git a/golden-tests/tests/hello/hello.quox b/golden-tests/tests/hello/hello.quox new file mode 100644 index 0000000..3b45067 --- /dev/null +++ b/golden-tests/tests/hello/hello.quox @@ -0,0 +1,7 @@ +def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState + +#[compile-scheme "(lambda (str) (builtin-io (display str) (newline)))"] +postulate print : String → IO {ok} + +#[main] +def main = print "hello 🐉" diff --git a/golden-tests/tests/hello/run b/golden-tests/tests/hello/run new file mode 100644 index 0000000..db7f834 --- /dev/null +++ b/golden-tests/tests/hello/run @@ -0,0 +1,2 @@ +. ../lib.sh +compile_run "$1" hello.quox hello.ss diff --git a/golden-tests/tests/ill-typed-main/expected b/golden-tests/tests/ill-typed-main/expected new file mode 100644 index 0000000..25498fb --- /dev/null +++ b/golden-tests/tests/ill-typed-main/expected @@ -0,0 +1,3 @@ +ill-typed-main.quox:1:11-1:12: + when checking a function declared as #[main] has type 1.IOState → {𝑎} × IOState + expected a function type, but got ℕ diff --git a/golden-tests/tests/ill-typed-main/ill-typed-main.quox b/golden-tests/tests/ill-typed-main/ill-typed-main.quox new file mode 100644 index 0000000..9ead5b5 --- /dev/null +++ b/golden-tests/tests/ill-typed-main/ill-typed-main.quox @@ -0,0 +1,2 @@ +#[main] +def main : ℕ = 5 diff --git a/golden-tests/tests/ill-typed-main/run b/golden-tests/tests/ill-typed-main/run new file mode 100644 index 0000000..5ad1fb7 --- /dev/null +++ b/golden-tests/tests/ill-typed-main/run @@ -0,0 +1,2 @@ +. ../lib.sh +check "$1" ill-typed-main.quox diff --git a/golden-tests/tests/it-5/expected b/golden-tests/tests/it-5/expected new file mode 100644 index 0000000..3644760 --- /dev/null +++ b/golden-tests/tests/it-5/expected @@ -0,0 +1,4 @@ +ω.five : ℕ +five = 5 +(define five + 5) diff --git a/golden-tests/tests/it-5/five.quox b/golden-tests/tests/it-5/five.quox new file mode 100644 index 0000000..365c1a7 --- /dev/null +++ b/golden-tests/tests/it-5/five.quox @@ -0,0 +1 @@ +def five : ℕ = 5 diff --git a/golden-tests/tests/it-5/run b/golden-tests/tests/it-5/run new file mode 100644 index 0000000..bb90a15 --- /dev/null +++ b/golden-tests/tests/it-5/run @@ -0,0 +1,2 @@ +. ../lib.sh +scheme "$1" five.quox diff --git a/golden-tests/tests/lib.sh b/golden-tests/tests/lib.sh new file mode 100644 index 0000000..7dbfb7b --- /dev/null +++ b/golden-tests/tests/lib.sh @@ -0,0 +1,18 @@ +FLAGS="--dump-check - --dump-erase - --dump-scheme - --color=none --width=100000" + +check() { + $1 $FLAGS "$2" -P check 2>&1 +} + +erase() { + $1 $FLAGS "$2" -P erase 2>&1 +} + +scheme() { + $1 $FLAGS "$2" -P scheme 2>&1 +} + +compile_run() { + $1 $FLAGS "$2" -o "$3" 2>&1 + chezscheme --program "$3" +} diff --git a/golden-tests/tests/load/expected b/golden-tests/tests/load/expected new file mode 100644 index 0000000..b7dd6c9 --- /dev/null +++ b/golden-tests/tests/load/expected @@ -0,0 +1,16 @@ +0.lib.IO : 1.★ → ★ +ω.lib.print : 1.String → lib.IO {ok} +ω.lib.main : lib.IO {ok} +ω.main : lib.IO {ok} +lib.IO = □ +lib.print = scheme:(lambda (str) (builtin-io (display str) (newline))) +lib.main = lib.print "hello 🐉" +#[main] main = lib.main +;; lib.IO erased +(define lib.print + (lambda (str) (builtin-io (display str) (newline)))) +(define lib.main + (lib.print "hello \x1f409;")) +(define main + lib.main) +hello 🐉 diff --git a/golden-tests/tests/load/lib.quox b/golden-tests/tests/load/lib.quox new file mode 100644 index 0000000..5ba4344 --- /dev/null +++ b/golden-tests/tests/load/lib.quox @@ -0,0 +1,8 @@ +namespace lib { +def0 IO : ★ → ★ = λ A ⇒ IOState → A × IOState + +#[compile-scheme "(lambda (str) (builtin-io (display str) (newline)))"] +postulate print : String → IO {ok} + +def main = print "hello 🐉" +} diff --git a/golden-tests/tests/load/main.quox b/golden-tests/tests/load/main.quox new file mode 100644 index 0000000..c53d261 --- /dev/null +++ b/golden-tests/tests/load/main.quox @@ -0,0 +1,4 @@ +load "lib.quox" + +#[main] +def main = lib.main diff --git a/golden-tests/tests/load/run b/golden-tests/tests/load/run new file mode 100644 index 0000000..677a01b --- /dev/null +++ b/golden-tests/tests/load/run @@ -0,0 +1,2 @@ +. ../lib.sh +compile_run "$1" main.quox load.ss diff --git a/pack.toml b/pack.toml index 61d7373..c323cad 100644 --- a/pack.toml +++ b/pack.toml @@ -20,3 +20,8 @@ ipkg = "quox.ipkg" type = "local" path = "./tests" ipkg = "quox-tests.ipkg" + +[custom.all.quox-golden-tests] +type = "local" +path = "./golden-tests" +ipkg = "quox-golden-tests.ipkg" From 3f7031c61370027dff483d7ebf11d88a97c4bd8e Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 15 Apr 2024 20:54:23 +0200 Subject: [PATCH 115/133] pack bump --- pack.toml | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/pack.toml b/pack.toml index c323cad..2673417 100644 --- a/pack.toml +++ b/pack.toml @@ -1,4 +1,4 @@ -collection = "nightly-240326" +collection = "nightly-240413" [custom.all.tap] type = "git" From ddc2422ffb2f137acdf4fde37a85aa90f2d19795 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 15 Apr 2024 22:27:55 +0200 Subject: [PATCH 116/133] fix .gitignore --- .gitignore | 4 ++-- 1 file changed, 2 insertions(+), 2 deletions(-) diff --git a/.gitignore b/.gitignore index 683c569..0b7a7aa 100644 --- a/.gitignore +++ b/.gitignore @@ -5,5 +5,5 @@ result *~ quox quox-tests -quox-golden-tests/tests/*/output -quox-golden-tests/tests/*/*.ss +golden-tests/tests/*/output +golden-tests/tests/*/*.ss From 67c825ab396751b264a7f8613b2c37714edd917e Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 15 Apr 2024 22:40:20 +0200 Subject: [PATCH 117/133] add coercion regularity to the equality checker (not to whnf) --- lib/Quox/Equal.idr | 86 +++++++++++++++++++++++++++++----------------- 1 file changed, 54 insertions(+), 32 deletions(-) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 796b6ff..9506a72 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -8,6 +8,7 @@ import Quox.EffExtra import Data.List1 import Data.Maybe +import Data.Either %default total @@ -527,7 +528,7 @@ namespace Elim EqualElim : List (Type -> Type) EqualElim = InnerErrEff :: EqualInner - private covering + private covering %inline computeElimTypeE : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) -> (e : Elim 0 n) -> (0 ne : NotRedexEq defs ctx sg e) => @@ -535,14 +536,18 @@ namespace Elim computeElimTypeE defs ectx sg e = lift $ computeElimType defs (toWhnfContext ectx) sg e - private + private %inline putError : Has InnerErrEff fs => Error -> Eff fs () putError err = modifyAt InnerErr (<|> Just err) - private + private %inline try : Eff EqualInner () -> Eff EqualElim () try act = lift $ catch putError $ lift act {fs' = EqualElim} + private %inline + nested : Eff EqualInner a -> Eff EqualElim (Either Error a) + nested act = lift $ runExcept act + private covering %inline clashE : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) -> (e, f : Elim 0 n) -> (0 nf : NotRedexEq defs ctx sg f) => @@ -580,6 +585,52 @@ namespace Elim (0 nf : NotRedexEq defs ctx sg f) -> Eff EqualElim (Term 0 n) + -- (no neutral dim apps or comps in a closed dctx) + compare0Inner' _ _ _ (DApp _ (K {}) _) _ ne _ = + void $ absurd $ noOr2 $ noOr2 ne + compare0Inner' _ _ _ _ (DApp _ (K {}) _) _ nf = + void $ absurd $ noOr2 $ noOr2 nf + compare0Inner' _ _ _ (Comp {r = K {}, _}) _ ne _ = void $ absurd $ noOr2 ne + compare0Inner' _ _ _ (Comp {r = B i _, _}) _ _ _ = absurd i + compare0Inner' _ _ _ _ (Comp {r = K {}, _}) _ nf = void $ absurd $ noOr2 nf + + -- Ψ | Γ ⊢ A‹p₁/𝑖› <: B‹p₂/𝑖› + -- Ψ | Γ ⊢ A‹q₁/𝑖› <: B‹q₂/𝑖› + -- Ψ | Γ ⊢ s <: t ⇐ B‹p₂/𝑖› + -- ----------------------------------------------------------- + -- Ψ | Γ ⊢ coe [𝑖 ⇒ A] @p₁ @q₁ s + -- <: coe [𝑖 ⇒ B] @p₂ @q₂ t ⇒ B‹q₂/𝑖› + compare0Inner' defs ctx sg (Coe ty1 p1 q1 val1 _) + (Coe ty2 p2 q2 val2 _) ne nf = do + let ty1p = dsub1 ty1 p1; ty2p = dsub1 ty2 p2 + ty1q = dsub1 ty1 q1; ty2q = dsub1 ty2 q2 + (ty_p, ty_q) <- bigger (ty1p, ty1q) (ty2p, ty2q) + try $ do + compareType defs ctx ty1p ty2p + compareType defs ctx ty1q ty2q + Term.compare0 defs ctx sg ty_p val1 val2 + pure $ ty_q + + -- an adaptation of the rule + -- + -- Ψ | Γ ⊢ A‹0/𝑖› = A‹1/𝑖› ⇐ ★ + -- ----------------------------------------------------- + -- Ψ | Γ ⊢ coe (𝑖 ⇒ A) @p @q s ⇝ (s ∷ A‹1/𝑖›) ⇒ A‹1/𝑖› + -- + -- it's here so that whnf doesn't have to depend on the equality checker + compare0Inner' defs ctx sg (Coe ty p q val loc) f _ _ = do + tyEq <- nested $ local_ Equal $ compareType defs ctx ty.zero ty.one + if isRight tyEq + then compare0Inner defs ctx sg (Ann val (dsub1 ty q) loc) f + else clashE defs ctx sg (Coe ty p q val loc) f + + -- symmetric version of the above + compare0Inner' defs ctx sg e (Coe ty p q val loc) _ _ = do + tyEq <- nested $ local_ Equal $ compareType defs ctx ty.zero ty.one + if isRight tyEq + then compare0Inner defs ctx sg e (Ann val (dsub1 ty q) loc) + else clashE defs ctx sg e (Coe ty p q val loc) + compare0Inner' defs ctx sg e@(F {}) f _ _ = do if e == f then computeElimTypeE defs ctx sg f else clashE defs ctx sg e f @@ -711,12 +762,6 @@ namespace Elim pure $ sub1 eret e compare0Inner' defs ctx sg e@(CaseBox {}) f _ _ = clashE defs ctx sg e f - -- (no neutral dim apps in a closed dctx) - compare0Inner' _ _ _ (DApp _ (K {}) _) _ ne _ = - void $ absurd $ noOr2 $ noOr2 ne - compare0Inner' _ _ _ _ (DApp _ (K {}) _) _ nf = - void $ absurd $ noOr2 $ noOr2 nf - -- Ψ | Γ ⊢ s <: t : B -- -------------------------------- -- Ψ | Γ ⊢ (s ∷ A) <: (t ∷ B) ⇒ B @@ -727,29 +772,6 @@ namespace Elim try $ Term.compare0 defs ctx sg ty s t pure ty - -- Ψ | Γ ⊢ A‹p₁/𝑖› <: B‹p₂/𝑖› - -- Ψ | Γ ⊢ A‹q₁/𝑖› <: B‹q₂/𝑖› - -- Ψ | Γ ⊢ s <: t ⇐ B‹p₂/𝑖› - -- ----------------------------------------------------------- - -- Ψ | Γ ⊢ coe [𝑖 ⇒ A] @p₁ @q₁ s - -- <: coe [𝑖 ⇒ B] @p₂ @q₂ t ⇒ B‹q₂/𝑖› - compare0Inner' defs ctx sg (Coe ty1 p1 q1 val1 _) - (Coe ty2 p2 q2 val2 _) ne nf = do - let ty1p = dsub1 ty1 p1; ty2p = dsub1 ty2 p2 - ty1q = dsub1 ty1 q1; ty2q = dsub1 ty2 q2 - (ty_p, ty_q) <- bigger (ty1p, ty1q) (ty2p, ty2q) - try $ do - compareType defs ctx ty1p ty2p - compareType defs ctx ty1q ty2q - Term.compare0 defs ctx sg ty_p val1 val2 - pure $ ty_q - compare0Inner' defs ctx sg e@(Coe {}) f _ _ = clashE defs ctx sg e f - - -- (no neutral compositions in a closed dctx) - compare0Inner' _ _ _ (Comp {r = K {}, _}) _ ne _ = void $ absurd $ noOr2 ne - compare0Inner' _ _ _ (Comp {r = B i _, _}) _ _ _ = absurd i - compare0Inner' _ _ _ _ (Comp {r = K {}, _}) _ nf = void $ absurd $ noOr2 nf - -- (type case equality purely structural) compare0Inner' defs ctx sg (TypeCase ty1 ret1 arms1 def1 eloc) (TypeCase ty2 ret2 arms2 def2 floc) ne _ = From 7f72ed56fbc6840ef2e463ca4b3cf41f9bf12e62 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 15 Apr 2024 22:40:58 +0200 Subject: [PATCH 118/133] add test for regularity --- golden-tests/tests/regularity/expected | 1 + golden-tests/tests/regularity/regularity.quox | 12 ++++++++++++ golden-tests/tests/regularity/run | 2 ++ 3 files changed, 15 insertions(+) create mode 100644 golden-tests/tests/regularity/expected create mode 100644 golden-tests/tests/regularity/regularity.quox create mode 100644 golden-tests/tests/regularity/run diff --git a/golden-tests/tests/regularity/expected b/golden-tests/tests/regularity/expected new file mode 100644 index 0000000..5b9502a --- /dev/null +++ b/golden-tests/tests/regularity/expected @@ -0,0 +1 @@ +0.reggie : 1.(A : ★) → 1.(AA : A ≡ A : ★) → 1.(s : A) → 1.(P : 1.A → ★) → 1.(P (coe (𝑖 ⇒ AA @𝑖) @0 @1 s)) → P s diff --git a/golden-tests/tests/regularity/regularity.quox b/golden-tests/tests/regularity/regularity.quox new file mode 100644 index 0000000..9a06dc7 --- /dev/null +++ b/golden-tests/tests/regularity/regularity.quox @@ -0,0 +1,12 @@ +-- this definition depends on coercion regularity in xtt. which is this +-- (adapted to quox): +-- +-- Ψ | Γ ⊢ 0 · A‹0/𝑖› = A‹1/𝑖› ⇐ ★ +-- --------------------------------------------------------- +-- Ψ | Γ ⊢ π · coe (𝑖 ⇒ A) @p @q s ⇝ (s ∷ A‹1/𝑖›) ⇒ A‹1/𝑖› +-- +-- otherwise, the types P (coe ⋯ s) and P s are incompatible + +def0 reggie : (A : ★) → (AA : A ≡ A : ★) → (s : A) → + (P : A → ★) → P (coe (𝑖 ⇒ AA @𝑖) s) → P s = + λ A AA s P p ⇒ p diff --git a/golden-tests/tests/regularity/run b/golden-tests/tests/regularity/run new file mode 100644 index 0000000..cbfda48 --- /dev/null +++ b/golden-tests/tests/regularity/run @@ -0,0 +1,2 @@ +. ../lib.sh +check "$1" regularity.quox From c9f66bb6af96302d843bad7fd1885d1625992e3f Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Thu, 18 Apr 2024 11:49:19 +0200 Subject: [PATCH 119/133] minor refactor --- lib/Quox/Equal.idr | 46 ++++++++++++++++++++++++---------------------- 1 file changed, 24 insertions(+), 22 deletions(-) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 9506a72..5d5f3db 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -30,6 +30,10 @@ export %inline mode : Has EqModeState fs => Eff fs EqMode mode = get +private %inline +withEqual : Has EqModeState fs => Eff fs a -> Eff fs a +withEqual = local_ Equal + parameters (loc : Loc) (ctx : EqContext n) private %inline @@ -242,7 +246,7 @@ namespace Term (E _, _) => wrongType t.loc ctx ty t _ => wrongType s.loc ctx ty s - compare0' defs ctx sg ty@(Pi {qty, arg, res, _}) s t = local_ Equal $ + compare0' defs ctx sg ty@(Pi {qty, arg, res, _}) s t = withEqual $ -- Γ ⊢ A empty -- ------------------------------------------- -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ (π·x : A) → B @@ -276,7 +280,7 @@ namespace Term eta loc e (S _ (N _)) = clashT loc ctx ty s t eta _ e (S _ (Y b)) = compare0 defs ctx' sg res.term (toLamBody e) b - compare0' defs ctx sg ty@(Sig {fst, snd, _}) s t = local_ Equal $ + compare0' defs ctx sg ty@(Sig {fst, snd, _}) s t = withEqual $ case (s, t) of -- Γ ⊢ s₁ = t₁ ⇐ A Γ ⊢ s₂ = t₂ ⇐ B{s₁/x} -- -------------------------------------------- @@ -302,7 +306,7 @@ namespace Term compare0 defs ctx sg (sub1 snd (Ann s fst s.loc)) (E $ Snd e e.loc) t SOne => clashT loc ctx ty s t - compare0' defs ctx sg ty@(Enum cases _) s t = local_ Equal $ + compare0' defs ctx sg ty@(Enum cases _) s t = withEqual $ -- η for empty & singleton enums if length (SortedSet.toList cases) <= 1 then pure () else case (s, t) of @@ -327,7 +331,7 @@ namespace Term -- Γ ⊢ e = f ⇐ Eq [i ⇒ A] s t pure () - compare0' defs ctx sg nat@(NAT {}) s t = local_ Equal $ + compare0' defs ctx sg nat@(NAT {}) s t = withEqual $ case (s, t) of -- --------------- -- Γ ⊢ n = n ⇐ ℕ @@ -354,7 +358,7 @@ namespace Term (E _, t) => wrongType t.loc ctx nat t (s, _) => wrongType s.loc ctx nat s - compare0' defs ctx sg str@(STRING {}) s t = local_ Equal $ + compare0' defs ctx sg str@(STRING {}) s t = withEqual $ case (s, t) of (Str x _, Str y _) => unless (x == y) $ clashT s.loc ctx str s t @@ -367,7 +371,7 @@ namespace Term (E _, _) => wrongType t.loc ctx str t _ => wrongType s.loc ctx str s - compare0' defs ctx sg bty@(BOX q ty {}) s t = local_ Equal $ + compare0' defs ctx sg bty@(BOX q ty {}) s t = withEqual $ case (s, t) of -- Γ ⊢ s = t ⇐ A -- ----------------------- @@ -445,7 +449,7 @@ compareType' defs ctx (Eq {ty = sTy, l = sl, r = sr, _}) compareType defs (extendDim sTy.name Zero ctx) sTy.zero tTy.zero compareType defs (extendDim sTy.name One ctx) sTy.one tTy.one ty <- bigger sTy tTy - local_ Equal $ do + withEqual $ do Term.compare0 defs ctx SZero ty.zero sl tl Term.compare0 defs ctx SZero ty.one sr tr @@ -545,8 +549,8 @@ namespace Elim try act = lift $ catch putError $ lift act {fs' = EqualElim} private %inline - nested : Eff EqualInner a -> Eff EqualElim (Either Error a) - nested act = lift $ runExcept act + succeeds : Eff EqualInner a -> Eff EqualElim Bool + succeeds act = lift $ map isRight $ runExcept act private covering %inline clashE : (defs : Definitions) -> (ctx : EqContext n) -> (sg : SQty) -> @@ -618,16 +622,14 @@ namespace Elim -- Ψ | Γ ⊢ coe (𝑖 ⇒ A) @p @q s ⇝ (s ∷ A‹1/𝑖›) ⇒ A‹1/𝑖› -- -- it's here so that whnf doesn't have to depend on the equality checker - compare0Inner' defs ctx sg (Coe ty p q val loc) f _ _ = do - tyEq <- nested $ local_ Equal $ compareType defs ctx ty.zero ty.one - if isRight tyEq + compare0Inner' defs ctx sg (Coe ty p q val loc) f _ _ = + if !(succeeds $ withEqual $ compareType defs ctx ty.zero ty.one) then compare0Inner defs ctx sg (Ann val (dsub1 ty q) loc) f else clashE defs ctx sg (Coe ty p q val loc) f -- symmetric version of the above - compare0Inner' defs ctx sg e (Coe ty p q val loc) _ _ = do - tyEq <- nested $ local_ Equal $ compareType defs ctx ty.zero ty.one - if isRight tyEq + compare0Inner' defs ctx sg e (Coe ty p q val loc) _ _ = + if !(succeeds $ withEqual $ compareType defs ctx ty.zero ty.one) then compare0Inner defs ctx sg e (Ann val (dsub1 ty q) loc) else clashE defs ctx sg e (Coe ty p q val loc) @@ -659,7 +661,7 @@ namespace Elim -- = caseπ f return R of { (x, y) ⇒ t } ⇒ Q[e/p] compare0Inner' defs ctx sg (CasePair epi e eret ebody eloc) (CasePair fpi f fret fbody floc) ne nf = - local_ Equal $ do + withEqual $ do ety <- compare0Inner defs ctx sg e f (fst, snd) <- expectSig defs ctx sg eloc ety let [< x, y] = ebody.names @@ -678,7 +680,7 @@ namespace Elim -- ------------------------------ -- Ψ | Γ ⊢ fst e = fst f ⇒ A compare0Inner' defs ctx sg (Fst e eloc) (Fst f floc) ne nf = - local_ Equal $ do + withEqual $ do ety <- compare0Inner defs ctx sg e f fst <$> expectSig defs ctx sg eloc ety compare0Inner' defs ctx sg e@(Fst {}) f _ _ = @@ -688,7 +690,7 @@ namespace Elim -- ------------------------------------ -- Ψ | Γ ⊢ snd e = snd f ⇒ B[fst e/x] compare0Inner' defs ctx sg (Snd e eloc) (Snd f floc) ne nf = - local_ Equal $ do + withEqual $ do ety <- compare0Inner defs ctx sg e f (_, tsnd) <- expectSig defs ctx sg eloc ety pure $ sub1 tsnd (Fst e eloc) @@ -703,7 +705,7 @@ namespace Elim -- = caseπ f return R of { '𝐚ᵢ ⇒ tᵢ } ⇒ Q[e/x] compare0Inner' defs ctx sg (CaseEnum epi e eret earms eloc) (CaseEnum fpi f fret farms floc) ne nf = - local_ Equal $ do + withEqual $ do ety <- compare0Inner defs ctx sg e f try $ compareType defs (extendTy0 eret.name ety ctx) eret.term fret.term @@ -726,7 +728,7 @@ namespace Elim -- ⇒ Q[e/x] compare0Inner' defs ctx sg (CaseNat epi epi' e eret ezer esuc eloc) (CaseNat fpi fpi' f fret fzer fsuc floc) ne nf = - local_ Equal $ do + withEqual $ do ety <- compare0Inner defs ctx sg e f let [< p, ih] = esuc.names try $ do @@ -750,7 +752,7 @@ namespace Elim -- = caseπ f return R of { [x] ⇒ t } ⇒ Q[e/x] compare0Inner' defs ctx sg (CaseBox epi e eret ebody eloc) (CaseBox fpi f fret fbody floc) ne nf = - local_ Equal $ do + withEqual $ do ety <- compare0Inner defs ctx sg e f (q, ty) <- expectBOX defs ctx sg eloc ety try $ do @@ -776,7 +778,7 @@ namespace Elim compare0Inner' defs ctx sg (TypeCase ty1 ret1 arms1 def1 eloc) (TypeCase ty2 ret2 arms2 def2 floc) ne _ = case sg `decEq` SZero of - Yes Refl => local_ Equal $ do + Yes Refl => withEqual $ do ety <- compare0Inner defs ctx SZero ty1 ty2 u <- expectTYPE defs ctx SZero eloc ety try $ do From d2a117fe614ff68542ad435e37a602064d84e3e0 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 12 May 2024 20:29:09 +0200 Subject: [PATCH 120/133] =?UTF-8?q?fix=20function=20=CE=B7=20with=20subsin?= =?UTF-8?q?gleton=20types?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- .../tests/eta-singleton/eta-sing.quox | 33 +++++++++++++++++++ golden-tests/tests/eta-singleton/expected | 9 +++++ golden-tests/tests/eta-singleton/run | 2 ++ lib/Quox/Equal.idr | 12 +++++-- 4 files changed, 54 insertions(+), 2 deletions(-) create mode 100644 golden-tests/tests/eta-singleton/eta-sing.quox create mode 100644 golden-tests/tests/eta-singleton/expected create mode 100644 golden-tests/tests/eta-singleton/run diff --git a/golden-tests/tests/eta-singleton/eta-sing.quox b/golden-tests/tests/eta-singleton/eta-sing.quox new file mode 100644 index 0000000..c3b1fc3 --- /dev/null +++ b/golden-tests/tests/eta-singleton/eta-sing.quox @@ -0,0 +1,33 @@ +-- inspired by https://github.com/agda/agda/issues/2556 + +postulate0 A : ★ + +def0 ZZ : ★ = 0 ≡ 0 : ℕ + +def reflZ : ZZ = δ _ ⇒ 0 + + +namespace erased { + def0 ZZA : ★ = 0.ZZ → A + + def propeq : (x : ZZA) → x ≡ (λ _ ⇒ x reflZ) : ZZA = + λ x ⇒ δ _ ⇒ x + + def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x = + λ P x p ⇒ p +} + +namespace unrestricted { + def0 ZZA : ★ = ω.ZZ → A + + def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x = + λ P x p ⇒ p +} + +namespace linear { + def0 ZZA : ★ = 1.ZZ → A + + #[fail] + def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x = + λ P x p ⇒ p +} diff --git a/golden-tests/tests/eta-singleton/expected b/golden-tests/tests/eta-singleton/expected new file mode 100644 index 0000000..271242e --- /dev/null +++ b/golden-tests/tests/eta-singleton/expected @@ -0,0 +1,9 @@ +0.A : ★ +0.ZZ : ★ +ω.reflZ : ZZ +0.erased.ZZA : ★ +ω.erased.propeq : 1.(x : erased.ZZA) → x ≡ (λ _ ⇒ x reflZ) : erased.ZZA +ω.erased.defeq : 0.(P : 1.erased.ZZA → ★) → 0.(x : erased.ZZA) → 1.(P (λ _ ⇒ (x reflZ))) → P x +0.unrestricted.ZZA : ★ +ω.unrestricted.defeq : 0.(P : 1.unrestricted.ZZA → ★) → 0.(x : unrestricted.ZZA) → 1.(P (λ _ ⇒ (x reflZ))) → P x +0.linear.ZZA : ★ diff --git a/golden-tests/tests/eta-singleton/run b/golden-tests/tests/eta-singleton/run new file mode 100644 index 0000000..710aa1c --- /dev/null +++ b/golden-tests/tests/eta-singleton/run @@ -0,0 +1,2 @@ +. ../lib.sh +check "$1" eta-sing.quox diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 5d5f3db..741aa1f 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -277,8 +277,16 @@ namespace Term toLamBody e = E $ App (weakE 1 e) (BVT 0 e.loc) e.loc eta : Loc -> Elim 0 n -> ScopeTerm 0 n -> Eff EqualInner () - eta loc e (S _ (N _)) = clashT loc ctx ty s t - eta _ e (S _ (Y b)) = compare0 defs ctx' sg res.term (toLamBody e) b + eta loc e (S _ (N b)) = + if qty /= One then + if !(isSubSing defs ctx sg arg) then + compare0 defs ctx' sg res.term (toLamBody e) (weakT 1 b) + else + clashT loc ctx ty s t + else + clashT loc ctx ty s t + eta _ e (S _ (Y b)) = + compare0 defs ctx' sg res.term (toLamBody e) b compare0' defs ctx sg ty@(Sig {fst, snd, _}) s t = withEqual $ case (s, t) of From b556c2f099150077f2087c3f561a20964e2accb0 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 12 May 2024 20:30:18 +0200 Subject: [PATCH 121/133] fix some comments --- lib/Quox/Equal.idr | 8 ++++---- 1 file changed, 4 insertions(+), 4 deletions(-) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 741aa1f..789b49c 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -249,18 +249,18 @@ namespace Term compare0' defs ctx sg ty@(Pi {qty, arg, res, _}) s t = withEqual $ -- Γ ⊢ A empty -- ------------------------------------------- - -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ (π·x : A) → B + -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ π.(x : A) → B if !(isEmpty defs ctx sg arg) then pure () else case (s, t) of -- Γ, x : A ⊢ s = t ⇐ B -- ------------------------------------------- - -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ (π·x : A) → B + -- Γ ⊢ (λ x ⇒ s) = (λ x ⇒ t) ⇐ π.(x : A) → B (Lam b1 {}, Lam b2 {}) => compare0 defs ctx' sg res.term b1.term b2.term -- Γ, x : A ⊢ s = e x ⇐ B -- ----------------------------------- - -- Γ ⊢ (λ x ⇒ s) = e ⇐ (π·x : A) → B + -- Γ ⊢ (λ x ⇒ s) = e ⇐ π.(x : A) → B (E e, Lam b {}) => eta s.loc e b (Lam b {}, E e) => eta s.loc e b @@ -435,7 +435,7 @@ compareType' defs ctx (Pi {qty = sQty, arg = sArg, res = sRes, loc}) (Pi {qty = tQty, arg = tArg, res = tRes, _}) = do -- Γ ⊢ A₁ :> A₂ Γ, x : A₁ ⊢ B₁ <: B₂ -- ---------------------------------------- - -- Γ ⊢ (π·x : A₁) → B₁ <: (π·x : A₂) → B₂ + -- Γ ⊢ π.(x : A₁) → B₁ <: π.(x : A₂) → B₂ expectEqualQ loc sQty tQty local flip $ compareType defs ctx sArg tArg -- contra compareType defs (extendTy0 sRes.name sArg ctx) sRes.term tRes.term From d276a66abdba7882d128c9d7f4e20656923f22f8 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 12 May 2024 20:30:26 +0200 Subject: [PATCH 122/133] slightly improve a log message --- lib/Quox/Equal.idr | 3 ++- 1 file changed, 2 insertions(+), 1 deletion(-) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 789b49c..5998b3d 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -916,7 +916,8 @@ parameters (loc : Loc) (ctx : TyContext d n) (EqContext n -> DSubst d 0 -> Eff fs ()) -> Eff fs () eachCorner loc fvs act = do say "equal" 50 loc $ - hsep $ "eachCorner: split on" :: map prettyBind' (getVars ctx fvs) + let vars = map prettyBind' (getVars ctx fvs) in + hsep $ "eachCorner: split on" :: if null vars then ["(none)"] else vars for_ (splits loc ctx.dctx fvs) $ \th => act (makeEqContext ctx th) th From 8fae67d4d56ab94a673ab724d1056243b5e145f2 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 12 May 2024 20:32:32 +0200 Subject: [PATCH 123/133] check the new test actually fails in the right way --- golden-tests/tests/eta-singleton/eta-sing.quox | 2 +- 1 file changed, 1 insertion(+), 1 deletion(-) diff --git a/golden-tests/tests/eta-singleton/eta-sing.quox b/golden-tests/tests/eta-singleton/eta-sing.quox index c3b1fc3..5ae2daf 100644 --- a/golden-tests/tests/eta-singleton/eta-sing.quox +++ b/golden-tests/tests/eta-singleton/eta-sing.quox @@ -27,7 +27,7 @@ namespace unrestricted { namespace linear { def0 ZZA : ★ = 1.ZZ → A - #[fail] + #[fail "λ _ ⇒ x reflZ is not equal to x"] def defeq : 0.(P : ZZA → ★) → 0.(x : ZZA) → P (λ _ ⇒ x reflZ) → P x = λ P x p ⇒ p } From 863849e4c459321b29631e5f82d7add2f12eb5b0 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 13 May 2024 01:23:14 +0200 Subject: [PATCH 124/133] =?UTF-8?q?clean=20up=20subsing=20=CE=B7=20stuff?= MIME-Version: 1.0 Content-Type: text/plain; charset=UTF-8 Content-Transfer-Encoding: 8bit --- lib/Quox/Equal.idr | 10 +++------- 1 file changed, 3 insertions(+), 7 deletions(-) diff --git a/lib/Quox/Equal.idr b/lib/Quox/Equal.idr index 5998b3d..5ac02b2 100644 --- a/lib/Quox/Equal.idr +++ b/lib/Quox/Equal.idr @@ -278,13 +278,9 @@ namespace Term eta : Loc -> Elim 0 n -> ScopeTerm 0 n -> Eff EqualInner () eta loc e (S _ (N b)) = - if qty /= One then - if !(isSubSing defs ctx sg arg) then - compare0 defs ctx' sg res.term (toLamBody e) (weakT 1 b) - else - clashT loc ctx ty s t - else - clashT loc ctx ty s t + if !(pure (qty /= One) `andM` isSubSing defs ctx sg arg) + then compare0 defs ctx' sg res.term (toLamBody e) (weakT 1 b) + else clashT loc ctx ty s t eta _ e (S _ (Y b)) = compare0 defs ctx' sg res.term (toLamBody e) b From 5bf40755b548d3fc9d4929e02c965213cff7c681 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 6 May 2024 19:24:02 +0200 Subject: [PATCH 125/133] beginning of quox stdlib --- stdlib/bool.quox | 49 ++++ stdlib/either.quox | 116 +++++++++ stdlib/fin.quox | 259 ++++++++++++++++++++ stdlib/int.quox | 149 ++++++++++++ stdlib/io.quox | 100 ++++++++ stdlib/irrel.quox | 43 ++++ stdlib/list.quox | 590 +++++++++++++++++++++++++++++++++++++++++++++ stdlib/maybe.quox | 146 +++++++++++ stdlib/misc.quox | 261 ++++++++++++++++++++ stdlib/nat.quox | 297 +++++++++++++++++++++++ stdlib/pair.quox | 67 +++++ stdlib/qty.quox | 156 ++++++++++++ stdlib/string.quox | 144 +++++++++++ stdlib/sub.quox | 159 ++++++++++++ 14 files changed, 2536 insertions(+) create mode 100644 stdlib/bool.quox create mode 100644 stdlib/either.quox create mode 100644 stdlib/fin.quox create mode 100644 stdlib/int.quox create mode 100644 stdlib/io.quox create mode 100644 stdlib/irrel.quox create mode 100644 stdlib/list.quox create mode 100644 stdlib/maybe.quox create mode 100644 stdlib/misc.quox create mode 100644 stdlib/nat.quox create mode 100644 stdlib/pair.quox create mode 100644 stdlib/qty.quox create mode 100644 stdlib/string.quox create mode 100644 stdlib/sub.quox diff --git a/stdlib/bool.quox b/stdlib/bool.quox new file mode 100644 index 0000000..855f064 --- /dev/null +++ b/stdlib/bool.quox @@ -0,0 +1,49 @@ +load "misc.quox" + +namespace bool { + +def0 Bool : ★ = {true, false} + +def if-dep : 0.(P : Bool → ★) → (b : Bool) → ω.(P 'true) → ω.(P 'false) → P b = + λ P b t f ⇒ case b return b' ⇒ P b' of { 'true ⇒ t; 'false ⇒ f } + +def if : 0.(A : ★) → (b : Bool) → ω.A → ω.A → A = + λ A ⇒ if-dep (λ _ ⇒ A) + +def0 if-same : (A : ★) → (b : Bool) → (x : A) → if A b x x ≡ x : A = + λ A b x ⇒ if-dep (λ b' ⇒ if A b' x x ≡ x : A) b (δ _ ⇒ x) (δ _ ⇒ x) + +def if2 : 0.(A B : ★) → (b : Bool) → ω.A → ω.B → if¹ ★ b A B = + λ A B ⇒ if-dep (λ b ⇒ if¹ ★ b A B) + +def0 T : Bool → ★ = λ b ⇒ if¹ ★ b True False + +def dup! : (b : Bool) → Dup Bool b = + λ b ⇒ + case b return b' ⇒ Dup Bool b' of { + 'true ⇒ (['true], [δ _ ⇒ ['true]]); + 'false ⇒ (['false], [δ _ ⇒ ['false]]) + } + +def dup : Bool → [ω.Bool] = + λ b ⇒ + case dup! b return [ω.Bool] of { + (b!, p0) ⇒ drop0 (b! ≡ [b] : [ω.Bool]) [ω.Bool] p0 b! + } + +def true-not-false : Not ('true ≡ 'false : Bool) = + λ eq ⇒ coe (𝑖 ⇒ T (eq @𝑖)) 'true + + +-- [todo] infix +def and : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a b 'false +def or : Bool → ω.Bool → Bool = λ a b ⇒ if Bool a 'true b +def not : Bool → Bool = λ b ⇒ if Bool b 'false 'true + + +def0 not-not : (b : Bool) → not (not b) ≡ b : Bool = + λ b ⇒ if-dep (λ b ⇒ not (not b) ≡ b : Bool) b (δ _ ⇒ 'true) (δ _ ⇒ 'false) + +} + +def0 Bool = bool.Bool diff --git a/stdlib/either.quox b/stdlib/either.quox new file mode 100644 index 0000000..fa67ea2 --- /dev/null +++ b/stdlib/either.quox @@ -0,0 +1,116 @@ +load "misc.quox" +load "bool.quox" + +namespace either { + +def0 Tag : ★ = {left, right} + +def0 Payload : ★ → ★ → Tag → ★ = + λ A B tag ⇒ case tag return ★ of { 'left ⇒ A; 'right ⇒ B } + +def0 Either : ★ → ★ → ★ = + λ A B ⇒ (tag : Tag) × Payload A B tag + +def Left : 0.(A B : ★) → A → Either A B = + λ A B x ⇒ ('left, x) + +def Right : 0.(A B : ★) → B → Either A B = + λ A B x ⇒ ('right, x) + +def elim : + 0.(A B : ★) → 0.(P : 0.(Either A B) → ★) → + ω.((x : A) → P (Left A B x)) → + ω.((x : B) → P (Right A B x)) → + (x : Either A B) → P x = + λ A B P f g e ⇒ + case e return e' ⇒ P e' of { (t, a) ⇒ + case t return t' ⇒ (a : Payload A B t') → P (t', a) + of { 'left ⇒ f; 'right ⇒ g } a + } + +def elimω : + 0.(A B : ★) → 0.(P : 0.(Either A B) → ★) → + ω.(ω.(x : A) → P (Left A B x)) → + ω.(ω.(x : B) → P (Right A B x)) → + ω.(x : Either A B) → P x = + λ A B P f g e ⇒ + case fst e return t' ⇒ ω.(a : Payload A B t') → P (t', a) + of { 'left ⇒ f; 'right ⇒ g } (snd e) + +def fold : + 0.(A B C : ★) → ω.(A → C) → ω.(B → C) → Either A B → C = + λ A B C ⇒ elim A B (λ _ ⇒ C) + +def foldω : + 0.(A B C : ★) → ω.(ω.A → C) → ω.(ω.B → C) → ω.(Either A B) → C = + λ A B C ⇒ elimω A B (λ _ ⇒ C) + + +} + +def0 Either = either.Either +def Left = either.Left +def Right = either.Right + + +namespace dec { + +def0 Dec : ★ → ★ = λ A ⇒ Either [0.A] [0.Not A] + +def Yes : 0.(A : ★) → 0.A → Dec A = λ A y ⇒ Left [0.A] [0.Not A] [y] +def No : 0.(A : ★) → 0.(Not A) → Dec A = λ A n ⇒ Right [0.A] [0.Not A] [n] + +def yes-refl : 0.(A : ★) → 0.(x : A) → Dec (x ≡ x : A) = + λ A x ⇒ Yes (x ≡ x : A) (δ 𝑖 ⇒ x) + +def0 DecEq : ★ → ★ = + λ A ⇒ ω.(x y : A) → Dec (x ≡ y : A) + +def elim : + 0.(A : ★) → 0.(P : 0.(Dec A) → ★) → + ω.(0.(y : A) → P (Yes A y)) → + ω.(0.(n : Not A) → P (No A n)) → + (x : Dec A) → P x = + λ A P f g ⇒ + either.elim [0.A] [0.Not A] P + (λ y ⇒ case y return y' ⇒ P (Left [0.A] [0.Not A] y') of {[y'] ⇒ f y'}) + (λ n ⇒ case n return n' ⇒ P (Right [0.A] [0.Not A] n') of {[n'] ⇒ g n'}) + +def bool : 0.(A : ★) → Dec A → Bool = + λ A ⇒ elim A (λ _ ⇒ Bool) (λ _ ⇒ 'true) (λ _ ⇒ 'false) + +def drop' : 0.(A : ★) → Dec A → True = + λ A ⇒ elim A (λ _ ⇒ True) (λ _ ⇒ 'true) (λ _ ⇒ 'true) + +def drop : 0.(A B : ★) → Dec A → B → B = + λ A B x y ⇒ true.drop B (drop' A x) y + +} + +def0 Dec = dec.Dec +def0 DecEq = dec.DecEq +def Yes = dec.Yes +def No = dec.No + + +namespace dect { + +def0 DecT : ★ → ★ = λ A ⇒ Either A [0.Not A] + +def YesT : 0.(A : ★) → 1.A → DecT A = λ A y ⇒ Left A [0.Not A] y +def NoT : 0.(A : ★) → 0.(Not A) → DecT A = λ A n ⇒ Right A [0.Not A] [n] + +def elim : + 0.(A : ★) → 0.(P : 0.(DecT A) → ★) → + ω.(1.(y : A) → P (YesT A y)) → + ω.(0.(n : Not A) → P (NoT A n)) → + (x : DecT A) → P x = + λ A P f g ⇒ + either.elim A [0.Not A] P + f + (λ n ⇒ case n return n' ⇒ P (Right A [0.Not A] n') of {[n'] ⇒ g n'}) +} + +def0 DecT = dect.DecT +def YesT = dect.YesT +def NoT = dect.NoT diff --git a/stdlib/fin.quox b/stdlib/fin.quox new file mode 100644 index 0000000..2491c90 --- /dev/null +++ b/stdlib/fin.quox @@ -0,0 +1,259 @@ +load "nat.quox" +load "either.quox" +load "maybe.quox" +load "sub.quox" + + +namespace nat.lt { + +def0 LT : ℕ → ℕ → ★ = + elim-pair¹ (λ _ _ ⇒ ★) + False -- 0 ≮ 0 + (λ n p ⇒ True) -- 0 < succ n + (λ m p ⇒ False) -- succ m ≮ 0 + (λ m n p ⇒ p) -- succ m < succ n ⇔ m < n + + +def0 irr : sub.Irr2 ℕ ℕ LT = + elim-pair (λ m n ⇒ (p q : LT m n) → p ≡ q : LT m n) + false.irr (λ _ _ ⇒ true.irr) (λ _ _ ⇒ false.irr) (λ _ _ p ⇒ p) + + +-- [todo] quantities (which will need to inline and adapt elim-pair) +def elimω : 0.(P : (m n : ℕ) → LT m n → ★) → + ω.(0.(n : ℕ) → P 0 (succ n) 'true) → + ω.(0.(m n : ℕ) → 0.(lt : LT m n) → + ω.(P m n lt) → P (succ m) (succ n) lt) → + ω.(m n : ℕ) → 0.(lt : LT m n) → P m n lt = + λ P p0s pss ⇒ + elim-pairω (λ m n ⇒ 0.(lt : LT m n) → P m n lt) + (λ ff ⇒ void (P 0 0 ff) ff) + (λ n p tt ⇒ p0s n) + (λ m p ff ⇒ void (P (succ m) 0 ff) ff) + (λ m n p tt ⇒ pss m n tt (p tt)) + +def0 true-ty : (m n : ℕ) → LT m n → LT m n ≡ True : ★ = + elim-pair¹ (λ m n ⇒ LT m n → LT m n ≡ True : ★) + (λ ff ⇒ void¹ (False ≡ True : ★) ff) + (λ n p tt ⇒ δ _ ⇒ True) + (λ m p ff ⇒ void¹ (False ≡ True : ★) ff) + (λ n m p tf ⇒ p tf) + +def0 true-val : + (m n : ℕ) → (lt : LT m n) → Eq (𝑖 ⇒ true-ty m n lt @𝑖) lt 'true = + let IsTrue : (m n : ℕ) → LT m n → ★ = + λ m n lt ⇒ Eq (𝑖 ⇒ true-ty m n lt @𝑖) lt 'true in + elim-pair (λ m n ⇒ (lt : LT m n) → IsTrue m n lt) + (λ ff ⇒ void (IsTrue 0 0 ff) ff) + (λ n p tt ⇒ δ _ ⇒ 'true) + (λ m p ff ⇒ void (IsTrue (succ m) 0 ff) ff) + (λ n m p tf ⇒ p tf) + +def revive : 0.(m n : ℕ) → 0.(LT m n) → LT m n = + λ m n lt ⇒ coe (𝑘 ⇒ true-ty m n lt @𝑘) @1 @0 'true + + +def drop : 0.(A : ★) → 0.(m n : ℕ) → LT m n → A → A = + λ A m n lt x ⇒ true.drop A (coe (𝑖 ⇒ true-ty m n lt @𝑖) lt) x + +def0 succ-both : (m n : ℕ) → LT m n → LT (succ m) (succ n) = + λ m n p ⇒ p + +def0 succ-right : (m n : ℕ) → LT m n → LT m (succ n) = + λ m n lt ⇒ + elimω (λ m n _ ⇒ LT m (succ n)) + (λ _ ⇒ 'true) + (λ _ _ _ ih ⇒ ih) + m n lt + +def0 right-is-succ : (m n : ℕ) → LT m n → IsSucc n = + λ m n lt ⇒ + elimω (λ _ n _ ⇒ IsSucc n) (λ _ ⇒ 'true) (λ _ _ _ _ ⇒ 'true) m n lt + +def right-has-succ : 0.(m : ℕ) → (n : ℕ) → 0.(LT m n) → HasSucc n = + λ m n lt ⇒ + case n return n' ⇒ 0.(LT m n') → HasSucc n' of { + 0 ⇒ λ lt ⇒ void (HasSucc 0) (right-is-succ m 0 lt); + succ n ⇒ λ _ ⇒ (n, [δ _ ⇒ succ n]) + } lt + +def0 right-not-zero : (m : ℕ) → Not (LT m 0) = + λ m ⇒ case m return m' ⇒ Not (LT m' 0) of { 0 ⇒ λ v ⇒ v; succ _ ⇒ λ v ⇒ v } + +def0 plus-right : (m n₀ n₁ : ℕ) → LT m n₀ → LT m (plus n₀ n₁) = + λ m n₀ n₁ lt ⇒ + elimω (λ m n _ ⇒ LT m (plus n n₁)) (λ _ ⇒ 'true) (λ _ _ _ ih ⇒ ih) m n₀ lt + +#[compile-scheme "(lambda% (m n) (if (< m n) dec.Yes dec.No))"] +def lt? : ω.(m n : ℕ) → Dec (LT m n) = + elim-pairω (λ m n ⇒ Dec (LT m n)) + (No (LT 0 0) (λ v ⇒ v)) + (λ n p ⇒ Yes (LT 0 (succ n)) 'true) + (λ m p ⇒ No (LT (succ m) 0) (λ v ⇒ v)) + (λ m n p ⇒ + dec.elim (LT m n) (λ _ ⇒ Dec (LT (succ m) (succ n))) + (λ yes ⇒ Yes (LT (succ m) (succ n)) yes) + (λ no ⇒ No (LT (succ m) (succ n)) no) p) + + +def0 irrefl : (m n : ℕ) → LT m n → Not (m ≡ n : ℕ) = + λ m n lt ⇒ + elimω (λ m n _ ⇒ Not (m ≡ n : ℕ)) + (λ n eq ⇒ zero-not-succ n eq) + (λ m n _ ih eq ⇒ ih (succ-inj m n eq)) + m n lt + +def0 asym : (m n : ℕ) → LT m n → Not (LT n m) = + λ m n lt ⇒ + elimω (λ m n _ ⇒ Not (LT n m)) (λ _ ff ⇒ ff) (λ _ _ _ ih ff ⇒ ih ff) m n lt + +def0 trans : (n₀ n₁ n₂ : ℕ) → LT n₀ n₁ → LT n₁ n₂ → LT n₀ n₂ = + λ n₀ n₁ n₂ lt₀₁ lt₁₂ ⇒ + elimω (λ n₀ n₁ lt₀₁ ⇒ (n₂ : ℕ) → (lt₁₂ : LT n₁ n₂) → LT n₀ n₂) + (λ n₁ n₂ ⇒ + case n₂ return n₂' ⇒ LT (succ n₁) n₂' → LT 0 n₂' of { + 0 ⇒ λ v ⇒ v; + succ _ ⇒ λ _ ⇒ 'true + }) + (λ n₀ n₁ lt₀₁ ih n₂ ⇒ + case n₂ return n₂' ⇒ LT (succ n₁) n₂' → LT (succ n₀) n₂' of { + 0 ⇒ λ v ⇒ v; + succ n₂ ⇒ λ lt₁₂ ⇒ ih n₂ lt₁₂ + }) + n₀ n₁ lt₀₁ n₂ lt₁₂ + +} + +namespace nat { +def0 LT = lt.LT +def lt? = lt.lt? +} + + +namespace fin { + +def0 Bounded : ℕ → ℕ → ★ = λ n i ⇒ nat.LT i n + +def0 Fin : ℕ → ★ = λ n ⇒ Sub ℕ (Bounded n) + +def fin : 0.(n : ℕ) → (i : ℕ) → 0.(Bounded n i) → Fin n = + λ n ⇒ sub.sub ℕ (Bounded n) + +def val : 0.(n : ℕ) → Fin n → ℕ = + λ n ⇒ sub.val ℕ (Bounded n) + +def0 val-eq : (n : ℕ) → (i j : Fin n) → val n i ≡ val n j : ℕ → i ≡ j : Fin n = + λ n ⇒ sub.sub-eq ℕ (Bounded n) (λ i ⇒ nat.lt.irr i n) + +def0 proof : (n : ℕ) → (i : Fin n) → nat.LT (val n i) n = + λ n ⇒ sub.proof ℕ (Bounded n) + + +def0 no-fin0 : Not (Fin 0) = + λ f0 ⇒ case f0 return False of { (i, lt) ⇒ + nat.lt.right-not-zero i (get0 (nat.LT i 0) lt) + } + + +def fin? : ω.(n i : ℕ) → Maybe (Fin n) = + λ n ⇒ sub.sub? ℕ (Bounded n) (λ i ⇒ nat.lt? i n) + +def F0 : 0.(n : ℕ) → Fin (succ n) = + λ n ⇒ fin (succ n) 0 'true +def FS : 0.(n : ℕ) → Fin n → Fin (succ n) = + λ n i ⇒ fin (succ n) (succ (val n i)) (proof n i) + +def weak : 0.(m n : ℕ) → 0.(nat.LT m n) → Fin m → Fin n = + λ m n mn i' ⇒ + let i = val m i'; 0.im = proof m i' in + fin n i (nat.lt.trans i m n im mn) + + +def bound-has-succ : (n : ℕ) → 0.(Fin n) → nat.HasSucc n = + λ n i ⇒ nat.lt.right-has-succ (fst i) n (get0 (nat.LT (fst i) n) (snd i)) + +def elim' : + 0.(P : (n i : ℕ) → nat.LT i n → ★) → + 1.(pz : 0.(n : ℕ) → P (succ n) 0 'true) → + ω.(ps : 0.(n i : ℕ) → 0.(lt : nat.LT i n) → + P n i lt → P (succ n) (succ i) lt) → + 0.(n : ℕ) → (i : ℕ) → 0.(lt : nat.LT i n) → P n i lt = + λ P pz ps n i lt ⇒ + case i return i' ⇒ 0.(n : ℕ) → 0.(lt : nat.LT i' n) → P n i' lt of { + 0 ⇒ λ n lt ⇒ + let0 npp = nat.lt.right-has-succ 0 n lt; + p = nat.has-succ.val n npp; + np = nat.has-succ.proof n npp in + coe (𝑘 ⇒ P (np @𝑘) 0 (coe (𝑙 ⇒ nat.LT 0 (np @𝑙)) @0 @𝑘 lt)) @1 @0 + (pz p); + succ i, ih ⇒ λ n lt ⇒ + let 0.npp = nat.lt.right-has-succ (succ i) n lt; + 0.p = nat.has-succ.val n npp; + 0.np = nat.has-succ.proof n npp; + 0.lt' : nat.LT i p = coe (𝑘 ⇒ nat.LT (succ i) (np @𝑘)) lt; + 0.lteq : Eq (𝑘 ⇒ nat.LT (succ i) (np @𝑘)) lt lt' = + δ 𝑘 ⇒ coe (𝑙 ⇒ nat.LT (succ i) (np @𝑙)) @0 @𝑘 lt; + 1.almost : P (succ p) (succ i) lt' = ps p i lt' (ih p lt') in + coe (𝑘 ⇒ P (np @𝑘) (succ i) (lteq @𝑘)) @1 @0 almost; + } n lt + +def elim : 0.(P : (n : ℕ) → Fin n → ★) → + (pz : 0.(n : ℕ) → P (succ n) (F0 n)) → + (ps : 0.(n : ℕ) → 0.(i : Fin n) → + P n i → P (succ n) (FS n i)) → + 0.(n : ℕ) → (i : Fin n) → P n i = + λ P pz ps n ilt ⇒ + case ilt return ilt' ⇒ P n ilt' of { (i, lt) ⇒ + let0 lt = get0 (nat.LT i n) lt in + drop0 (nat.LT i n) (P n (i, [lt])) lt + (elim' (λ n i lt ⇒ P n (i, [lt])) pz (λ n i lt ⇒ ps n (i, [lt])) n i lt) + } + +{- +def elim : 0.(P : (n : ℕ) → Fin n → ★) → + (pz : 0.(n : ℕ) → P (succ n) (F0 n)) → + (ps : 0.(n : ℕ) → 0.(i : Fin n) → + P n i → P (succ n) (FS n i)) → + 0.(n : ℕ) → (i : Fin n) → P n i = + λ P pz ps n ilt ⇒ + let i = val n ilt; 0.lt : nat.LT i n = proof n ilt; + 0.pp = nat.lt.right-has-succ i n lt; + 0.p = nat.has-succ.val n pp; 0.np = nat.has-succ.proof n pp; + 0.RES : ℕ → ℕ → ★ = + λ i n ⇒ (lt : nat.LT i n) × P n (i, [lt]); + res : RES i (succ p) = + case i + return i' ⇒ 0.(p : ℕ) → 0.(nat.LT i' (succ p)) → RES i' (succ p) + of { + 0 ⇒ λ p _ ⇒ ('true, pz p); + succ i, IH ⇒ λ p lt ⇒ + let 0.qq = nat.lt.right-has-succ i p lt; + 0.q = nat.has-succ.val p qq; 0.pq = nat.has-succ.proof p qq; + 0.lt : nat.LT i (succ q) = coe (𝑘 ⇒ nat.LT i (pq @𝑘)) lt; + in + case IH q lt return RES (succ i) (succ p) of { (lt', ih') ⇒ + let lt : nat.LT (succ i) (succ p) = + coe (𝑘 ⇒ nat.LT i (pq @𝑘)) @1 @0 lt'; + ih : P p (i, [lt]) = + coe (𝑘 ⇒ P (pq @𝑘) (i, [coe (𝑙 ⇒ nat.LT i (pq @𝑙)) @1 @𝑘 lt'])) + @1 @0 ih'; + res : P (succ p) (succ i, [lt]) = + ps p (i, [lt]) ih; + in + (lt, res) + } + } p (coe (𝑘 ⇒ nat.LT i (np @𝑘)) lt); + in + case coe (𝑘 ⇒ RES i (np @𝑘)) @1 @0 res + return P n ilt + of { (lt', res) ⇒ + nat.lt.drop (P n ilt) i n lt' res + } +-} + +} + + +def0 Fin = fin.Fin +def F0 = fin.F0 +def FS = fin.FS diff --git a/stdlib/int.quox b/stdlib/int.quox new file mode 100644 index 0000000..3ca1478 --- /dev/null +++ b/stdlib/int.quox @@ -0,0 +1,149 @@ +load "nat.quox" + +namespace int { + +def0 Sign : ★ = {pos, neg-succ} +def0 ℤ : ★ = Sign × ℕ + +def from-ℕ : ℕ → ℤ = λ n ⇒ ('pos, n) + +def neg-ℕ : ℕ → ℤ = + λ n ⇒ case n return ℤ of { 0 ⇒ ('pos, 0); succ n ⇒ ('neg-succ, n) } + +def zeroℤ : ℤ = ('pos, 0) + + +def match : 0.(A : ★) → ω.(pos neg : ℕ → A) → ℤ → A = + λ A pos neg x ⇒ + case x return A of { (s, x) ⇒ + case s return A of { 'pos ⇒ pos x; 'neg-succ ⇒ neg x } + } + +def negate : ℤ → ℤ = + match ℤ neg-ℕ (λ x ⇒ from-ℕ (succ x)) + +def minus-ℕ-ℕ : ℕ → ℕ → ℤ = + λ m n ⇒ + letω f : ω.ℕ → ω.ℕ → ℤ = λ m n ⇒ + bool.if ℤ (nat.ge m n) (from-ℕ (nat.minus m n)) + (neg-ℕ (nat.minus n m)) in + getω ℤ (app2ω ℕ ℕ ℤ f (nat.dup m) (nat.dup n)) + +def plus-ℕ : ℤ → ℕ → ℤ = + match (ℕ → ℤ) (λ x n ⇒ from-ℕ (nat.plus x n)) + (λ x n ⇒ minus-ℕ-ℕ n (succ x)) + +def minus-ℕ : ℤ → ℕ → ℤ = + match (ℕ → ℤ) minus-ℕ-ℕ (λ x n ⇒ ('neg-succ, nat.plus x n)) + + +def plus : ℤ → ℤ → ℤ = + match (ℤ → ℤ) (λ x y ⇒ plus-ℕ y x) (λ x y ⇒ minus-ℕ y (succ x)) + +def minus : ℤ → ℤ → ℤ = λ x y ⇒ plus x (negate y) + + +def dup-sign : Sign → [ω. Sign] = + λ s ⇒ case s return [ω. Sign] of { + 'pos ⇒ ['pos]; + 'neg-succ ⇒ ['neg-succ] + } + +def0 dup-sign-ok : (s : Sign) → dup-sign s ≡ [s] : [ω. Sign] = + λ s ⇒ case s return s' ⇒ dup-sign s' ≡ [s'] : [ω. Sign] of { + 'pos ⇒ δ 𝑖 ⇒ ['pos]; + 'neg-succ ⇒ δ 𝑖 ⇒ ['neg-succ] + } + +def dup : ℤ → [ω.ℤ] = + λ x ⇒ case x return [ω.ℤ] of { (s, n) ⇒ + app2ω Sign ℕ ℤ (λ s n ⇒ (s, n)) (dup-sign s) (nat.dup n) + } + +def0 dup-ok : (x : ℤ) → dup x ≡ [x] : [ω.ℤ] = + λ x ⇒ + case x return x' ⇒ dup x' ≡ [x'] : [ω.ℤ] of { (s, n) ⇒ δ 𝑖 ⇒ + app2ω Sign ℕ ℤ (λ s n ⇒ (s, n)) (dup-sign-ok s @𝑖) (nat.dup-ok n @𝑖) + } + + +def times-ℕ : ℤ → ℕ → ℤ = + match (ℕ → ℤ) + (λ m n ⇒ from-ℕ (nat.times m n)) + (λ m' n ⇒ neg-ℕ (nat.times (succ m') n)) + +def times : ℤ → ℤ → ℤ = + match (ℤ → ℤ) (λ p x ⇒ times-ℕ x p) (λ n x ⇒ negate (times-ℕ x (succ n))) + + +def abs : ℤ → ℕ = match ℕ (λ p ⇒ p) (λ n ⇒ succ n) + + +def pair-eq? : 0.(A B : ★) → ω.(DecEq A) → ω.(DecEq B) → DecEq (A × B) = + λ A B eqA? eqB? x y ⇒ + let0 Ret : ★ = x ≡ y : (A × B) in + letω a0 = fst x; a1 = fst y; + b0 = snd x; b1 = snd y in + dec.elim (a0 ≡ a1 : A) (λ _ ⇒ Dec Ret) + (λ ya ⇒ + dec.elim (b0 ≡ b1 : B) (λ _ ⇒ Dec Ret) + (λ yb ⇒ Yes Ret (δ 𝑖 ⇒ (ya @𝑖, yb @𝑖))) + (λ nb ⇒ No Ret (λ eq ⇒ nb (δ 𝑖 ⇒ snd (eq @𝑖)))) + (eqB? b0 b1)) + (λ na ⇒ No Ret (λ eq ⇒ na (δ 𝑖 ⇒ fst (eq @𝑖)))) + (eqA? a0 a1) + + +def sign-eq? : DecEq Sign = + λ x y ⇒ + let0 disc : Sign → ★ = + λ s ⇒ case s return ★ of { 'pos ⇒ True; 'neg-succ ⇒ False } in + case x return x' ⇒ Dec (x' ≡ y : Sign) of { + 'pos ⇒ + case y return y' ⇒ Dec ('pos ≡ y' : Sign) of { + 'pos ⇒ dec.yes-refl Sign 'pos; + 'neg-succ ⇒ + No ('pos ≡ 'neg-succ : Sign) + (λ eq ⇒ coe (𝑖 ⇒ disc (eq @𝑖)) 'true) + }; + 'neg-succ ⇒ + case y return y' ⇒ Dec ('neg-succ ≡ y' : Sign) of { + 'neg-succ ⇒ dec.yes-refl Sign 'neg-succ; + 'pos ⇒ + No ('neg-succ ≡ 'pos : Sign) + (λ eq ⇒ coe (𝑖 ⇒ disc (eq @𝑖)) @1 @0 'true) + } + } + +#[compile-scheme "(lambda% (x y) (if (equal? x y) Yes No))"] +def eq? : DecEq ℤ = pair-eq? Sign ℕ sign-eq? nat.eq? + +def eq : ω.ℤ → ω.ℤ → Bool = + λ x y ⇒ dec.bool (x ≡ y : ℤ) (eq? x y) + +} + +def0 ℤ = int.ℤ + + +namespace scheme-int { + postulate0 Int : ★ + + #[compile-scheme "(lambda (x) x)"] + postulate from-ℕ : ℕ → Int + + #[compile-scheme "(lambda% (x y) (+ x y))"] + postulate plus : Int → Int → Int + + #[compile-scheme "(lambda% (x y) (- x y))"] + postulate minus : Int → Int → Int + + #[compile-scheme "(lambda% (x y) (* x y))"] + postulate times : Int → Int → Int + + #[compile-scheme "(lambda% (x y) (if (= x y) 'true 'false))"] + postulate eq : Int → Int → Bool + + #[compile-scheme "abs"] + postulate abs : Int → ℕ +} diff --git a/stdlib/io.quox b/stdlib/io.quox new file mode 100644 index 0000000..36ebe69 --- /dev/null +++ b/stdlib/io.quox @@ -0,0 +1,100 @@ +load "misc.quox" +load "maybe.quox" +load "list.quox" + +namespace io { + +def0 IORes : ★ → ★ = λ A ⇒ A × IOState + +def0 IO : ★ → ★ = λ A ⇒ IOState → IORes A + +def pure : 0.(A : ★) → A → IO A = λ A x s ⇒ (x, s) + +def bind : 0.(A B : ★) → IO A → (A → IO B) → IO B = + λ A B m k s0 ⇒ + case m s0 return IORes B of { (x, s1) ⇒ k x s1 } + +def bindω : 0.(A B : ★) → IO [ω.A] → (ω.A → IO B) → IO B = + λ A B m k s0 ⇒ + case m s0 return IORes B of { (x, s1) ⇒ + case x return IORes B of { [x] ⇒ k x s1 } + } + +def map : 0.(A B : ★) → (A → B) → IO A → IO B = + λ A B f m ⇒ bind A B m (λ x ⇒ pure B (f x)) + +def mapω : 0.(A B : ★) → (ω.A → B) → IO [ω.A] → IO B = + λ A B f m ⇒ bindω A B m (λ x ⇒ pure B (f x)) + +def seq : 0.(B : ★) → IO True → IO B → IO B = + λ B x y ⇒ bind True B x (λ u ⇒ case u return IO B of { 'true ⇒ y }) + +def seq' : IO True → IO True → IO True = seq True + +def pass : IO True = pure True 'true + +#[compile-scheme "(lambda (str) (builtin-io (display str) 'true))"] +postulate print : String → IO True + +#[compile-scheme "(lambda (str) (builtin-io (write str) (newline) 'true))"] +postulate dump : 0.(A : ★) → A → IO True + +def newline = print "\n" + +def println : String → IO True = + λ str ⇒ seq' (print str) newline + +#[compile-scheme "(builtin-io (get-line (current-input-port)))"] +postulate readln : IO String + + +-- [todo] errors lmao + +{- +postulate0 File : ★ + +#[compile-scheme "(lambda (path) (builtin-io (open-input-file path)))"] +postulate open-read : String → IO File + +#[compile-scheme "(lambda (file) (builtin-io (close-port file) 'true))"] +postulate close : File → IO True + +#[compile-scheme + "(lambda% (file if-eof if-line) + (builtin-io + (let ([result (get-line file)]) + (if (eof-object? result) + (cons if-eof file) + (cons (if-line result) file)))))"] +postulate prim-read-line : + File → + ω.(if-eof : Maybe [ω.String]) → + ω.(if-line : ω.String → Maybe [ω.String]) → + IO (Maybe [ω.String] × File) + +def read-line : File → IO (Maybe [ω.String] × File) = + λ f ⇒ prim-read-line f (Nothing [ω.String]) (λ x ⇒ Just [ω.String] [x]) +-} + + +#[compile-scheme + "(lambda (path) (builtin-io (call-with-input-file path get-string-all)))"] +postulate read-fileω : ω.(path : String) → IO [ω.String] + +def read-file : ω.(path : String) → IO String = + λ path ⇒ + map [ω.String] String (getω String) (read-fileω path) + + +#[compile-scheme + "(lambda (path) (builtin-io + (call-with-input-file path + (lambda (file) + (do [(line (get-line file) (get-line file)) + (acc '() (cons line acc))] + [(eof-object? line) (reverse acc)])))))"] +postulate read-file-lines : ω.(path : String) → IO (List String) + +} + +def0 IO = io.IO diff --git a/stdlib/irrel.quox b/stdlib/irrel.quox new file mode 100644 index 0000000..87537a4 --- /dev/null +++ b/stdlib/irrel.quox @@ -0,0 +1,43 @@ +load "misc.quox" + +def0 Irr1 : (A : ★) → (A → ★) → ★ = + λ A P ⇒ (x : A) → (p q : P x) → p ≡ q : P x + +def0 Sub : (A : ★) → (P : A → ★) → ★ = + λ A P ⇒ (x : A) × [0. P x] + +def0 SubDup : (A : ★) → (P : A → ★) → Sub A P → ★ = + λ A P s ⇒ Dup A (fst s) + -- (x! : [ω.A]) × [0. x! ≡ [fst s] : [ω.A]] + +def subdup-to-dup : + 0.(A : ★) → 0.(P : A → ★) → 0.(Irr1 A P) → + 0.(s : Sub A P) → SubDup A P s → Dup (Sub A P) s = + λ A P pirr s sd ⇒ + case sd return Dup (Sub A P) s of { (sω, ss0) ⇒ + case ss0 return Dup (Sub A P) s of { [ss0] ⇒ + case sω + return sω' ⇒ 0.(sω' ≡ [fst s] : [ω.A]) → Dup (Sub A P) s + of { [s!] ⇒ λ ss' ⇒ + let ω.p : [0.P (fst s)] = revive0 (P (fst s)) (snd s); + 0.ss : s! ≡ fst s : A = boxω-inj A s! (fst s) ss' in + ([(s!, coe (𝑖 ⇒ [0.P (ss @𝑖)]) @1 @0 p)], + [δ 𝑗 ⇒ [(ss @𝑗, coe (𝑖 ⇒ [0.P (ss @𝑖)]) @1 @𝑗 p)]]) + } ss0 + }} + +def subdup : 0.(A : ★) → 0.(P : A → ★) → 0.(Irr1 A P) → + ((x : A) → Dup A x) → + (s : Sub A P) → SubDup A P s = + λ A P pirr dup s ⇒ + case s return s' ⇒ SubDup A P s' of { (x, p) ⇒ + drop0 (P x) (Dup A x) p (dup x) + } + +def dup : 0.(A : ★) → 0.(P : A → ★) → 0.(Irr1 A P) → + ((x : A) → Dup A x) → + (s : Sub A P) → Dup (Sub A P) s = + λ A P pirr dup s ⇒ subdup-to-dup A P pirr s (subdup A P pirr dup s) + +def forget : 0.(A : ★) → 0.(P : A → ★) → Sub A P → A = + λ A P s ⇒ case s return A of { (x, p) ⇒ drop0 (P x) A p x } diff --git a/stdlib/list.quox b/stdlib/list.quox new file mode 100644 index 0000000..2bab51e --- /dev/null +++ b/stdlib/list.quox @@ -0,0 +1,590 @@ +load "misc.quox" +load "nat.quox" +load "maybe.quox" +load "bool.quox" +load "qty.quox" + +namespace vec { + +def0 Vec : ℕ → ★ → ★ = + λ n A ⇒ + caseω n return ★ of { + zero ⇒ {nil}; + succ _, 0.Tail ⇒ A × Tail + } + +def drop-nil-dep : 0.(A : ★) → 0.(P : Vec 0 A → ★) → + (xs : Vec 0 A) → P 'nil → P xs = + λ A P xs p ⇒ case xs return xs' ⇒ P xs' of { 'nil ⇒ p } + +def drop-nil : 0.(A B : ★) → Vec 0 A → B → B = + λ A B ⇒ drop-nil-dep A (λ _ ⇒ B) + +def match-dep : + 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) → + ω.(P 0 'nil) → + ω.((n : ℕ) → (x : A) → (xs : Vec n A) → P (succ n) (x, xs)) → + (n : ℕ) → (xs : Vec n A) → P n xs = + λ A P pn pc n ⇒ + case n return n' ⇒ (xs : Vec n' A) → P n' xs of { + 0 ⇒ λ nil ⇒ drop-nil-dep A (P 0) nil pn; + succ len ⇒ λ cons ⇒ + case cons return cons' ⇒ P (succ len) cons' of { + (first, rest) ⇒ pc len first rest + } + } + +def match-depω : + 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) → + ω.(P 0 'nil) → + ω.(ω.(n : ℕ) → ω.(x : A) → ω.(xs : Vec n A) → P (succ n) (x, xs)) → + ω.(n : ℕ) → ω.(xs : Vec n A) → P n xs = + λ A P pn pc n ⇒ + caseω n return n' ⇒ ω.(xs : Vec n' A) → P n' xs of { + 0 ⇒ λ nil ⇒ drop-nil-dep A (P 0) nil pn; + succ len ⇒ λ cons ⇒ + caseω cons return cons' ⇒ P (succ len) cons' of { + (first, rest) ⇒ pc len first rest + } + } +def match-dep# = match-depω + +def elim : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) → + P 0 'nil → + ω.((x : A) → 0.(n : ℕ) → 0.(xs : Vec n A) → + P n xs → P (succ n) (x, xs)) → + (n : ℕ) → (xs : Vec n A) → P n xs = + λ A P pn pc n ⇒ + case n return n' ⇒ (xs' : Vec n' A) → P n' xs' of { + zero ⇒ λ nil ⇒ + case nil return nil' ⇒ P 0 nil' of { 'nil ⇒ pn }; + succ n, IH ⇒ λ cons ⇒ + case cons return cons' ⇒ P (succ n) cons' of { + (first, rest) ⇒ pc first n rest (IH rest) + } + } + +def elim2 : 0.(A B : ★) → 0.(P : (n : ℕ) → Vec n A → Vec n B → ★) → + P 0 'nil 'nil → + ω.((x : A) → (y : B) → 0.(n : ℕ) → + 0.(xs : Vec n A) → 0.(ys : Vec n B) → + P n xs ys → P (succ n) (x, xs) (y, ys)) → + (n : ℕ) → (xs : Vec n A) → (ys : Vec n B) → P n xs ys = + λ A B P pn pc n ⇒ + case n return n' ⇒ (xs : Vec n' A) → (ys : Vec n' B) → P n' xs ys of { + zero ⇒ λ nila nilb ⇒ + drop-nil-dep A (λ n ⇒ P 0 n nilb) nila + (drop-nil-dep B (λ n ⇒ P 0 'nil n) nilb pn); + succ n, IH ⇒ λ consa consb ⇒ + case consa return consa' ⇒ P (succ n) consa' consb of { (a, as) ⇒ + case consb return consb' ⇒ P (succ n) (a, as) consb' of { (b, bs) ⇒ + pc a b n as bs (IH as bs) + } + } + } + +def elim2-uneven : + 0.(A B : ★) → 0.(P : (m n : ℕ) → Vec m A → Vec n B → ★) → + -- both nil + ω.(P 0 0 'nil 'nil) → + -- first nil + ω.((y : B) → 0.(n : ℕ) → 0.(ys : Vec n B) → + P 0 n 'nil ys → P 0 (succ n) 'nil (y, ys)) → + -- second nil + ω.((x : A) → 0.(m : ℕ) → 0.(xs : Vec m A) → + P m 0 xs 'nil → P (succ m) 0 (x, xs) 'nil) → + -- both cons + ω.((x : A) → (y : B) → 0.(m n : ℕ) → + 0.(xs : Vec m A) → 0.(ys : Vec n B) → + P m n xs ys → P (succ m) (succ n) (x, xs) (y, ys)) → + (m n : ℕ) → (xs : Vec m A) → (ys : Vec n B) → P m n xs ys = + λ A B P pnn pnc pcn pcc ⇒ + nat.elim-pair (λ m n ⇒ (xs : Vec m A) → (ys : Vec n B) → P m n xs ys) + (λ xnil ynil ⇒ + let0 Ret = P 0 0 'nil 'nil in + drop-nil A Ret xnil (drop-nil B Ret ynil pnn)) + (λ n IH xnil yys ⇒ + case yys return yys' ⇒ P 0 (succ n) 'nil yys' of { (y, ys) ⇒ + pnc y n ys (IH xnil ys) + }) + (λ m IH xxs ynil ⇒ + case xxs return xxs' ⇒ P (succ m) 0 xxs' 'nil of { (x, xs) ⇒ + pcn x m xs (IH xs ynil) + }) + (λ m n IH xxs yys ⇒ + case xxs return xxs' ⇒ P (succ m) (succ n) xxs' yys of { (x, xs) ⇒ + case yys return yys' ⇒ P (succ m) (succ n) (x, xs) yys' of { (y, ys) ⇒ + pcc x y m n xs ys (IH xs ys) + }}) + +-- haha gross +def elimω : 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) → + ω.(P 0 'nil) → + ω.(ω.(x : A) → ω.(n : ℕ) → ω.(xs : Vec n A) → + ω.(P n xs) → P (succ n) (x, xs)) → + ω.(n : ℕ) → ω.(xs : Vec n A) → P n xs = + λ A P pn pc n ⇒ + caseω n return n' ⇒ ω.(xs' : Vec n' A) → P n' xs' of { + zero ⇒ λ _ ⇒ pn; + succ n, ω.IH ⇒ λ xxs ⇒ + letω x = fst xxs; xs = snd xxs in pc x n xs (IH xs) + } + +def elimω2 : 0.(A B : ★) → 0.(P : (n : ℕ) → Vec n A → Vec n B → ★) → + ω.(P 0 'nil 'nil) → + ω.(ω.(x : A) → ω.(y : B) → ω.(n : ℕ) → + ω.(xs : Vec n A) → ω.(ys : Vec n B) → + ω.(P n xs ys) → P (succ n) (x, xs) (y, ys)) → + ω.(n : ℕ) → ω.(xs : Vec n A) → ω.(ys : Vec n B) → P n xs ys = + λ A B P pn pc n ⇒ + caseω n return n' ⇒ ω.(xs : Vec n' A) → ω.(ys : Vec n' B) → P n' xs ys of { + zero ⇒ λ _ _ ⇒ pn; + succ n, ω.IH ⇒ λ xxs yys ⇒ + letω x = fst xxs; xs = snd xxs; y = fst yys; ys = snd yys in + pc x y n xs ys (IH xs ys) + } + +postulate elimP : + ω.(π : NzQty) → ω.(ρₙ ρₗ : Qty) → + 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) → + FunNz π (P 0 'nil) + (Fun 'any + (FUN-NZ π A (λ x ⇒ FUN ρₙ ℕ (λ n ⇒ FUN ρₗ (Vec n A) (λ xs ⇒ + FunNz π (P n xs) (P (succ n) (x, xs)))))) + (FUN-NZ π ℕ (λ n ⇒ FUN-NZ π (Vec n A) (λ xs ⇒ P n xs)))) +{- + = + λ π ρₙ ρₗ A P ⇒ uhhhhhhhhhhhhhhhhhhh +-} + +def elimω2-uneven : + 0.(A B : ★) → 0.(P : (m n : ℕ) → Vec m A → Vec n B → ★) → + -- both nil + ω.(P 0 0 'nil 'nil) → + -- first nil + ω.(ω.(y : B) → ω.(n : ℕ) → ω.(ys : Vec n B) → + ω.(P 0 n 'nil ys) → P 0 (succ n) 'nil (y, ys)) → + -- second nil + ω.(ω.(x : A) → ω.(m : ℕ) → ω.(xs : Vec m A) → + ω.(P m 0 xs 'nil) → P (succ m) 0 (x, xs) 'nil) → + -- both cons + ω.(ω.(x : A) → ω.(y : B) → ω.(m n : ℕ) → + ω.(xs : Vec m A) → ω.(ys : Vec n B) → + ω.(P m n xs ys) → P (succ m) (succ n) (x, xs) (y, ys)) → + ω.(m n : ℕ) → ω.(xs : Vec m A) → ω.(ys : Vec n B) → P m n xs ys = + λ A B P pnn pnc pcn pcc ⇒ + nat.elim-pairω (λ m n ⇒ ω.(xs : Vec m A) → ω.(ys : Vec n B) → P m n xs ys) + (λ _ _ ⇒ pnn) + (λ n IH xnil yys ⇒ + letω y = fst yys; ys = snd yys in pnc y n ys (IH xnil ys)) + (λ m IH xxs ynil ⇒ + letω x = fst xxs; xs = snd xxs in pcn x m xs (IH xs ynil)) + (λ m n IH xxs yys ⇒ + letω x = fst xxs; xs = snd xxs; y = fst yys; ys = snd yys in + pcc x y m n xs ys (IH xs ys)) + +def zip-with : 0.(A B C : ★) → ω.(A → B → C) → + (n : ℕ) → Vec n A → Vec n B → Vec n C = + λ A B C f ⇒ + elim2 A B (λ n _ _ ⇒ Vec n C) 'nil (λ a b _ _ _ abs ⇒ (f a b, abs)) + +def zip-withω : 0.(A B C : ★) → ω.(ω.A → ω.B → C) → + ω.(n : ℕ) → ω.(Vec n A) → ω.(Vec n B) → Vec n C = + λ A B C f ⇒ + elimω2 A B (λ n _ _ ⇒ Vec n C) 'nil (λ a b _ _ _ abs ⇒ (f a b, abs)) + + +namespace zip-with { + def0 Failure : (A B : ★) → (m n : ℕ) → Vec m A → Vec n B → ★ = + λ A B m n xs ys ⇒ + Sing (Vec m A) xs × Sing (Vec n B) ys × [0. Not (m ≡ n : ℕ)] + + def0 Success : (C : ★) → (m n : ℕ) → ★ = + λ C m n ⇒ Vec n C × [0. m ≡ n : ℕ] + + def0 Result : (A B C : ★) → (m n : ℕ) → Vec m A → Vec n B → ★ = + λ A B C m n xs ys ⇒ + Either (Failure A B m n xs ys) (Success C m n) + + def zip-with-hetω : 0.(A B C : ★) → ω.(A → B → C) → + ω.(m n : ℕ) → (xs : Vec m A) → (ys : Vec n B) → + Result A B C m n xs ys = + λ A B C f m n xs ys ⇒ + let0 TNo : Vec m A → Vec n B → ★ = Failure A B m n; + TYes : ★ = Success C m n; + TRes : Vec m A → Vec n B → ★ = λ xs ys ⇒ Either (TNo xs ys) TYes in + dec.elim (m ≡ n : ℕ) + (λ _ ⇒ (xs : Vec m A) → (ys : Vec n B) → TRes xs ys) + (λ eq xs ys ⇒ + let zs : Vec n C = + zip-with A B C f n (coe (𝑖 ⇒ Vec (eq @𝑖) A) xs) ys in + Right (TNo xs ys) TYes (zs, [eq])) + (λ neq xs ys ⇒ Left (TNo xs ys) TYes + (sing (Vec m A) xs, sing (Vec n B) ys, [neq])) + (nat.eq? m n) xs ys + + def zip-with-het : 0.(A B C : ★) → ω.(A → B → C) → + (m n : ℕ) → (xs : Vec m A) → (ys : Vec n B) → + Result A B C m n xs ys = + λ A B C f m n ⇒ + let0 Ret : ℕ → ℕ → ★ = + λ m n ⇒ (xs : Vec m A) → (ys : Vec n B) → Result A B C m n xs ys in + dup.elim ℕ m (λ m' ⇒ Ret m' n) + (λ m ⇒ dup.elim ℕ n (λ n' ⇒ Ret m n') + (λ n ⇒ zip-with-hetω A B C f m n) (nat.dup! n)) + (nat.dup! m) +} +def0 ZipWith = zip-with.Result +def zip-with-het = zip-with.zip-with-het +def zip-with-hetω = zip-with.zip-with-hetω + +#[compile-scheme "(lambda% (n xs) xs)"] +def up : 0.(A : ★) → (n : ℕ) → Vec n A → Vec¹ n A = + λ A n ⇒ + case n return n' ⇒ Vec n' A → Vec¹ n' A of { + zero ⇒ λ xs ⇒ + case xs return Vec¹ 0 A of { 'nil ⇒ 'nil }; + succ n', f' ⇒ λ xs ⇒ + case xs return Vec¹ (succ n') A of { + (first, rest) ⇒ (first, f' rest) + } + } + +def append : 0.(A : ★) → (m : ℕ) → 0.(n : ℕ) → + Vec m A → Vec n A → Vec (nat.plus m n) A = + λ A m n xs ys ⇒ + elim A (λ m _ ⇒ Vec (nat.plus m n) A) ys (λ x _ _ xsys ⇒ (x, xsys)) m xs + +} + +def0 Vec = vec.Vec + + +namespace list { + +def0 List : ★ → ★ = + λ A ⇒ (len : ℕ) × Vec len A + +def Nil : 0.(A : ★) → List A = + λ A ⇒ (0, 'nil) + +def Cons : 0.(A : ★) → A → List A → List A = + λ A x xs ⇒ case xs return List A of { (len, elems) ⇒ (succ len, x, elems) } + +def single : 0.(A : ★) → A → List A = + λ A x ⇒ Cons A x (Nil A) + +def elim : 0.(A : ★) → 0.(P : List A → ★) → + P (Nil A) → + ω.((x : A) → 0.(xs : List A) → P xs → P (Cons A x xs)) → + (xs : List A) → P xs = + λ A P pn pc xs ⇒ + case xs return xs' ⇒ P xs' of { (len, elems) ⇒ + vec.elim A (λ n xs ⇒ P (n, xs)) + pn (λ x n xs IH ⇒ pc x (n, xs) IH) + len elems + } + +def elimω : 0.(A : ★) → 0.(P : List A → ★) → + ω.(P (Nil A)) → + ω.(ω.(x : A) → ω.(xs : List A) → ω.(P xs) → P (Cons A x xs)) → + ω.(xs : List A) → P xs = + λ A P pn pc xs ⇒ + caseω xs return xs' ⇒ P xs' of { (len, elems) ⇒ + vec.elimω A (λ n xs ⇒ P (n, xs)) + pn (λ x n xs IH ⇒ pc x (n, xs) IH) + len elems + } + +def elim2 : 0.(A B : ★) → 0.(P : List A → List B → ★) → + ω.(P (Nil A) (Nil B)) → + ω.((y : B) → 0.(ys : List B) → + P (Nil A) ys → P (Nil A) (Cons B y ys)) → + ω.((x : A) → 0.(xs : List A) → + P xs (Nil B) → P (Cons A x xs) (Nil B)) → + ω.((x : A) → 0.(xs : List A) → (y : B) → 0.(ys : List B) → + P xs ys → P (Cons A x xs) (Cons B y ys)) → + (xs : List A) → (ys : List B) → P xs ys = + λ A B P pnn pnc pcn pcc xs ys ⇒ + case xs return xs' ⇒ P xs' ys of { (m, xs) ⇒ + case ys return ys' ⇒ P (m, xs) ys' of { (n, ys) ⇒ + vec.elim2-uneven A B (λ m n xs ys ⇒ P (m, xs) (n, ys)) + pnn + (λ y n ys IH ⇒ pnc y (n, ys) IH) + (λ x m xs IH ⇒ pcn x (m, xs) IH) + (λ x y m n xs ys IH ⇒ pcc x (m, xs) y (n, ys) IH) + m n xs ys + }} + +def elimω2 : 0.(A B : ★) → 0.(P : List A → List B → ★) → + ω.(P (Nil A) (Nil B)) → + ω.(ω.(y : B) → ω.(ys : List B) → + ω.(P (Nil A) ys) → P (Nil A) (Cons B y ys)) → + ω.(ω.(x : A) → ω.(xs : List A) → + ω.(P xs (Nil B)) → P (Cons A x xs) (Nil B)) → + ω.(ω.(x : A) → ω.(xs : List A) → ω.(y : B) → ω.(ys : List B) → + ω.(P xs ys) → P (Cons A x xs) (Cons B y ys)) → + ω.(xs : List A) → ω.(ys : List B) → P xs ys = + λ A B P pnn pnc pcn pcc xs ys ⇒ + caseω xs return xs' ⇒ P xs' ys of { (m, xs) ⇒ + caseω ys return ys' ⇒ P (m, xs) ys' of { (n, ys) ⇒ + vec.elimω2-uneven A B (λ m n xs ys ⇒ P (m, xs) (n, ys)) + pnn + (λ y n ys IH ⇒ pnc y (n, ys) IH) + (λ x m xs IH ⇒ pcn x (m, xs) IH) + (λ x y m n xs ys IH ⇒ pcc x (m, xs) y (n, ys) IH) + m n xs ys + }} + +def as-vec : 0.(A : ★) → 0.(P : List A → ★) → (xs : List A) → + (ω.(n : ℕ) → (xs : Vec n A) → P (n, xs)) → P xs = + λ A P xs f ⇒ + case xs return xs' ⇒ P xs' of { (n, xs) ⇒ + dup.elim ℕ n (λ n' ⇒ (xs : Vec n' A) → P (n', xs)) f (nat.dup! n) xs + } + +def match-dep : + 0.(A : ★) → 0.(P : List A → ★) → + ω.(P (Nil A)) → ω.((x : A) → (xs : List A) → P (Cons A x xs)) → + (xs : List A) → P xs = + λ A P pn pc xs ⇒ + case xs return xs' ⇒ P xs' of { + (len, elems) ⇒ + vec.match-dep A (λ n xs ⇒ P (n, xs)) pn (λ n x xs ⇒ pc x (n, xs)) + len elems + } + +def match-depω : + 0.(A : ★) → 0.(P : List A → ★) → + ω.(P (Nil A)) → + ω.(ω.(x : A) → ω.(xs : List A) → P (Cons A x xs)) → + ω.(xs : List A) → P xs = + λ A P pn pc xs ⇒ + vec.match-depω A (λ n xs ⇒ P (n, xs)) pn (λ n x xs ⇒ pc x (n, xs)) + (fst xs) (snd xs) +def match-dep# = match-depω + +def match : 0.(A B : ★) → ω.B → ω.(A → List A → B) → List A → B = + λ A B ⇒ match-dep A (λ _ ⇒ B) + +def matchω : 0.(A B : ★) → ω.B → ω.(ω.A → ω.(List A) → B) → ω.(List A) → B = + λ A B ⇒ match-depω A (λ _ ⇒ B) +def match# = matchω + + +def up : 0.(A : ★) → List A → List¹ A = + λ A xs ⇒ + case xs return List¹ A of { (len, elems) ⇒ + dup.elim'¹ ℕ len (λ _ ⇒ List¹ A) + (λ len eq ⇒ (len, vec.up A len (coe (𝑖 ⇒ Vec (eq @𝑖) A) @1 @0 elems))) + (nat.dup! len) + } + +def foldr : 0.(A B : ★) → B → ω.(A → B → B) → List A → B = + λ A B z f xs ⇒ elim A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs + +def foldl : 0.(A B : ★) → B → ω.(B → A → B) → List A → B = + λ A B z f xs ⇒ + foldr A (B → B) (λ b ⇒ b) (λ a g b ⇒ g (f b a)) xs z + +def map : 0.(A B : ★) → ω.(A → B) → List A → List B = + λ A B f ⇒ foldr A (List B) (Nil B) (λ x ys ⇒ Cons B (f x) ys) + + +-- ugh +def foldrω : 0.(A B : ★) → ω.B → ω.(ω.A → ω.B → B) → ω.(List A) → B = + λ A B z f xs ⇒ elimω A (λ _ ⇒ B) z (λ x _ y ⇒ f x y) xs + +def foldlω : 0.(A B : ★) → ω.B → ω.(ω.B → ω.A → B) → ω.(List A) → B = + λ A B z f xs ⇒ + foldrω A (ω.B → B) (λ b ⇒ b) (λ a g b ⇒ g (f b a)) xs z + +def mapω : 0.(A B : ★) → ω.(ω.A → B) → ω.(List A) → List B = + λ A B f ⇒ foldrω A (List B) (Nil B) (λ x ys ⇒ Cons B (f x) ys) + + +def0 All : (A : ★) → (P : A → ★) → List A → ★ = + λ A P xs ⇒ foldr¹ A ★ True (λ x ps ⇒ P x × ps) (up A xs) + +def append : 0.(A : ★) → List A → List A → List A = + λ A xs ys ⇒ foldr A (List A) ys (Cons A) xs + +def reverse : 0.(A : ★) → List A → List A = + λ A ⇒ foldl A (List A) (Nil A) (λ xs x ⇒ Cons A x xs) + + +def find : 0.(A : ★) → ω.(ω.A → Bool) → ω.(List A) → Maybe A = + λ A p ⇒ + foldlω A (Maybe A) (Nothing A) (λ m x ⇒ maybe.or A m (maybe.check A p x)) + +def cons-first : 0.(A : ★) → ω.A → List (List A) → List (List A) = + λ A x ⇒ + match (List A) (List (List A)) + (single (List A) (single A x)) + (λ xs xss ⇒ Cons (List A) (Cons A x xs) xss) + +def split : 0.(A : ★) → ω.(ω.A → Bool) → ω.(List A) → List (List A) = + λ A p ⇒ + foldrω A (List (List A)) + (Nil (List A)) + (λ x xss ⇒ bool.if (List (List A)) (p x) + (Cons (List A) (Nil A) xss) + (cons-first A x xss)) + +def break : 0.(A : ★) → ω.(ω.A → Bool) → ω.(List A) → List A × List A = + λ A p xs ⇒ + let0 Lst = List A; Lst2 = (Lst × Lst) ∷ ★; State = Either Lst Lst2 in + letω LeftS = Left Lst Lst2; RightS = Right Lst Lst2 in + letω res = + foldlω A State + (LeftS (Nil A)) + (λ acc x ⇒ + either.foldω Lst Lst2 State + (λ xs ⇒ bool.if State (p x) + (RightS (xs, list.single A x)) + (LeftS (Cons A x xs))) + (λ xsys ⇒ + RightS (fst xsys, Cons A x (snd xsys))) acc) + xs ∷ State in + letω res = + either.fold Lst Lst2 Lst2 (λ xs ⇒ (Nil A, xs)) (λ xsys ⇒ xsys) res in + (reverse A (fst res), reverse A (snd res)) + +def uncons : 0.(A : ★) → List A → Maybe (A × List A) = + λ A ⇒ + match A (Maybe (A × List A)) + (Nothing (A × List A)) + (λ x xs ⇒ Just (A × List A) (x, xs)) + +def head : 0.(A : ★) → ω.(List A) → Maybe A = + λ A ⇒ matchω A (Maybe A) (Nothing A) (λ x _ ⇒ Just A x) + +def tail : 0.(A : ★) → ω.(List A) → Maybe (List A) = + λ A ⇒ matchω A (Maybe (List A)) (Nothing (List A)) (λ _ xs ⇒ Just (List A) xs) + +def tail-or-nil : 0.(A : ★) → ω.(List A) → List A = + λ A ⇒ matchω A (List A) (Nil A) (λ _ xs ⇒ xs) + +-- slip (xs, []) = (xs, []) +-- slip (xs, y :: ys) = (y :: xs, ys) +def slip : 0.(A : ★) → List A × List A → List A × List A = + λ A xsys ⇒ + case xsys return List A × List A of { (xs, ys) ⇒ + match A (List A → List A × List A) + (λ xs ⇒ (xs, Nil A)) + (λ y ys xs ⇒ (Cons A y xs, ys)) + ys xs + } + +def split-at' : 0.(A : ★) → ℕ → List A → List A × List A = + λ A n xs ⇒ + (case n return List A × List A → List A × List A of { + 0 ⇒ λ xsys ⇒ xsys; + succ _, f ⇒ λ xsys ⇒ f (slip A xsys) + }) (Nil A, xs) + +def split-at : 0.(A : ★) → ℕ → List A → List A × List A = + λ A n xs ⇒ + case split-at' A n xs return List A × List A of { + (xs', ys) ⇒ (reverse A xs', ys) + } + +def filter : 0.(A : ★) → ω.(ω.A → Bool) → ω.(List A) → List A = + λ A p ⇒ + foldrω A (List A) + (Nil A) + (λ x xs ⇒ bool.if (List A) (p x) (Cons A x xs) xs) + +def length : 0.(A : ★) → ω.(List A) → ℕ = + λ A xs ⇒ fst xs + + +namespace zip-with { + def0 VFailure = vec.zip-with.Failure + def0 VSuccess = vec.zip-with.Success + + def0 Failure : (A B : ★) → List A → List B → ★ = + λ A B xs ys ⇒ VFailure A B (fst xs) (fst ys) (snd xs) (snd ys) + + def0 Result : (A B C : ★) → List A → List B → ★ = + λ A B C xs ys ⇒ Either (Failure A B xs ys) (List C) + + def zip-with : 0.(A B C : ★) → ω.(A → B → C) → + (xs : List A) → (ys : List B) → + Result A B C xs ys = + λ A B C f xs ys ⇒ + let0 Ret = Result A B C in + as-vec A (λ xs' ⇒ Ret xs' ys) xs (λ m xs ⇒ + as-vec B (λ ys' ⇒ Ret (m, xs) ys') ys (λ n ys ⇒ + let0 Err = Failure A B (m, xs) (n, ys) in + either.fold Err (VSuccess C m n) (Ret (m, xs) (n, ys)) + (λ no ⇒ Left Err (List C) no) + (λ yes ⇒ case yes return Ret (m, xs) (n, ys) of { (vec, prf) ⇒ + Right Err (List C) (drop0 (m ≡ n : ℕ) (List C) prf (n, vec)) + }) + (vec.zip-with-hetω A B C f m n xs ys))) +} +def0 ZipWith = zip-with.Result +def zip-with = zip-with.zip-with + +def zip-withω : 0.(A B C : ★) → ω.(ω.A → ω.B → C) → + ω.(xs : List A) → ω.(ys : List B) → + Either [0. Not (fst xs ≡ fst ys : ℕ)] (List C) = + λ A B C f xs ys ⇒ + letω m = fst xs; xs = snd xs; + n = fst ys; ys = snd ys in + let0 Err : ★ = [0. Not (m ≡ n : ℕ)] in + dec.elim (m ≡ n : ℕ) (λ _ ⇒ Either Err (List C)) + (λ mn ⇒ + letω xs = coe (𝑖 ⇒ Vec (mn @𝑖) A) xs in + Right Err (List C) (n, vec.zip-withω A B C f n xs ys)) + (λ nmn ⇒ Left Err (List C) [nmn]) + (nat.eq? m n) +def zip-with# = zip-withω + + +def zip-with-uneven : + 0.(A B C : ★) → ω.(ω.A → ω.B → C) → ω.(List A) → ω.(List B) → List C = + λ A B C f xs ys ⇒ + caseω nat.min (fst xs) (fst ys) + return ω.(List A) → ω.(List B) → List C of { + 0 ⇒ λ _ _ ⇒ Nil C; + succ _, ω.fih ⇒ λ xs ys ⇒ + maybe.foldω (A × List A) (List C) (Nil C) + (λ xxs ⇒ maybe.foldω (B × List B) (List C) (Nil C) + (λ yys ⇒ Cons C (f (fst xxs) (fst yys)) (fih (snd xxs) (snd yys))) + (list.uncons B ys)) + (list.uncons A xs) + } xs ys + + +def sum : List ℕ → ℕ = foldl ℕ ℕ 0 nat.plus +def product : List ℕ → ℕ = foldl ℕ ℕ 1 nat.times + + +namespace mergesort { + def deal : 0.(A : ★) → List A → List A × List A = + λ A ⇒ + let0 One = List A; Pair : ★ = One × One in + foldl A Pair (Nil A, Nil A) + (pair.uncurry' One One (A → Pair) (λ ys zs x ⇒ (Cons A x zs, ys))) + +} + + +postulate0 SchemeList : ★ → ★ + +#[compile-scheme + "(lambda (list) (cons (length list) (fold-right cons 'nil list)))"] +postulate from-scheme : 0.(A : ★) → SchemeList A → List A + +#[compile-scheme + "(lambda (lst) + (do [(lst (cdr lst) (cdr lst)) + (acc '() (cons (car lst) acc))] + [(equal? lst 'nil) (reverse acc)]))"] +postulate to-scheme : 0.(A : ★) → List A → SchemeList A + +} + +def0 List = list.List diff --git a/stdlib/maybe.quox b/stdlib/maybe.quox new file mode 100644 index 0000000..83e96c4 --- /dev/null +++ b/stdlib/maybe.quox @@ -0,0 +1,146 @@ +load "misc.quox" +load "pair.quox" +load "either.quox" + +namespace maybe { + +def0 Tag : ★ = {nothing, just} + +def0 Payload : Tag → ★ → ★ = + λ tag A ⇒ case tag return ★ of { 'nothing ⇒ True; 'just ⇒ A } + +def0 Maybe : ★ → ★ = + λ A ⇒ (t : Tag) × Payload t A + +def tag : 0.(A : ★) → ω.(Maybe A) → Tag = + λ _ x ⇒ caseω x return Tag of { (tag, _) ⇒ tag } + +def Nothing : 0.(A : ★) → Maybe A = + λ _ ⇒ ('nothing, 'true) + +def Just : 0.(A : ★) → A → Maybe A = + λ _ x ⇒ ('just, x) + +def0 IsJustTag : Tag → ★ = + λ t ⇒ case t return ★ of { 'just ⇒ True; 'nothing ⇒ False } + +def0 IsJust : (A : ★) → Maybe A → ★ = + λ A x ⇒ IsJustTag (tag A x) + +def is-just? : 0.(A : ★) → ω.(x : Maybe A) → Dec (IsJust A x) = + λ A x ⇒ + caseω tag A x return t ⇒ Dec (IsJustTag t) of { + 'just ⇒ Yes True 'true; + 'nothing ⇒ No False (λ x ⇒ x) + } + +def0 nothing-unique : + (A : ★) → (x : True) → ('nothing, x) ≡ Nothing A : Maybe A = + λ A x ⇒ + case x return x' ⇒ ('nothing, x') ≡ Nothing A : Maybe A of { + 'true ⇒ δ _ ⇒ ('nothing, 'true) + } + +def elim' : + 0.(A : ★) → + 0.(P : (t : Tag) → Payload t A → ★) → + ω.(P 'nothing 'true) → + ω.((x : A) → P 'just x) → + (t : Tag) → (x : Payload t A) → P t x = + λ A P nothing just tag ⇒ + case tag return t ⇒ (x : Payload t A) → P t x of { + 'nothing ⇒ λ x ⇒ case x return x' ⇒ P 'nothing x' of { 'true ⇒ nothing }; + 'just ⇒ just + } + +def elim : + 0.(A : ★) → + 0.(P : Maybe A → ★) → + ω.(P (Nothing A)) → + ω.((x : A) → P (Just A x)) → + (x : Maybe A) → P x = + λ A P n j x ⇒ + case x return x' ⇒ P x' of { + (tag, payload) ⇒ elim' A (λ x t ⇒ P (x, t)) n j tag payload + } + +def elimω' : + 0.(A : ★) → + 0.(P : (t : Tag) → Payload t A → ★) → + ω.(P 'nothing 'true) → + ω.(ω.(x : A) → P 'just x) → + ω.(t : Tag) → ω.(x : Payload t A) → P t x = + λ A P nothing just tag ⇒ + case tag return t ⇒ ω.(x : Payload t A) → P t x of { + 'nothing ⇒ λ x ⇒ case x return x' ⇒ P 'nothing x' of { 'true ⇒ nothing }; + 'just ⇒ just + } + +def elimω : + 0.(A : ★) → + 0.(P : Maybe A → ★) → + ω.(P (Nothing A)) → + ω.(ω.(x : A) → P (Just A x)) → + ω.(x : Maybe A) → P x = + λ A P n j x ⇒ + caseω x return x' ⇒ P x' of { + (tag, payload) ⇒ elimω' A (λ x t ⇒ P (x, t)) n j tag payload + } + +{- +-- direct elim implementation +def elim : + 0.(A : ★) → + 0.(P : Maybe A → ★) → + ω.(P (Nothing A)) → + ω.((x : A) → P (Just A x)) → + (x : Maybe A) → P x = + λ A P n j x ⇒ + case x return x' ⇒ P x' of { (tag, payload) ⇒ + (case tag + return t ⇒ + 0.(eq : tag ≡ t : Tag) → P (t, coe (𝑖 ⇒ Payload (eq @𝑖) A) payload) + of { + 'nothing ⇒ + λ eq ⇒ + case coe (𝑖 ⇒ Payload (eq @𝑖) A) payload + return p ⇒ P ('nothing, p) + of { 'true ⇒ n }; + 'just ⇒ λ eq ⇒ j (coe (𝑖 ⇒ Payload (eq @𝑖) A) payload) + }) (δ 𝑖 ⇒ tag) + } +-} + +def fold : 0.(A B : ★) → ω.B → ω.(A → B) → Maybe A → B = + λ A B ⇒ elim A (λ _ ⇒ B) + +def foldω : 0.(A B : ★) → ω.B → ω.(ω.A → B) → ω.(Maybe A) → B = + λ A B ⇒ elimω A (λ _ ⇒ B) + +def join : 0.(A : ★) → (Maybe (Maybe A)) → Maybe A = + λ A ⇒ fold (Maybe A) (Maybe A) (Nothing A) (λ x ⇒ x) + +def pair : 0.(A B : ★) → ω.(Maybe A) → ω.(Maybe B) → Maybe (A × B) = + λ A B x y ⇒ + foldω A (Maybe (A × B)) (Nothing (A × B)) + (λ x' ⇒ fold B (Maybe (A × B)) (Nothing (A × B)) + (λ y' ⇒ Just (A × B) (x', y')) y) x + +def map : 0.(A B : ★) → ω.(A → B) → Maybe A → Maybe B = + λ A B f ⇒ fold A (Maybe B) (Nothing B) (λ x ⇒ Just B (f x)) + +def mapω : 0.(A B : ★) → ω.(ω.A → B) → ω.(Maybe A) → Maybe B = + λ A B f ⇒ foldω A (Maybe B) (Nothing B) (λ x ⇒ Just B (f x)) + + +def check : 0.(A : ★) → (ω.A → Bool) → ω.A → Maybe A = + λ A p x ⇒ bool.if (Maybe A) (p x) (Just A x) (Nothing A) + +def or : 0.(A : ★) → Maybe A → ω.(Maybe A) → Maybe A = + λ A l r ⇒ fold A (Maybe A) r (Just A) l + +} + +def0 Maybe = maybe.Maybe +def Just = maybe.Just +def Nothing = maybe.Nothing diff --git a/stdlib/misc.quox b/stdlib/misc.quox new file mode 100644 index 0000000..945c9af --- /dev/null +++ b/stdlib/misc.quox @@ -0,0 +1,261 @@ +namespace true { + def0 True : ★ = {true} + + def drop : 0.(A : ★) → True → A → A = + λ A t x ⇒ case t return A of { 'true ⇒ x } + + def0 eta : (s : True) → s ≡ 'true : True = + λ s ⇒ case s return s' ⇒ s' ≡ 'true : True of { 'true ⇒ δ 𝑖 ⇒ 'true } + + def0 irr : (s t : True) → s ≡ t : True = + λ s t ⇒ + coe (𝑖 ⇒ eta s @𝑖 ≡ t : True) @1 @0 + (coe (𝑖 ⇒ 'true ≡ eta t @𝑖 : True) @1 @0 (δ _ ⇒ 'true)) + + def revive : 0.True → True = λ _ ⇒ 'true +} +def0 True = true.True + +namespace false { + def0 False : ★ = {} + + def void : 0.(A : ★) → 0.False → A = + λ A v ⇒ case0 v return A of { } + + def0 irr : (u v : False) → u ≡ v : False = + λ u v ⇒ void (u ≡ v : False) u + + def revive : 0.False → False = void False +} +def0 False = false.False +def void = false.void + + +def0 Not : ★ → ★ = λ A ⇒ ω.A → False + +def0 Iff : ★ → ★ → ★ = λ A B ⇒ (A → B) × (B → A) + +def0 All : (A : ★) → (A → ★) → ★ = + λ A P ⇒ (x : A) → P x + +def cong : + 0.(A : ★) → 0.(P : A → ★) → 1.(p : All A P) → + 0.(x y : A) → 1.(xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) (p x) (p y) = + λ A P p x y xy ⇒ δ 𝑖 ⇒ p (xy @𝑖) + +def cong' : + 0.(A B : ★) → 1.(f : A → B) → + 0.(x y : A) → 1.(xy : x ≡ y : A) → f x ≡ f y : B = + λ A B ⇒ cong A (λ _ ⇒ B) + +def coherence : + 0.(A B : ★) → 0.(AB : A ≡ B : ★) → 1.(x : A) → + Eq (𝑖 ⇒ AB @𝑖) x (coe (𝑖 ⇒ AB @𝑖) x) = + λ A B AB x ⇒ + δ 𝑗 ⇒ coe (𝑖 ⇒ AB @𝑖) @0 @𝑗 x + + +def0 EqF : (A : ★) → (P : A → ★) → (p : All A P) → (q : All A P) → A → ★ = + λ A P p q x ⇒ p x ≡ q x : P x + +def funext : + 0.(A : ★) → 0.(P : A → ★) → 0.(p q : All A P) → + 1.(All A (EqF A P p q)) → p ≡ q : All A P = + λ A P p q eq ⇒ δ 𝑖 ⇒ λ x ⇒ eq x @𝑖 + +def refl : 0.(A : ★) → 1.(x : A) → x ≡ x : A = λ A x ⇒ δ _ ⇒ x + +def sym : 0.(A : ★) → 0.(x y : A) → 1.(x ≡ y : A) → y ≡ x : A = + λ A x y eq ⇒ coe (𝑗 ⇒ eq @𝑗 ≡ x : A) (δ _ ⇒ eq @0) + -- btw this uses eq @0 instead of just x because of the quantities + +def sym-c : 0.(A : ★) → 0.(x y : A) → 1.(x ≡ y : A) → y ≡ x : A = + λ A x y eq ⇒ δ 𝑖 ⇒ + comp A (eq @0) @𝑖 { 0 𝑗 ⇒ eq @𝑗; 1 _ ⇒ eq @0 } + +{- +def sym-het : 0.(A B : ★) → 0.(AB : A ≡ B : ★) → + 0.(x : A) → 0.(y : B) → + 1.(Eq (𝑖 ⇒ AB @𝑖) x y) → + Eq (𝑖 ⇒ sym¹ ★ A B AB @𝑖) y x = + λ A B AB x y xy ⇒ + let0 BA = sym¹ ★ A B AB; + y' : A = coe (𝑖 ⇒ BA @𝑖) y; + yy' : Eq (𝑖 ⇒ BA @𝑖) y y' = + δ 𝑗 ⇒ coe (𝑖 ⇒ BA @𝑖) @0 @𝑗 y; + in + 0 +-} + +{- + δ 𝑖 ⇒ + comp (𝑗 ⇒ sym¹ ★ A B AB @𝑗) @0 @𝑖 y @𝑖 { + 0 𝑗 ⇒ xy @𝑗; + 1 𝑗 ⇒ xy @𝑗 + } +-} + +def trans10 : 0.(A : ★) → 0.(x y z : A) → + 1.(x ≡ y : A) → 0.(y ≡ z : A) → x ≡ z : A = + λ A x y z eq1 eq2 ⇒ coe (𝑗 ⇒ x ≡ eq2 @𝑗 : A) eq1 + +def trans01 : 0.(A : ★) → 0.(x y z : A) → + 0.(x ≡ y : A) → 1.(y ≡ z : A) → x ≡ z : A = + λ A x y z eq1 eq2 ⇒ coe (𝑗 ⇒ eq1 @𝑗 ≡ z : A) @1 @0 eq2 + +def trans : 0.(A : ★) → 0.(x y z : A) → + ω.(x ≡ y : A) → ω.(y ≡ z : A) → x ≡ z : A = + λ A x y z eq1 eq2 ⇒ trans01 A x y z eq1 eq2 + +{- +def trans-het : 0.(A B C : ★) → 0.(AB : A ≡ B : ★) → 0.(BC : B ≡ C : ★) → + 0.(x : A) → 0.(y : B) → 0.(z : C) → + ω.(Eq (𝑖 ⇒ AB @𝑖) x y) → + ω.(Eq (𝑖 ⇒ BC @𝑖) y z) → + Eq (𝑖 ⇒ trans¹ ★ A B C AB BC @𝑖) x z += + λ A B C AB BC x y z xy yz ⇒ + let 0.AC = trans¹ ★ A B C AB BC; + 0.y' : A = coe (𝑗 ⇒ AB @𝑗) @1 @0 y; + in + δ 𝑖 ⇒ + trans (AC @𝑖) (coe (𝑗 ⇒ AC @𝑗) @0 @𝑖 x) + (coe (𝑗 ⇒ AC @𝑗) @0 @𝑖 y') + (coe (𝑗 ⇒ AC @𝑗) @1 @𝑖 z) + 0 + 0 + @𝑖 + +def0 trans-trans-het : + (A : ★) → (x y z : A) → + (xy : x ≡ y : A) → (yz : y ≡ z : A) → + Eq (_ ⇒ x ≡ z : A) + (trans A x y z xy yz) + (trans-het A A A (δ _ ⇒ A) (δ _ ⇒ A) x y z xy yz) = + λ A x y z xy yz ⇒ δ _ ⇒ trans A x y z xy yz +-} + +def appω : 0.(A B : ★) → ω.(f : ω.A → B) → [ω.A] → [ω.B] = + λ A B f x ⇒ case x return [ω.B] of { [x'] ⇒ [f x'] } +def app# = appω + +def app2ω : 0.(A B C : ★) → ω.(f : ω.A → ω.B → C) → [ω.A] → [ω.B] → [ω.C] = + λ A B C f x y ⇒ + case x return [ω.C] of { [x'] ⇒ + case y return [ω.C] of { [y'] ⇒ [f x' y'] } + } +def app2# = app2ω + +def getω : 0.(A : ★) → [ω.A] → A = + λ A x ⇒ case x return A of { [x] ⇒ x } +def get# = getω + +def0 get0 : (A : ★) → [0.A] → A = + λ A x ⇒ case x return A of { [x] ⇒ x } + +def0 get0-box : (A : ★) → (b : [0.A]) → + [get0 A b] ≡ b : [0.A] = + λ A b ⇒ case b return b' ⇒ [get0 A b'] ≡ b' : [0.A] of { [x] ⇒ δ _ ⇒ [x] } + +def drop0 : 0.(A B : ★) → [0.A] → B → B = + λ A B x y ⇒ case x return B of { [_] ⇒ y } + +def0 drop0-eq : (A B : ★) → (x : [0.A]) → (y : B) → drop0 A B x y ≡ y : B = + λ A B x y ⇒ + case x return x' ⇒ drop0 A B x' y ≡ y : B of { [_] ⇒ δ 𝑖 ⇒ y } + +def0 HEq : (A B : ★) → A → B → ★¹ = + λ A B x y ⇒ (AB : A ≡ B : ★) × Eq (𝑖 ⇒ AB @𝑖) x y + +def0 boxω-inj : (A : ★) → (x y : A) → [x] ≡ [y] : [ω.A] → x ≡ y : A = + λ A x y xy ⇒ δ 𝑖 ⇒ getω A (xy @𝑖) +-- [todo] change lexical syntax to allow "box#-inj" + +def revive0 : 0.(A : ★) → 0.[0.A] → [0.A] = + λ A s ⇒ [get0 A s] + + +namespace sing { + +def0 Sing : (A : ★) → A → ★ = + λ A x ⇒ (val : A) × [0. val ≡ x : A] + +def sing : 0.(A : ★) → (x : A) → Sing A x = + λ A x ⇒ (x, [δ _ ⇒ x]) + +def val : 0.(A : ★) → 0.(x : A) → Sing A x → A = + λ A x sg ⇒ + case sg return A of { (x', eq) ⇒ drop0 (x' ≡ x : A) A eq x' } + +def0 val-fst : (A : ★) → (x : A) → (sg : Sing A x) → val A x sg ≡ fst sg : A = + λ A x sg ⇒ drop0-eq (fst sg ≡ x : A) A (snd sg) (fst sg) + +def0 proof : (A : ★) → (x : A) → (sg : Sing A x) → val A x sg ≡ x : A = + λ A x sg ⇒ + trans A (val A x sg) (fst sg) x + (val-fst A x sg) (get0 (fst sg ≡ x : A) (snd sg)) + +def app : 0.(A B : ★) → 0.(x : A) → + (f : A → B) → Sing A x → Sing B (f x) = + λ A B x f sg ⇒ + let 1.x' = val A x sg; + 0.xx = proof A x sg in + (f x', [δ 𝑖 ⇒ f (xx @𝑖)]) + +} + +def0 Sing = sing.Sing +def sing = sing.sing + + +namespace dup { + +def0 Dup : (A : ★) → A → ★ = + λ A x ⇒ Sing [ω.A] [x] + +def from-parts : + 0.(A : ★) → + (dup : A → [ω.A]) → + 0.(prf : (x : A) → dup x ≡ [x] : [ω.A]) → + (x : A) → Dup A x = + λ A dup prf x ⇒ (dup x, [prf x]) + +def to-drop : 0.(A : ★) → (A → [ω.A]) → 0.(B : ★) → A → B → B = + λ A dup B x y ⇒ case dup x return B of { [_] ⇒ y } + +def erased : 0.(A : ★) → (x : [0.A]) → Dup [0.A] x = + λ A x ⇒ case x return x' ⇒ Dup [0.A] x' of { [x] ⇒ sing [ω.[0.A]] [[x]] } + +def valω : 0.(A : ★) → 0.(x : A) → Dup A x → [ω.A] = + λ A x ⇒ sing.val [ω.A] [x] +def val# = valω + +def val : 0.(A : ★) → 0.(x : A) → Dup A x → A = + λ A x x! ⇒ getω A (valω A x x!) + +def0 proofω : (A : ★) → (x : A) → (x! : Dup A x) → valω A x x! ≡ [x] : [ω.A] = + λ A x x! ⇒ sing.proof [ω.A] [x] x! +def0 proof# : (A : ★) → (x : A) → (x! : Dup A x) → val# A x x! ≡ [x] : [ω.A] = + proofω + +def0 proof : (A : ★) → (x : A) → (x! : Dup A x) → val A x x! ≡ x : A = + λ A x x! ⇒ δ 𝑖 ⇒ getω A (proofω A x x! @𝑖) + +def elim' : 0.(A : ★) → 0.(x : A) → 0.(P : A → ★) → + (ω.(x' : A) → 0.(x' ≡ x : A) → P x) → Dup A x → P x = + λ A x P f x! ⇒ + let xω : [ω.A] = sing.val [ω.A] [x] x! in + case xω return xω' ⇒ 0.(xω' ≡ xω : [ω.A]) → P x of { [x'] ⇒ λ eq1 ⇒ + let0 eq2 = sing.proof [ω.A] [x] x!; + eq = boxω-inj A x' x (trans [ω.A] [x'] xω [x] eq1 eq2) in + f x' eq + } (δ _ ⇒ xω) + +def elim : 0.(A : ★) → 0.(x : A) → 0.(P : A → ★) → + (ω.(x' : A) → P x') → Dup A x → P x = + λ A x P f ⇒ elim' A x P (λ x' xx ⇒ coe (𝑖 ⇒ P (xx @𝑖)) (f x')) + + +} + +def0 Dup = dup.Dup diff --git a/stdlib/nat.quox b/stdlib/nat.quox new file mode 100644 index 0000000..d2e620f --- /dev/null +++ b/stdlib/nat.quox @@ -0,0 +1,297 @@ +load "misc.quox" +load "bool.quox" +load "either.quox" +load "sub.quox" + +namespace nat { + +def elim-0-1 : + 0.(P : ℕ → ★) → + ω.(P 0) → ω.(P 1) → + ω.(0.(n : ℕ) → P n → P (succ n)) → + (n : ℕ) → P n = + λ P p0 p1 ps n ⇒ + case n return n' ⇒ P n' of { + zero ⇒ p0; + succ n' ⇒ + case n' return n'' ⇒ P (succ n'') of { + zero ⇒ p1; + succ n'', IH ⇒ ps (succ n'') IH + } + } + +def elim-pair : + 0.(P : ℕ → ℕ → ★) → + ω.(P 0 0) → + ω.(0.(n : ℕ) → P 0 n → P 0 (succ n)) → + ω.(0.(m : ℕ) → P m 0 → P (succ m) 0) → + ω.(0.(m n : ℕ) → P m n → P (succ m) (succ n)) → + (m n : ℕ) → P m n = + λ P zz zs sz ss m ⇒ + case m return m' ⇒ (n : ℕ) → P m' n of { + 0 ⇒ λ n ⇒ case n return n' ⇒ P 0 n' of { + 0 ⇒ zz; + succ n', ihn ⇒ zs n' ihn + }; + succ m', ihm ⇒ λ n ⇒ case n return n' ⇒ P (succ m') n' of { + 0 ⇒ sz m' (ihm 0); + succ n' ⇒ ss m' n' (ihm n') + } + } + +def elim-pairω : + 0.(P : ℕ → ℕ → ★) → + ω.(P 0 0) → + ω.(ω.(n : ℕ) → ω.(P 0 n) → P 0 (succ n)) → + ω.(ω.(m : ℕ) → ω.(P m 0) → P (succ m) 0) → + ω.(ω.(m n : ℕ) → ω.(P m n) → P (succ m) (succ n)) → + ω.(m n : ℕ) → P m n = + λ P zz zs sz ss m ⇒ + caseω m return m' ⇒ ω.(n : ℕ) → P m' n of { + 0 ⇒ λ n ⇒ caseω n return n' ⇒ P 0 n' of { + 0 ⇒ zz; + succ n', ω.ihn ⇒ zs n' ihn + }; + succ m', ω.ihm ⇒ λ n ⇒ caseω n return n' ⇒ P (succ m') n' of { + 0 ⇒ sz m' (ihm 0); + succ n' ⇒ ss m' n' (ihm n') + } + } + + +def succ-boxω : [ω.ℕ] → [ω.ℕ] = + λ n ⇒ case n return [ω.ℕ] of { [n] ⇒ [succ n] } + +#[compile-scheme "(lambda (n) n)"] +def dup : ℕ → [ω.ℕ] = + λ n ⇒ case n return [ω.ℕ] of { + 0 ⇒ [0]; + succ _, n! ⇒ succ-boxω n! + } + +def0 dup-ok : (n : ℕ) → dup n ≡ [n] : [ω.ℕ] = + λ n ⇒ + case n return n' ⇒ dup n' ≡ [n'] : [ω.ℕ] of { + 0 ⇒ δ 𝑖 ⇒ [0]; + succ _, ih ⇒ δ 𝑖 ⇒ succ-boxω (ih @𝑖) + } + +def dup! : (n : ℕ) → Dup ℕ n = + dup.from-parts ℕ dup dup-ok + + +def drop : 0.(A : ★) → ℕ → A → A = + dup.to-drop ℕ dup + + +def natopω' : 0.(A : ★) → ω.(ω.ℕ → ω.ℕ → A) → ℕ → ℕ → A = + λ A f m n ⇒ + getω A (app2ω ℕ ℕ A f (dup m) (dup n)) + +def natopω = natopω' ℕ + +#[compile-scheme "(lambda% (m n) (+ m n))"] +def plus : ℕ → ℕ → ℕ = + λ m n ⇒ + case m return ℕ of { + zero ⇒ n; + succ _, p ⇒ succ p + } + +#[compile-scheme "(lambda% (m n) (* m n))"] +def timesω : ω.ℕ → ω.ℕ → ℕ = + λ m n ⇒ + case m return ℕ of { + zero ⇒ zero; + succ _, t ⇒ plus n t + } + +def times = natopω timesω + +def pred : ℕ → ℕ = λ n ⇒ case n return ℕ of { zero ⇒ zero; succ n ⇒ n } + +def pred-succ : ω.(n : ℕ) → pred (succ n) ≡ n : ℕ = + λ n ⇒ δ 𝑖 ⇒ n + +def succ-inj : 0.(m n : ℕ) → succ m ≡ succ n : ℕ → m ≡ n : ℕ = + λ m n eq ⇒ δ 𝑖 ⇒ pred (eq @𝑖) + +#[compile-scheme "(lambda% (m n) (max 0 (- m n)))"] +def minus : ℕ → ℕ → ℕ = + λ m n ⇒ + (case n return ℕ → ℕ of { + zero ⇒ λ m ⇒ m; + succ _, f ⇒ λ m ⇒ f (pred m) + }) m + + +def minω : ω.ℕ → ω.ℕ → ℕ = + elim-pairω (λ _ _ ⇒ ℕ) 0 (λ _ _ ⇒ 0) (λ _ _ ⇒ 0) (λ _ _ x ⇒ succ x) + +def min = natopω minω + + +def0 IsSucc : ℕ → ★ = + λ n ⇒ case n return ★ of { zero ⇒ False; succ _ ⇒ True } + +def is-succ? : ω.(n : ℕ) → Dec (IsSucc n) = + λ n ⇒ + caseω n return n' ⇒ Dec (IsSucc n') of { + zero ⇒ No (IsSucc zero) (λ v ⇒ v); + succ n ⇒ Yes (IsSucc (succ n)) 'true + } + +def zero-not-succ : 0.(m : ℕ) → Not (zero ≡ succ m : ℕ) = + λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) @1 @0 'true + +def succ-not-zero : 0.(m : ℕ) → Not (succ m ≡ zero : ℕ) = + λ m eq ⇒ coe (𝑖 ⇒ IsSucc (eq @𝑖)) 'true + +def0 not-succ-self : (m : ℕ) → Not (m ≡ succ m : ℕ) = + λ m ⇒ + case m return m' ⇒ Not (m' ≡ succ m' : ℕ) of { + zero ⇒ zero-not-succ 0; + succ n, ω.ih ⇒ λ eq ⇒ ih (succ-inj n (succ n) eq) + } + + +def0 IsSuccOf : ℕ → ℕ → ★ = + λ n p ⇒ n ≡ succ p : ℕ + +def0 PredOf : ℕ → ★ = + λ n ⇒ Sub ℕ (IsSuccOf n) + +def0 no-pred0 : Not (PredOf 0) = + λ p ⇒ + case p return False of { (p, lt) ⇒ + zero-not-succ p (get0 (0 ≡ succ p : ℕ) lt) + } + +def pred? : (n : ℕ) → DecT (PredOf n) = + λ n ⇒ + case n return n' ⇒ DecT (PredOf n') of { + zero ⇒ NoT (PredOf zero) no-pred0; + succ n ⇒ YesT (PredOf (succ n)) (n, [δ _ ⇒ succ n]) + } + +namespace pred-of { + +def revive : (n : ℕ) → 0.(PredOf n) → PredOf n = + λ n hs ⇒ + let0 p = fst hs in + case n return n' ⇒ 0.(n' ≡ succ p : ℕ) → PredOf n' of { + zero ⇒ λ eq ⇒ void (PredOf zero) (zero-not-succ p eq); + succ p' ⇒ λ _ ⇒ (p', [δ _ ⇒ succ p']) + } (get0 (n ≡ succ p : ℕ) (snd hs)) + +def val : 0.(n : ℕ) → PredOf n → ℕ = + λ n ⇒ sub.val ℕ (IsSuccOf n) + +def0 proof : (n : ℕ) → (p : PredOf n) → n ≡ succ (fst p) : ℕ = + λ n ⇒ sub.proof ℕ (IsSuccOf n) + +} + + +def divmodω : ω.ℕ → ω.ℕ → ℕ × ℕ = + -- https://coq.inria.fr/doc/V8.18.0/stdlib/Coq.Init.Nat.html#divmod + letω divmod' : ℕ → ω.ℕ → ℕ → ℕ → ℕ × ℕ = + λ x ⇒ + case x return ω.ℕ → ℕ → ℕ → ℕ × ℕ of { + 0 ⇒ λ y q u ⇒ (q, u); + succ _, f' ⇒ λ y q u ⇒ + case u return ℕ × ℕ of { + 0 ⇒ f' y (succ q) y; + succ u' ⇒ f' y q u' + } + } in + λ x y ⇒ + caseω y return ℕ × ℕ of { + 0 ⇒ (0, 0); + succ y' ⇒ + case divmod' x y' 0 y' return ℕ × ℕ of { (d, m) ⇒ (d, minus y' m) } + } + +def divmod = natopω' (ℕ × ℕ) divmodω + +def divω : ω.ℕ → ω.ℕ → ℕ = λ x y ⇒ fst (divmodω x y) +def div = natopω divω + +def modω : ω.ℕ → ω.ℕ → ℕ = λ x y ⇒ snd (divmodω x y) +def mod = natopω modω + + +#[compile-scheme "(lambda% (m n) (if (= m n) Yes No))"] +def eq? : DecEq ℕ = + λ m n ⇒ + elim-pair (λ m n ⇒ Dec (m ≡ n : ℕ)) + (Yes (0 ≡ 0 : ℕ) (δ 𝑖 ⇒ 0)) + (λ n p ⇒ + dec.drop (0 ≡ n : ℕ) (Dec (0 ≡ succ n : ℕ)) p + (No (0 ≡ succ n : ℕ) (λ zs ⇒ zero-not-succ n zs))) + (λ m p ⇒ + dec.drop (m ≡ 0 : ℕ) (Dec (succ m ≡ 0 : ℕ)) p + (No (succ m ≡ 0 : ℕ) (λ sz ⇒ succ-not-zero m sz))) + (λ m n ⇒ + dec.elim (m ≡ n : ℕ) (λ _ ⇒ Dec (succ m ≡ succ n : ℕ)) + (λ yy ⇒ Yes (succ m ≡ succ n : ℕ) (δ 𝑖 ⇒ succ (yy @𝑖))) + (λ nn ⇒ No (succ m ≡ succ n : ℕ) (λ yy ⇒ nn (succ-inj m n yy)))) + m n + + +def0 Ordering : ★ = {lt, eq, gt} + +namespace ordering { + def from : 0.(A : ★) → ω.A → ω.A → ω.A → Ordering → A = + λ A lt eq gt o ⇒ + case o return A of { 'lt ⇒ lt; 'eq ⇒ eq; 'gt ⇒ gt } + + def drop : 0.(A : ★) → Ordering → A → A = + λ A o x ⇒ case o return A of { 'lt ⇒ x; 'eq ⇒ x; 'gt ⇒ x } + + def eq : Ordering → Ordering → Bool = + λ x y ⇒ + case x return Bool of { + 'lt ⇒ case y return Bool of { 'lt ⇒ 'true; 'eq ⇒ 'false; 'gt ⇒ 'false }; + 'eq ⇒ case y return Bool of { 'lt ⇒ 'false; 'eq ⇒ 'true; 'gt ⇒ 'false }; + 'gt ⇒ case y return Bool of { 'lt ⇒ 'false; 'eq ⇒ 'false; 'gt ⇒ 'true }; + } +} + +def compare : ℕ → ℕ → Ordering = + elim-pair (λ _ _ ⇒ Ordering) + 'eq + (λ _ o ⇒ ordering.drop Ordering o 'lt) + (λ _ o ⇒ ordering.drop Ordering o 'gt) + (λ _ _ x ⇒ x) + +def lt : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ ordering.eq (compare m n) 'lt +def eq : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ ordering.eq (compare m n) 'eq +def gt : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ ordering.eq (compare m n) 'gt +def ne : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ bool.not (eq m n) +def le : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ bool.not (gt m n) +def ge : ω.ℕ → ω.ℕ → Bool = λ m n ⇒ bool.not (lt m n) + + +def0 plus-zero : (m : ℕ) → m ≡ plus m 0 : ℕ = + λ m ⇒ + case m return m' ⇒ m' ≡ plus m' 0 : ℕ of { + zero ⇒ δ _ ⇒ 0; + succ m', ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖) + } + +def0 plus-succ : (m n : ℕ) → succ (plus m n) ≡ plus m (succ n) : ℕ = + λ m n ⇒ + case m return m' ⇒ succ (plus m' n) ≡ plus m' (succ n) : ℕ of { + zero ⇒ δ _ ⇒ succ n; + succ _, ih ⇒ δ 𝑖 ⇒ succ (ih @𝑖) + } + +def0 times-zero : (m : ℕ) → 0 ≡ timesω m 0 : ℕ = + λ m ⇒ + case m return m' ⇒ 0 ≡ timesω m' 0 : ℕ of { + zero ⇒ δ _ ⇒ zero; + succ m', ih ⇒ ih + } + +} diff --git a/stdlib/pair.quox b/stdlib/pair.quox new file mode 100644 index 0000000..9f93009 --- /dev/null +++ b/stdlib/pair.quox @@ -0,0 +1,67 @@ +namespace pair { + +def0 Σ : (A : ★) → (A → ★) → ★ = λ A B ⇒ (x : A) × B x + +def uncurry : + 0.(A : ★) → 0.(B : A → ★) → 0.(C : (x : A) → (B x) → ★) → + (f : (x : A) → (y : B x) → C x y) → + (p : Σ A B) → C (fst p) (snd p) = + λ A B C f p ⇒ + case p return p' ⇒ C (fst p') (snd p') of { (x, y) ⇒ f x y } + +def uncurry' : + 0.(A B C : ★) → (A → B → C) → (A × B) → C = + λ A B C ⇒ uncurry A (λ _ ⇒ B) (λ _ _ ⇒ C) + +def curry : + 0.(A : ★) → 0.(B : A → ★) → 0.(C : (Σ A B) → ★) → + (f : (p : Σ A B) → C p) → (x : A) → (y : B x) → C (x, y) = + λ A B C f x y ⇒ f (x, y) + +def curry' : + 0.(A B C : ★) → (A × B → C) → A → B → C = + λ A B C ⇒ curry A (λ _ ⇒ B) (λ _ ⇒ C) + +def0 fst-snd : + (A : ★) → (B : A → ★) → + (p : Σ A B) → p ≡ (fst p, snd p) : Σ A B = + λ A B p ⇒ δ 𝑖 ⇒ p -- η + +def0 fst-eq : + (A : ★) → (B : A → ★) → + (p q : Σ A B) → p ≡ q : Σ A B → fst p ≡ fst q : A = + λ A B p q eq ⇒ δ 𝑖 ⇒ fst (eq @𝑖) + +def0 snd-eq : + (A : ★) → (B : A → ★) → + (p q : Σ A B) → (eq : p ≡ q : Σ A B) → + Eq (𝑖 ⇒ B (fst-eq A B p q eq @𝑖)) (snd p) (snd q) = + λ A B p q eq ⇒ δ 𝑖 ⇒ snd (eq @𝑖) + +def0 pair-eq : + (A : ★) → (B : A → ★) → + (x0 x1 : A) → (y0 : B x0) → (y1 : B x1) → + (xx : x0 ≡ x1 : A) → (yy : Eq (𝑖 ⇒ B (xx @𝑖)) y0 y1) → + (x0, y0) ≡ (x1, y1) : ((x : A) × B x) = + λ A B x0 x1 y0 y1 xx yy ⇒ δ 𝑖 ⇒ (xx @𝑖, yy @𝑖) + +def map : + 0.(A A' : ★) → + 0.(B : A → ★) → 0.(B' : A' → ★) → + (f : A → A') → (g : 0.(x : A) → (B x) → B' (f x)) → + Σ A B → Σ A' B' = + λ A A' B B' f g p ⇒ + case p return Σ A' B' of { (x, y) ⇒ (f x, g x y) } + +def map' : 0.(A A' B B' : ★) → (A → A') → (B → B') → (A × B) → A' × B' = + λ A A' B B' f g ⇒ map A A' (λ _ ⇒ B) (λ _ ⇒ B') f (λ _ ⇒ g) + +def map-fst : 0.(A A' B : ★) → (A → A') → A × B → A' × B = + λ A A' B f ⇒ map' A A' B B f (λ x ⇒ x) + +def map-snd : 0.(A B B' : ★) → (B → B') → A × B → A × B' = + λ A B B' f ⇒ map' A A B B' (λ x ⇒ x) f + +} + +def0 Σ = pair.Σ diff --git a/stdlib/qty.quox b/stdlib/qty.quox new file mode 100644 index 0000000..673b4d4 --- /dev/null +++ b/stdlib/qty.quox @@ -0,0 +1,156 @@ +load "misc.quox" + +def0 Qty : ★ = {"zero", one, any} + +def0 NzQty : ★ = {one, any} + +def nz : NzQty → Qty = + λ π ⇒ case π return Qty of { 'one ⇒ 'one; 'any ⇒ 'any } + +def dup! : (π : Qty) → Dup Qty π = + λ π ⇒ case π return π' ⇒ Dup Qty π' of { + 'zero ⇒ (['zero], [δ _ ⇒ ['zero]]); + 'one ⇒ (['one], [δ _ ⇒ ['one]]); + 'any ⇒ (['any], [δ _ ⇒ ['any]]); + } + +def dup : (π : Qty) → [ω.Qty] = + λ π ⇒ dup.valω Qty π (dup! π) + +def drop : 0.(A : ★) → Qty → A → A = + λ A π x ⇒ case π return A of { + 'zero ⇒ x; + 'one ⇒ x; + 'any ⇒ x; + } + +def if-zero : 0.(A : ★) → Qty → ω.A → ω.A → A = + λ A π z nz ⇒ + case π return A of { 'zero ⇒ z; 'one ⇒ nz; 'any ⇒ nz } + +def plus : Qty → ω.Qty → Qty = + λ π ρ ⇒ + case π return Qty of { + 'zero ⇒ ρ; + 'one ⇒ if-zero Qty ρ 'one 'any; + 'any ⇒ 'any; + } + +def times : Qty → ω.Qty → Qty = + λ π ρ ⇒ + case π return Qty of { + 'zero ⇒ 'zero; + 'one ⇒ ρ; + 'any ⇒ if-zero Qty ρ 'zero 'any; + } + +def0 FUN : Qty → (A : ★) → (A → ★) → ★ = + λ π A B ⇒ + case π return ★ of { + 'zero ⇒ 0.(x : A) → B x; + 'one ⇒ 1.(x : A) → B x; + 'any ⇒ ω.(x : A) → B x; + } + +def0 FUN-NZ : NzQty → (A : ★) → (A → ★) → ★ = + λ π A B ⇒ + case π return ★ of { + 'one ⇒ 1.(x : A) → B x; + 'any ⇒ ω.(x : A) → B x; + } + +def0 Fun : Qty → ★ → ★ → ★ = + λ π A B ⇒ FUN π A (λ _ ⇒ B) + +def0 FunNz : NzQty → ★ → ★ → ★ = + λ π A B ⇒ FUN-NZ π A (λ _ ⇒ B) + +def0 Box : Qty → ★ → ★ = + λ π A ⇒ + case π return ★ of { + 'zero ⇒ [0.A]; + 'one ⇒ [1.A]; + 'any ⇒ [ω.A]; + } + +def0 BoxNz : NzQty → ★ → ★ = + λ π A ⇒ + case π return ★ of { + 'one ⇒ [1.A]; + 'any ⇒ [ω.A]; + } + +def0 unbox : (π : Qty) → (A : ★) → Box π A → A = + λ π A ⇒ + case π return π' ⇒ Box π' A → A of { + 'zero ⇒ λ x ⇒ case x return A of { [x] ⇒ x }; + 'one ⇒ λ x ⇒ case x return A of { [x] ⇒ x }; + 'any ⇒ λ x ⇒ case x return A of { [x] ⇒ x }; + } + +def0 unbox0 = unbox 'zero +def0 unbox1 = unbox 'one +def0 unboxω = unbox 'any + +def0 unbox-nz : (π : NzQty) → (A : ★) → BoxNz π A → A = + λ π A ⇒ + case π return π' ⇒ BoxNz π' A → A of { + 'one ⇒ λ x ⇒ case x return A of { [x] ⇒ x }; + 'any ⇒ λ x ⇒ case x return A of { [x] ⇒ x }; + } + +def0 unbox-nz1 = unbox-nz 'one +def0 unbox-nzω = unbox-nz 'any + +def apply : (π : Qty) → 0.(A : ★) → 0.(B : A → ★) → + FUN π A B → (x : Box π A) → B (unbox π A x) = + λ π A B ⇒ + case π + return π' ⇒ FUN π' A B → (x : Box π' A) → B (unbox π' A x) + of { + 'zero ⇒ λ f x ⇒ case x return x' ⇒ B (unbox0 A x') of { [x] ⇒ f x }; + 'one ⇒ λ f x ⇒ case x return x' ⇒ B (unbox1 A x') of { [x] ⇒ f x }; + 'any ⇒ λ f x ⇒ case x return x' ⇒ B (unboxω A x') of { [x] ⇒ f x }; + } + +def apply' : (π : Qty) → 0.(A B : ★) → Fun π A B → (x : Box π A) → B = + λ π A B ⇒ apply π A (λ _ ⇒ B) + +def apply-nz : (π : NzQty) → 0.(A : ★) → 0.(B : A → ★) → + FUN-NZ π A B → (x : BoxNz π A) → B (unbox-nz π A x) = + λ π A B ⇒ + case π + return π' ⇒ FUN-NZ π' A B → (x : BoxNz π' A) → B (unbox-nz π' A x) + of { + 'one ⇒ λ f x ⇒ case x return x' ⇒ B (unbox-nz1 A x') of { [x] ⇒ f x }; + 'any ⇒ λ f x ⇒ case x return x' ⇒ B (unbox-nzω A x') of { [x] ⇒ f x }; + } + +def apply-nz' : (π : NzQty) → 0.(A B : ★) → FunNz π A B → (x : BoxNz π A) → B = + λ π A B ⇒ apply-nz π A (λ _ ⇒ B) + +def lam : (π : Qty) → 0.(A : ★) → 0.(B : A → ★) → + ((x : Box π A) → B (unbox π A x)) → FUN π A B = + λ π A B ⇒ + case π + return π' ⇒ ((x : Box π' A) → B (unbox π' A x)) → FUN π' A B of { + 'zero ⇒ λ f x ⇒ f [x]; + 'one ⇒ λ f x ⇒ f [x]; + 'any ⇒ λ f x ⇒ f [x]; + } + +def lam' : (π : Qty) → 0.(A B : ★) → (Box π A → B) → Fun π A B = + λ π A B ⇒ lam π A (λ _ ⇒ B) + +def lam-nz : (π : NzQty) → 0.(A : ★) → 0.(B : A → ★) → + ((x : BoxNz π A) → B (unbox-nz π A x)) → FUN-NZ π A B = + λ π A B ⇒ + case π + return π' ⇒ ((x : BoxNz π' A) → B (unbox-nz π' A x)) → FUN-NZ π' A B of { + 'one ⇒ λ f x ⇒ f [x]; + 'any ⇒ λ f x ⇒ f [x]; + } + +def lam-nz' : (π : NzQty) → 0.(A B : ★) → (BoxNz π A → B) → FunNz π A B = + λ π A B ⇒ lam-nz π A (λ _ ⇒ B) + diff --git a/stdlib/string.quox b/stdlib/string.quox new file mode 100644 index 0000000..f59c799 --- /dev/null +++ b/stdlib/string.quox @@ -0,0 +1,144 @@ +load "bool.quox" +load "list.quox" +load "maybe.quox" +load "either.quox" + +namespace char { + +postulate0 Char : ★ + +#[compile-scheme "(lambda (c) c)"] +postulate dup : Char → [ω.Char] + +#[compile-scheme "char->integer"] +postulate to-ℕ : Char → ℕ + +#[compile-scheme "integer->char"] +postulate from-ℕ : ℕ → Char + +def space = from-ℕ 0x20 +def tab = from-ℕ 0x09 +def newline = from-ℕ 0x0a + +def test-via-ℕ : (ω.ℕ → ω.ℕ → Bool) → (ω.Char → ω.Char → Bool) = + λ p c d ⇒ p (to-ℕ c) (to-ℕ d) +def lt = test-via-ℕ nat.lt +def eq = test-via-ℕ nat.eq +def gt = test-via-ℕ nat.gt +def le = test-via-ℕ nat.le +def ne = test-via-ℕ nat.ne +def ge = test-via-ℕ nat.ge + +postulate0 eq-iff-nat : (c d : Char) → Iff (c ≡ d : Char) (to-ℕ c ≡ to-ℕ d : ℕ) + +def eq? : DecEq Char = + λ c d ⇒ + let0 Ty = (c ≡ d : Char) ∷ ★ in + dec.elim (to-ℕ c ≡ to-ℕ d : ℕ) (λ _ ⇒ Dec Ty) + (λ y ⇒ Yes Ty ((snd (eq-iff-nat c d)) y)) + (λ n ⇒ No Ty (λ y ⇒ n ((fst (eq-iff-nat c d)) y))) + (nat.eq? (to-ℕ c) (to-ℕ d)) + +def ws? : ω.Char → Bool = + λ c ⇒ bool.or (bool.or (eq c space) (eq c tab)) (eq c newline) + +def digit? : ω.Char → Bool = + λ c ⇒ bool.and (ge c (from-ℕ 0x30)) (le c (from-ℕ 0x39)) + +def digit-val : Char → Maybe ℕ = + λ c ⇒ case dup c return Maybe ℕ of { [c] ⇒ + bool.if (Maybe ℕ) (digit? c) + (Just ℕ (nat.minus (to-ℕ c) 0x30)) + (Nothing ℕ) + } + +} + +def0 Char = char.Char + +namespace string { + +#[compile-scheme "string->list"] +postulate to-scheme-list : String → list.SchemeList Char + +def to-list : String → List Char = + λ str ⇒ list.from-scheme Char (to-scheme-list str) + +#[compile-scheme "list->string"] +postulate from-scheme-list : list.SchemeList Char → String + +def from-list : List Char → String = + λ cs ⇒ from-scheme-list (list.to-scheme Char cs) + +def foldl : 0.(A : ★) → A → ω.(A → Char → A) → String → A = + λ A z f str ⇒ list.foldl Char A z f (to-list str) + +def foldlω : 0.(A : ★) → ω.A → ω.(ω.A → ω.Char → A) → ω.String → A = + λ A z f str ⇒ list.foldlω Char A z f (to-list str) + +def split : ω.(ω.Char → Bool) → ω.String → List String = + λ p str ⇒ + list.map (List Char) String from-list + (list.split Char p (to-list str)) + +def break : ω.(ω.Char → Bool) → ω.String → String × String = + λ p str ⇒ + letω pair = list.break Char p (to-list str) in + (from-list (fst pair), from-list (snd pair)) + +def reverse : String → String = + λ str ⇒ from-list (list.reverse Char (to-list str)) + +#[compile-scheme "(lambda% (y n a b) (if (string=? a b) y n))"] +postulate eq' : 0.(A : ★) → A → A → ω.String → ω.String → A +def eq : ω.String → ω.String → Bool = eq' Bool 'true 'false + +def null : ω.String → Bool = eq "" +def not-null : ω.String → Bool = λ s ⇒ bool.not (null s) + +#[compile-scheme "(lambda (str) str)"] +postulate dup : String → [ω.String] + +postulate0 dup-ok : (str : String) → dup str ≡ [str] : [ω.String] + +def dup! : (str : String) → Dup String str = + dup-from-parts String dup dup-ok + + +def to-ℕ : String → Maybe ℕ = + letω add-digit : Maybe ℕ → ℕ → Maybe ℕ = + maybe.fold ℕ (ℕ → Maybe ℕ) (λ d ⇒ Just ℕ d) + (λ n d ⇒ Just ℕ (nat.plus (nat.times 10 n) d)) in + letω drop : Maybe ℕ → Maybe ℕ = + maybe.fold ℕ (Maybe ℕ) (Nothing ℕ) + (λ n ⇒ nat.drop (Maybe ℕ) n (Nothing ℕ)) in + letω add-digit-c : Maybe ℕ → Char → Maybe ℕ = + λ acc c ⇒ + maybe.fold ℕ (Maybe ℕ → Maybe ℕ) drop (λ n acc ⇒ add-digit acc n) + (char.digit-val c) acc in + λ str ⇒ + case dup str return Maybe ℕ of { [str] ⇒ + bool.if (Maybe ℕ) (not-null str) + (foldl (Maybe ℕ) (Just ℕ 0) add-digit-c str) + (Nothing ℕ) + } + +def to-ℕ-or-0 : String → ℕ = + λ str ⇒ maybe.fold ℕ ℕ 0 (λ x ⇒ x) (to-ℕ str) + + +#[compile-scheme + "(lambda% (yes no str) + (let [(len (string-length str))] + (if (= len 0) + no + (let [(first (string-ref str 0)) + (rest (substring str 1 len))] + (% yes first rest)))))"] +postulate uncons' : 0.(A : ★) → ω.A → ω.(Char → String → A) → String → A + +def uncons : String → Maybe (Char × String) = + let0 Pair : ★ = Char × String in + uncons' (Maybe Pair) (Nothing Pair) (λ c s ⇒ Just Pair (c, s)) + +} diff --git a/stdlib/sub.quox b/stdlib/sub.quox new file mode 100644 index 0000000..61128a4 --- /dev/null +++ b/stdlib/sub.quox @@ -0,0 +1,159 @@ +load "misc.quox" +load "either.quox" +load "maybe.quox" + +namespace sub { + +def0 Irr : (A : ★) → ★ = + λ A ⇒ (x y : A) → x ≡ y : A + +def0 Irr1 : (A : ★) → (A → ★) → ★ = + λ A P ⇒ (x : A) → Irr (P x) + +def0 Irr2 : (A B : ★) → (A → B → ★) → ★ = + λ A B P ⇒ (x : A) → (y : B) → Irr (P x y) + +def0 Sub : (A : ★) → (P : A → ★) → ★ = + λ A P ⇒ (x : A) × [0. P x] + + +def sub : 0.(A : ★) → 0.(P : A → ★) → (x : A) → 0.(P x) → Sub A P = + λ A P x p ⇒ (x, [p]) + +def sub? : 0.(A : ★) → 0.(P : A → ★) → (ω.(x : A) → Dec (P x)) → + ω.A → Maybe (Sub A P) = + λ A P p? x ⇒ + dec.elim (P x) (λ _ ⇒ Maybe (Sub A P)) + (λ y ⇒ Just (Sub A P) (x, [y])) + (λ n ⇒ Nothing (Sub A P)) + (p? x) + + +def val : 0.(A : ★) → 0.(P : A → ★) → Sub A P → A = + λ A P s ⇒ case s return A of { (x, p) ⇒ drop0 (P x) A p x } + +def0 proof : 0.(A : ★) → 0.(P : A → ★) → (s : Sub A P) → P (fst s) = + λ A P s ⇒ get0 (P (fst s)) (snd s) + +{- + +def0 proof' : 0.(A : ★) → 0.(P : A → ★) → (s : Sub A P) → P (fst s) = + λ A P s ⇒ get0 (P (fst s)) (snd s) + +def0 val-fst : (A : ★) → (P : A → ★) → + (s : Sub A P) → val A P s ≡ fst s : A = + λ A P s ⇒ + case s return s' ⇒ val A P s' ≡ fst s' : A of { + (x, p) ⇒ drop0-eq (P x) A p x + } + +def0 proof : 0.(A : ★) → 0.(P : A → ★) → (s : Sub A P) → P (val A P s) = + λ A P s ⇒ coe (𝑖 ⇒ P (val-fst A P s @𝑖)) @1 @0 (proof' A P s) + +postulate0 proof-snd' : (A : ★) → (P : A → ★) → (s : Sub A P) → + Eq (𝑖 ⇒ P (val-fst A P s @𝑖)) (proof A P s) (proof' A P s) + +postulate0 proof-snd : (A : ★) → (P : A → ★) → (s : Sub A P) → + Eq (𝑖 ⇒ [0.P (val-fst A P s @𝑖)]) [proof A P s] (snd s) + +#![log (all, 10) (equal, 100)] +def0 val-proof-eq : (A : ★) → (P : A → ★) → (s : Sub A P) → + sub A P (val A P s) (proof A P s) ≡ s : Sub A P = + λ A P s ⇒ + case s return s' ⇒ sub A P (val A P s') (proof A P s') ≡ s' : Sub A P + of { (xxxxx, p) ⇒ + case p + return p' ⇒ + sub A P (val A P (xxxxx, p')) (proof A P (xxxxx, p')) ≡ (xxxxx, p') : Sub A P + of { [p0] ⇒ + δ 𝑖 ⇒ (val-fst A P (xxxxx, [p0]) @𝑖, proof-snd A P (xxxxx, [p0]) @𝑖) + } + } +#![log pop] + +def elim' : 0.(A : ★) → 0.(P : A → ★) → + 0.(R : (x : A) → P x → ★) → + (1.(x : A) → 0.(p : P x) → R x p) → + (s : Sub A P) → R (val A P s) (proof A P s) = + λ A P R p s ⇒ p (val A P s) (proof A P s) + +{- +def elim : 0.(A : ★) → 0.(P : A → ★) → + 0.(R : Sub A P → ★) → + (1.(x : A) → 0.(p : P x) → R (x, [p])) → + (s : Sub A P) → R s = + λ A P R p s ⇒ p (val A P s) (proof A P s) +-} + +-} + + + +def0 SubDup : (A : ★) → (P : A → ★) → Sub A P → ★ = + λ A P s ⇒ Dup A (fst s) + -- (x! : [ω.A]) × [0. x! ≡ [fst s] : [ω.A]] + +def subdup-to-dup : + 0.(A : ★) → 0.(P : A → ★) → + 0.(s : Sub A P) → SubDup A P s → Dup (Sub A P) s = + λ A P s sd ⇒ + case sd return Dup (Sub A P) s of { (sω, ss0) ⇒ + case ss0 return Dup (Sub A P) s of { [ss0] ⇒ + case sω + return sω' ⇒ 0.(sω' ≡ [fst s] : [ω.A]) → Dup (Sub A P) s + of { [s!] ⇒ λ ss' ⇒ + let ω.p : [0.P (fst s)] = revive0 (P (fst s)) (snd s); + 0.ss : s! ≡ fst s : A = boxω-inj A s! (fst s) ss' in + ([(s!, coe (𝑖 ⇒ [0.P (ss @𝑖)]) @1 @0 p)], + [δ 𝑗 ⇒ [(ss @𝑗, coe (𝑖 ⇒ [0.P (ss @𝑖)]) @1 @𝑗 p)]]) + } ss0 + }} + +def subdup : 0.(A : ★) → 0.(P : A → ★) → + ((x : A) → Dup A x) → + (s : Sub A P) → SubDup A P s = + λ A P dup s ⇒ + case s return s' ⇒ SubDup A P s' of { (x, p) ⇒ + drop0 (P x) (Dup A x) p (dup x) + } + +def dup! : 0.(A : ★) → 0.(P : A → ★) → ((x : A) → Dup A x) → + (s : Sub A P) → Dup (Sub A P) s = + λ A P dupA s ⇒ subdup-to-dup A P s (subdup A P dupA s) + + +def0 irr1-het : (A : ★) → (P : A → ★) → Irr1 A P → + (x y : A) → (p : P x) → (q : P y) → + (xy : x ≡ y : A) → Eq (𝑖 ⇒ P (xy @𝑖)) p q = + λ A P pirr x y p q xy ⇒ δ 𝑖 ⇒ + pirr (xy @𝑖) (coe (𝑗 ⇒ P (xy @𝑗)) @0 @𝑖 p) (coe (𝑗 ⇒ P (xy @𝑗)) @1 @𝑖 q) @𝑖 + +def0 irr2-het : (A B : ★) → (P : A → B → ★) → Irr2 A B P → + (x₀ x₁ : A) → (y₀ y₁ : B) → (p : P x₀ y₀) → (q : P x₁ y₁) → + (xx : x₀ ≡ x₁ : A) → (yy : y₀ ≡ y₁ : B) → + Eq (𝑖 ⇒ P (xx @𝑖) (yy @𝑖)) p q = + λ A B P pirr x₀ x₁ y₀ y₁ p q xx yy ⇒ δ 𝑖 ⇒ + pirr (xx @𝑖) (yy @𝑖) + (coe (𝑗 ⇒ P (xx @𝑗) (yy @𝑗)) @0 @𝑖 p) + (coe (𝑗 ⇒ P (xx @𝑗) (yy @𝑗)) @1 @𝑖 q) @𝑖 + + +def0 sub-eq : (A : ★) → (P : A → ★) → Irr1 A P → + (x y : Sub A P) → fst x ≡ fst y : A → x ≡ y : Sub A P = + λ A P pirr x y xy0 ⇒ δ 𝑖 ⇒ + let proof = proof A P in + (xy0 @𝑖, [irr1-het A P pirr (fst x) (fst y) (proof x) (proof y) xy0 @𝑖]) + + +def eq? : 0.(A : ★) → 0.(P : A → ★) → 0.(Irr1 A P) → + DecEq A → DecEq (Sub A P) = + λ A P pirr aeq? s t ⇒ + let0 EQ : ★ = s ≡ t : Sub A P in + dec.elim (fst s ≡ fst t : A) (λ _ ⇒ Dec EQ) + (λ y ⇒ Yes EQ (sub-eq A P pirr s t y)) + (λ n ⇒ No EQ (λ eq ⇒ n (δ 𝑖 ⇒ fst (eq @𝑖)))) + (aeq? (fst s) (fst t)) + +} + +def0 Sub = sub.Sub From 01e16e20e54d29bf34b92df6830847f636915981 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Mon, 6 May 2024 19:21:56 +0200 Subject: [PATCH 126/133] more bib stuff --- quox.bib | 167 +++++++++++++++++++++++++++++++++++++++++++++++++++++-- 1 file changed, 162 insertions(+), 5 deletions(-) diff --git a/quox.bib b/quox.bib index c673ea5..25412e6 100644 --- a/quox.bib +++ b/quox.bib @@ -1,4 +1,4 @@ -% quantitative stuff +% quantitative/modal stuff {{{1 @inproceedings{grtt, author = {Moon, Benjamin and @@ -63,8 +63,118 @@ doi = {10.1145/3209108.3209189} } +@article{frac-uniq, + author = {Marshall, Daniel and Orchard, Dominic}, + title = {Functional Ownership through Fractional Uniqueness}, + year = {2024}, + publisher = {Association for Computing Machinery}, + address = {New York, NY, USA}, + volume = {8}, + number = {OOPSLA1}, + url = {https://doi.org/10.1145/3649848}, + doi = {10.1145/3649848}, + journal = {Proc. ACM Program. Lang.}, +} -% observational stuff +@article{rustbelt, + author = {Jung, Ralf and + Jourdan, Jacques-Henri and + Krebbers, Robbert and + Dreyer, Derek}, + title = {{RustBelt}: + securing the foundations of the {R}ust programming language}, + year = {2017}, + publisher = {Association for Computing Machinery}, + address = {New York, NY, USA}, + volume = {2}, + number = {POPL}, + url = {https://doi.org/10.1145/3158154}, + doi = {10.1145/3158154}, + journal = {Proc. ACM Program. Lang.}, +} + +@article{lightweight-rust, + author = {Pearce, David J.}, + title = {A Lightweight Formalism for Reference Lifetimes + and Borrowing in Rust}, + year = {2021}, + publisher = {Association for Computing Machinery}, + volume = {43}, + number = {1}, + url = {https://doi.org/10.1145/3443420}, + doi = {10.1145/3443420}, + journal = {ACM Trans. Program. Lang. Syst.}, +} + +@misc{oxide, + title = {Oxide: The Essence of Rust}, + author = {Aaron Weiss and + Olek Gierczak and + Daniel Patterson and + Amal Ahmed}, + year = {2021}, + eprint = {1903.00982}, + archivePrefix = {arXiv}, + primaryClass = {cs.PL} +} + +@inproceedings{frac-perms, + author = {John Boyland}, + editor = {Radhia Cousot}, + title = {Checking Interference with Fractional Permissions}, + booktitle = {Static Analysis, 10th International Symposium, {SAS} 2003, + San Diego, CA, USA, June 11-13, 2003, Proceedings}, + series = {Lecture Notes in Computer Science}, + volume = {2694}, + pages = {55--72}, + publisher = {Springer}, + year = {2003}, + url = {https://doi.org/10.1007/3-540-44898-5\_4}, + doi = {10.1007/3-540-44898-5\_4}, +} + +@inproceedings{linexp-graded, + title = {Linear Exponentials as Graded Modal Types}, + author = {Hughes, Jack and + Marshall, Daniel and + Wood, James and + Orchard, Dominic}, + url = {https://hal-lirmm.ccsd.cnrs.fr/lirmm-03271465}, + booktitle = {5th International Workshop on + Trends in Linear Logic and Applications ({TLLA} 2021)}, + year = {2021}, + month = Jun, +} + +@inproceedings{alms, + author = {Tov, Jesse A. and Pucella, Riccardo}, + title = {Practical affine types}, + year = {2011}, + publisher = {Association for Computing Machinery}, + url = {https://users.cs.northwestern.edu/~jesse/pubs/alms/tovpucella-alms.pdf}, + doi = {10.1145/1926385.1926436}, + booktitle = {Proceedings of the 38th Annual ACM SIGPLAN-SIGACT + Symposium on Principles of Programming Languages}, +} + +@inproceedings{rrr, + author = {Daniel Marshall and Dominic Orchard}, + editor = {Marco Carbone and Rumyana Neykova}, + title = {Replicate, Reuse, Repeat: Capturing Non-Linear Communication + via Session Types and Graded Modal Types}, + booktitle = {Proceedings of the 13th International Workshop on Programming + Language Approaches to Concurrency and Communication-cEntric + Software, PLACES@ETAPS 2022, Munich, Germany, 3rd April 2022}, + series = {{EPTCS}}, + volume = {356}, + pages = {1--11}, + year = {2022}, + url = {https://arxiv.org/abs/2203.12875}, + doi = {10.4204/EPTCS.356.1}, +} + + +% observational stuff {{{1 @inproceedings{ott-now, author = {Thorsten Altenkirch and @@ -111,8 +221,15 @@ doi = {10.4230/LIPIcs.FSCD.2019.31} } +@unpublished{cubical-ott, + author = {James Chapman and Fredrik Nordvall Forsberg and Conor {McBride}}, + title = {The Box of Delights (Cubical Observational Type Theory)}, + year = {2018}, + url = {https://github.com/msp-strath/platypus/blob/138daf7/January18/doc/CubicalOTT/CubicalOTT.pdf}, +} -% NbE + +% NbE {{{1 @article{nbe-mltt, title = {Normalization by Evaluation for Martin-Löf Type Theory with @@ -184,7 +301,7 @@ doi = {10.4204/EPTCS.153.4} } -% Misc type stuff +% Misc type stuff {{{1 @article{calf, author = {Niu, Yue and @@ -337,7 +454,45 @@ } -% Misc implementation +% Misc type stuff {{{1 + +@inproceedings{local, + author = {Michael Vollmer and + Chaitanya Koparkar and + Mike Rainey and + Laith Sakka and + Milind Kulkarni and + Ryan R. Newton}, + editor = {Kathryn S. McKinley and + Kathleen Fisher}, + title = {{LoCal}: a language for programs operating on serialized data}, + booktitle = {Proceedings of the 40th {ACM} {SIGPLAN} Conference on Programming + Language Design and Implementation, {PLDI} 2019, Phoenix, AZ, + USA, June 22-26, 2019}, + pages = {48--62}, + publisher = {{ACM}}, + year = {2019}, + url = {http://recurial.com/pldi19main.pdf}, + doi = {10.1145/3314221.3314631}, +} + +@article{mlsub-pearl, + author = {Parreaux, Lionel}, + title = {The simple essence of algebraic subtyping: principal type + inference with subtyping made easy (functional pearl)}, + year = {2020}, + publisher = {Association for Computing Machinery}, + address = {New York, NY, USA}, + volume = {4}, + number = {ICFP}, + url = {https://doi.org/10.1145/3409006}, + doi = {10.1145/3409006}, + journal = {Proc. ACM Program. Lang.}, + month = {aug}, +} + + +% Misc implementation {{{1 @article{expl-sub, author = {Martín Abadi and @@ -412,3 +567,5 @@ url = {https://www.cs.tufts.edu/~nr/cs257/archive/mike-sperber/shift-reset-direct.pdf}, doi = {10.1145/581478.581504}, } + +% vim: set fdm=marker : From 3e23929b5f2787815add2f532c5b0835239155da Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 5 May 2024 19:41:06 +0200 Subject: [PATCH 127/133] export infix --- lib/Quox/BoolExtra.idr | 4 ++-- lib/Quox/Context.idr | 6 +++--- lib/Quox/Loc.idr | 2 +- lib/Quox/Log.idr | 2 +- lib/Quox/No.idr | 2 +- lib/Quox/Syntax/DimEq.idr | 2 +- lib/Quox/Syntax/Shift.idr | 2 +- lib/Quox/Syntax/Subst.idr | 4 ++-- lib/Quox/Syntax/Term/Base.idr | 2 -- tests/AstExtra.idr | 2 +- tests/Tests/PrettyTerm.idr | 2 +- 11 files changed, 14 insertions(+), 16 deletions(-) diff --git a/lib/Quox/BoolExtra.idr b/lib/Quox/BoolExtra.idr index 69a7495..7a34ac1 100644 --- a/lib/Quox/BoolExtra.idr +++ b/lib/Quox/BoolExtra.idr @@ -3,8 +3,8 @@ module Quox.BoolExtra import public Data.Bool -infixr 5 `andM` -infixr 4 `orM` +export infixr 5 `andM` +export infixr 4 `orM` public export andM, orM : Monad m => m Bool -> m Bool -> m Bool diff --git a/lib/Quox/Context.idr b/lib/Quox/Context.idr index a13a624..97daabd 100644 --- a/lib/Quox/Context.idr +++ b/lib/Quox/Context.idr @@ -158,12 +158,12 @@ getWith : (forall from, to. tm from -> Shift from to -> tm to) -> Context tm len -> Var len -> tm len getWith shft = getShiftWith shft SZ -infixl 8 !! +export infixl 8 !! public export %inline (!!) : CanShift tm => Context tm len -> Var len -> tm len (!!) = getWith (//) -infixl 8 !!! +export infixl 8 !!! public export %inline (!!!) : Context' tm len -> Var len -> tm (!!!) = getWith const @@ -206,7 +206,7 @@ parameters {auto _ : Applicative f} traverse' : (a -> f b) -> Telescope' a from to -> f (Telescope' b from to) traverse' f = traverse f - infixl 3 `app` + export infixl 3 `app` ||| like `(<*>)` but with effects export app : Telescope (\n => tm1 n -> f (tm2 n)) from to -> diff --git a/lib/Quox/Loc.idr b/lib/Quox/Loc.idr index 7aeb229..fae1bf8 100644 --- a/lib/Quox/Loc.idr +++ b/lib/Quox/Loc.idr @@ -108,7 +108,7 @@ extendL : Loc -> Loc -> Loc extendL l1 l2 = l1 `extend'` l2.bounds -infixr 1 `or_`, `or` +export infixr 1 `or_`, `or` export %inline or_ : Loc_ -> Loc_ -> Loc_ or_ l1@(YesLoc {}) _ = l1 diff --git a/lib/Quox/Log.idr b/lib/Quox/Log.idr index 6630bb6..08d1873 100644 --- a/lib/Quox/Log.idr +++ b/lib/Quox/Log.idr @@ -163,7 +163,7 @@ record LogMsg where level : Nat {auto 0 levelOk : IsLogLevel level} message : Lazy LogDoc -infix 0 :> +export infix 0 :> %name Log.LogMsg msg public export diff --git a/lib/Quox/No.idr b/lib/Quox/No.idr index 59cbca1..4134485 100644 --- a/lib/Quox/No.idr +++ b/lib/Quox/No.idr @@ -43,7 +43,7 @@ parameters {0 a, b : Bool} noOr2 = snd . noOr -infixr 1 `orNo` +export infixr 1 `orNo` export %inline orNo : No a -> No b -> No (a || b) orNo Ah Ah = Ah diff --git a/lib/Quox/Syntax/DimEq.idr b/lib/Quox/Syntax/DimEq.idr index a224641..885eebd 100644 --- a/lib/Quox/Syntax/DimEq.idr +++ b/lib/Quox/Syntax/DimEq.idr @@ -123,7 +123,7 @@ equal ZeroIsOne p q = True equal (C eqs) p q = get eqs p == get eqs q -infixl 7 : Maybe (Dim d) -> DimEq (S d) ZeroIsOne : Shift from to -> f to diff --git a/lib/Quox/Syntax/Subst.idr b/lib/Quox/Syntax/Subst.idr index aebe6a4..1e14d4d 100644 --- a/lib/Quox/Syntax/Subst.idr +++ b/lib/Quox/Syntax/Subst.idr @@ -20,7 +20,7 @@ data Subst : (Nat -> Type) -> Nat -> Nat -> Type where (:::) : (t : Lazy (env to)) -> Subst env from to -> Subst env (S from) to %name Subst th, ph, ps -infixr 7 !::: +export infixr 7 !::: ||| in case the automatic laziness insertion gets confused public export (!:::) : env to -> Subst env from to -> Subst env (S from) to @@ -42,7 +42,7 @@ export Ord (f to) => Ord (Subst f from to) where compare = compare `on` repr export Show (f to) => Show (Subst f from to) where show = show . repr -infixl 8 // +export infixl 8 // public export interface FromVar term => CanSubstSelf term where (//) : term from -> Lazy (Subst term from to) -> term to diff --git a/lib/Quox/Syntax/Term/Base.idr b/lib/Quox/Syntax/Term/Base.idr index 88e7b07..75bae76 100644 --- a/lib/Quox/Syntax/Term/Base.idr +++ b/lib/Quox/Syntax/Term/Base.idr @@ -47,8 +47,6 @@ TagVal : Type TagVal = String -infixl 8 :# -infixl 9 :@, :% mutual public export TSubst : TSubstLike diff --git a/tests/AstExtra.idr b/tests/AstExtra.idr index 76257b7..9dfb70a 100644 --- a/tests/AstExtra.idr +++ b/tests/AstExtra.idr @@ -4,7 +4,7 @@ import Quox.Syntax import Quox.Parser.Syntax import Quox.Typing.Context -prefix 9 ^ +export prefix 9 ^ public export (^) : (Loc -> a) -> a (^) a = a noLoc diff --git a/tests/Tests/PrettyTerm.idr b/tests/Tests/PrettyTerm.idr index 551a444..30c84cd 100644 --- a/tests/Tests/PrettyTerm.idr +++ b/tests/Tests/PrettyTerm.idr @@ -24,7 +24,7 @@ parameters (ds : BContext d) (ns : BContext n) testPrettyE1 e str {label} = testPrettyT1 (E e) str {label} -prefix 9 ^ +export prefix 9 ^ (^) : (Loc -> a) -> a (^) a = a noLoc From 519cc4779abf8f15f820e13acd006889287fea24 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 2 Jun 2024 17:34:08 +0200 Subject: [PATCH 128/133] add xtt2 and hofmann's quotient types to bib --- quox.bib | 29 +++++++++++++++++++++++++++++ 1 file changed, 29 insertions(+) diff --git a/quox.bib b/quox.bib index 25412e6..5c2ca0a 100644 --- a/quox.bib +++ b/quox.bib @@ -221,6 +221,17 @@ doi = {10.4230/LIPIcs.FSCD.2019.31} } +@article{xtt2, + author = {Jonathan Sterling and Carlo Angiuli and Daniel Gratzer}, + title = {A Cubical Language for Bishop Sets}, + journal = {Log. Methods Comput. Sci.}, + volume = {18}, + number = {1}, + year = {2022}, + url = {https://doi.org/10.46298/lmcs-18(1:43)2022}, + doi = {10.46298/LMCS-18(1:43)2022}, +} + @unpublished{cubical-ott, author = {James Chapman and Fredrik Nordvall Forsberg and Conor {McBride}}, title = {The Box of Delights (Cubical Observational Type Theory)}, @@ -456,6 +467,24 @@ % Misc type stuff {{{1 +% not open access. i cry +@inproceedings{simple-quotient, + author = {Martin Hofmann}, + editor = {Mariangiola Dezani{-}Ciancaglini and Gordon D. Plotkin}, + title = {A Simple Model for Quotient Types}, + booktitle = {Typed Lambda Calculi and Applications, + Second International Conference on Typed Lambda Calculi and + Applications, {TLCA} '95, Edinburgh, UK, April 10-12, 1995, + Proceedings}, + series = {Lecture Notes in Computer Science}, + volume = {902}, + pages = {216--234}, + publisher = {Springer}, + year = {1995}, + url = {https://doi.org/10.1007/BFb0014055}, + doi = {10.1007/BFB0014055}, +} + @inproceedings{local, author = {Michael Vollmer and Chaitanya Koparkar and From 7b3ccfc45a912f52e80a5f419b6177b0ae1e7c93 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 2 Jun 2024 17:34:52 +0200 Subject: [PATCH 129/133] comment out a partial definition in list.quox --- stdlib/list.quox | 2 ++ 1 file changed, 2 insertions(+) diff --git a/stdlib/list.quox b/stdlib/list.quox index 2bab51e..5b34ee4 100644 --- a/stdlib/list.quox +++ b/stdlib/list.quox @@ -144,6 +144,7 @@ def elimω2 : 0.(A B : ★) → 0.(P : (n : ℕ) → Vec n A → Vec n B → ★ pc x y n xs ys (IH xs ys) } +{- postulate elimP : ω.(π : NzQty) → ω.(ρₙ ρₗ : Qty) → 0.(A : ★) → 0.(P : (n : ℕ) → Vec n A → ★) → @@ -156,6 +157,7 @@ postulate elimP : = λ π ρₙ ρₗ A P ⇒ uhhhhhhhhhhhhhhhhhhh -} +-} def elimω2-uneven : 0.(A B : ★) → 0.(P : (m n : ℕ) → Vec m A → Vec n B → ★) → From 68c414a94162550faaa4c783f022dae9c1e74275 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 2 Jun 2024 17:34:58 +0200 Subject: [PATCH 130/133] add vec.map --- stdlib/list.quox | 3 +++ 1 file changed, 3 insertions(+) diff --git a/stdlib/list.quox b/stdlib/list.quox index 5b34ee4..feaa0a7 100644 --- a/stdlib/list.quox +++ b/stdlib/list.quox @@ -240,6 +240,9 @@ def0 ZipWith = zip-with.Result def zip-with-het = zip-with.zip-with-het def zip-with-hetω = zip-with.zip-with-hetω +def map : 0.(A B : ★) → ω.(A → B) → (n : ℕ) → Vec n A → Vec n B = + λ A B f ⇒ elim A (λ n _ ⇒ Vec n B) 'nil (λ x _ _ ys ⇒ (f x, ys)) + #[compile-scheme "(lambda% (n xs) xs)"] def up : 0.(A : ★) → (n : ℕ) → Vec n A → Vec¹ n A = λ A n ⇒ From f00c802336e29154b8d02ba7bbec5a9d1d638adc Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Sun, 2 Jun 2024 17:35:56 +0200 Subject: [PATCH 131/133] functions returning subsings are also subsings --- golden-tests/tests/isprop-subsing/expected | 2 ++ golden-tests/tests/isprop-subsing/isprop-subsing.quox | 4 ++++ golden-tests/tests/isprop-subsing/run | 2 ++ 3 files changed, 8 insertions(+) create mode 100644 golden-tests/tests/isprop-subsing/expected create mode 100644 golden-tests/tests/isprop-subsing/isprop-subsing.quox create mode 100644 golden-tests/tests/isprop-subsing/run diff --git a/golden-tests/tests/isprop-subsing/expected b/golden-tests/tests/isprop-subsing/expected new file mode 100644 index 0000000..8fbea7a --- /dev/null +++ b/golden-tests/tests/isprop-subsing/expected @@ -0,0 +1,2 @@ +0.IsProp : 1.★ → ★ +0.feq : 1.(A : ★) → 1.(f : IsProp A) → 1.(g : IsProp A) → f ≡ g : IsProp A diff --git a/golden-tests/tests/isprop-subsing/isprop-subsing.quox b/golden-tests/tests/isprop-subsing/isprop-subsing.quox new file mode 100644 index 0000000..2117d08 --- /dev/null +++ b/golden-tests/tests/isprop-subsing/isprop-subsing.quox @@ -0,0 +1,4 @@ +def0 IsProp : ★ → ★ = λ A ⇒ (x y : A) → x ≡ y : A + +def0 feq : (A : ★) → (f g : IsProp A) → f ≡ g : IsProp A = + λ A f g ⇒ δ _ ⇒ f diff --git a/golden-tests/tests/isprop-subsing/run b/golden-tests/tests/isprop-subsing/run new file mode 100644 index 0000000..feb762b --- /dev/null +++ b/golden-tests/tests/isprop-subsing/run @@ -0,0 +1,2 @@ +. ../lib.sh +check "$1" isprop-subsing.quox From 2bfe3250cf2e2c9606e801aaf73e505939f5b953 Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Tue, 28 May 2024 17:00:01 +0200 Subject: [PATCH 132/133] remove Tighten stuff --- golden-tests/tests/useless-coe/coe.quox | 9 + golden-tests/tests/useless-coe/expected | 5 + golden-tests/tests/useless-coe/run | 2 + lib/Quox/OPE.idr | 76 ----- lib/Quox/Parser/FromParser.idr | 4 +- lib/Quox/Syntax/Term.idr | 1 - lib/Quox/Syntax/Term/Base.idr | 6 + lib/Quox/Syntax/Term/Subst.idr | 28 ++ lib/Quox/Syntax/Term/Tighten.idr | 376 ------------------------ lib/Quox/Var.idr | 10 - lib/Quox/Whnf/Coercion.idr | 32 +- lib/Quox/Whnf/Main.idr | 31 +- lib/Quox/Whnf/TypeCase.idr | 6 +- lib/quox-lib.ipkg | 2 - tests/Tests/FromPTerm.idr | 2 +- 15 files changed, 84 insertions(+), 506 deletions(-) create mode 100644 golden-tests/tests/useless-coe/coe.quox create mode 100644 golden-tests/tests/useless-coe/expected create mode 100644 golden-tests/tests/useless-coe/run delete mode 100644 lib/Quox/OPE.idr delete mode 100644 lib/Quox/Syntax/Term/Tighten.idr diff --git a/golden-tests/tests/useless-coe/coe.quox b/golden-tests/tests/useless-coe/coe.quox new file mode 100644 index 0000000..85da306 --- /dev/null +++ b/golden-tests/tests/useless-coe/coe.quox @@ -0,0 +1,9 @@ +-- non-dependent coe should reduce to its body + +def five : ℕ = 5 +def five? : ℕ = coe ℕ 5 + +def eq : five ≡ five? : ℕ = δ _ ⇒ 5 + +def subst1 : 0.(P : ℕ → ★) → P five → P five? = λ P p ⇒ p +def subst2 : 0.(P : ℕ → ★) → P five? → P five = λ P p ⇒ p diff --git a/golden-tests/tests/useless-coe/expected b/golden-tests/tests/useless-coe/expected new file mode 100644 index 0000000..b0b14ce --- /dev/null +++ b/golden-tests/tests/useless-coe/expected @@ -0,0 +1,5 @@ +ω.five : ℕ +ω.five? : ℕ +ω.eq : five ≡ five? : ℕ +ω.subst1 : 0.(P : 1.ℕ → ★) → 1.(P five) → P five? +ω.subst2 : 0.(P : 1.ℕ → ★) → 1.(P five?) → P five diff --git a/golden-tests/tests/useless-coe/run b/golden-tests/tests/useless-coe/run new file mode 100644 index 0000000..aba005b --- /dev/null +++ b/golden-tests/tests/useless-coe/run @@ -0,0 +1,2 @@ +. ../lib.sh +check "$1" coe.quox diff --git a/lib/Quox/OPE.idr b/lib/Quox/OPE.idr deleted file mode 100644 index 31203eb..0000000 --- a/lib/Quox/OPE.idr +++ /dev/null @@ -1,76 +0,0 @@ -||| "order preserving embeddings", for recording a correspondence between -||| a smaller scope and part of a larger one. -module Quox.OPE - -import Quox.NatExtra -import Data.Nat - -%default total - - -public export -data OPE : Nat -> Nat -> Type where - Id : OPE n n - Drop : OPE m n -> OPE m (S n) - Keep : OPE m n -> OPE (S m) (S n) -%name OPE p, q - -public export %inline Injective Drop where injective Refl = Refl -public export %inline Injective Keep where injective Refl = Refl - -public export -opeZero : {n : Nat} -> OPE 0 n -opeZero {n = 0} = Id -opeZero {n = S n} = Drop opeZero - -public export -(.) : OPE m n -> OPE n p -> OPE m p -p . Id = p -Id . q = q -p . Drop q = Drop $ p . q -Drop p . Keep q = Drop $ p . q -Keep p . Keep q = Keep $ p . q - -public export -toLTE : {m : Nat} -> OPE m n -> m `LTE` n -toLTE Id = reflexive -toLTE (Drop p) = lteSuccRight $ toLTE p -toLTE (Keep p) = LTESucc $ toLTE p - - -public export -keepN : (n : Nat) -> OPE a b -> OPE (n + a) (n + b) -keepN 0 p = p -keepN (S n) p = Keep $ keepN n p - -public export -dropInner' : LTE' m n -> OPE m n -dropInner' LTERefl = Id -dropInner' (LTESuccR p) = Drop $ dropInner' $ force p - -public export -dropInner : {n : Nat} -> LTE m n -> OPE m n -dropInner = dropInner' . fromLte - -public export -dropInnerN : (m : Nat) -> OPE n (m + n) -dropInnerN 0 = Id -dropInnerN (S m) = Drop $ dropInnerN m - - -public export -interface Tighten t where - tighten : OPE m n -> t n -> Maybe (t m) - -parameters {auto _ : Tighten t} - export %inline - tightenInner : {n : Nat} -> m `LTE` n -> t n -> Maybe (t m) - tightenInner = tighten . dropInner - - export %inline - tightenN : (m : Nat) -> t (m + n) -> Maybe (t n) - tightenN m = tighten $ dropInnerN m - - export %inline - tighten1 : t (S n) -> Maybe (t n) - tighten1 = tightenN 1 diff --git a/lib/Quox/Parser/FromParser.idr b/lib/Quox/Parser/FromParser.idr index 5a4edc7..2ae4f37 100644 --- a/lib/Quox/Parser/FromParser.idr +++ b/lib/Quox/Parser/FromParser.idr @@ -297,7 +297,7 @@ mutual if all isUnused xs then SN <$> fromPTermWith ds ns t else - ST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t + SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith ds (ns ++ xs) t private fromPTermDScope : {s : Nat} -> Context' PatVar d -> Context' PatVar n -> @@ -307,7 +307,7 @@ mutual if all isUnused xs then SN {f = \d => Term d n} <$> fromPTermWith ds ns t else - DST (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t + SY (fromSnocVect $ map fromPatVar xs) <$> fromPTermWith (ds ++ xs) ns t export %inline diff --git a/lib/Quox/Syntax/Term.idr b/lib/Quox/Syntax/Term.idr index 2ac69a4..b7e4054 100644 --- a/lib/Quox/Syntax/Term.idr +++ b/lib/Quox/Syntax/Term.idr @@ -3,4 +3,3 @@ module Quox.Syntax.Term import public Quox.Syntax.Term.Base import public Quox.Syntax.Term.Subst import public Quox.Syntax.Term.Pretty -import public Quox.Syntax.Term.Tighten diff --git a/lib/Quox/Syntax/Term/Base.idr b/lib/Quox/Syntax/Term/Base.idr index 75bae76..5457b83 100644 --- a/lib/Quox/Syntax/Term/Base.idr +++ b/lib/Quox/Syntax/Term/Base.idr @@ -398,6 +398,12 @@ public export %inline DLamN : (body : Term d n) -> (loc : Loc) -> Term d n DLamN {body, loc} = DLam {body = SN body, loc} +||| more convenient Coe +public export %inline +CoeY : (i : BindName) -> (ty : Term (S d) n) -> + (p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n +CoeY {i, ty, p, q, val, loc} = Coe {ty = SY [< i] ty, p, q, val, loc} + ||| non dependent equality type public export %inline Eq0 : (ty, l, r : Term d n) -> (loc : Loc) -> Term d n diff --git a/lib/Quox/Syntax/Term/Subst.idr b/lib/Quox/Syntax/Term/Subst.idr index afc8eef..67927c3 100644 --- a/lib/Quox/Syntax/Term/Subst.idr +++ b/lib/Quox/Syntax/Term/Subst.idr @@ -354,3 +354,31 @@ PushSubsts Term Subst.isCloT where pushSubstsWith th (comp th ps ph) s pushSubstsWith th ph (DCloT (Sub s ps)) = pushSubstsWith (ps . th) ph s + + +||| heterogeneous comp, in terms of Comp and Coe +public export %inline +CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> + (r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n +CompH' {ty, p, q, val, r, zero, one, loc} = + let ty' = SY ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in + Comp { + ty = dsub1 ty q, p, q, + val = E $ Coe ty p q val val.loc, r, + zero = SY zero.names $ E $ + Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc, + one = SY one.names $ E $ + Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc, + loc + } + +||| heterogeneous comp, in terms of Comp and Coe +public export %inline +CompH : (i : BindName) -> (ty : Term (S d) n) -> + (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) -> + (j0 : BindName) -> (zero : Term (S d) n) -> + (j1 : BindName) -> (one : Term (S d) n) -> + (loc : Loc) -> Elim d n +CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} = + CompH' {ty = SY [< i] ty, p, q, val, r, + zero = SY [< j0] zero, one = SY [< j1] one, loc} diff --git a/lib/Quox/Syntax/Term/Tighten.idr b/lib/Quox/Syntax/Term/Tighten.idr deleted file mode 100644 index 0709684..0000000 --- a/lib/Quox/Syntax/Term/Tighten.idr +++ /dev/null @@ -1,376 +0,0 @@ -module Quox.Syntax.Term.Tighten - -import Quox.Syntax.Term.Base -import Quox.Syntax.Term.Subst -import public Quox.OPE -import Quox.No - -%default total - - -export -Tighten Dim where - tighten p (K e loc) = pure $ K e loc - tighten p (B i loc) = B <$> tighten p i <*> pure loc - -export -tightenScope : (forall m, n. OPE m n -> f n -> Maybe (f m)) -> - {s : Nat} -> OPE m n -> Scoped s f n -> Maybe (Scoped s f m) -tightenScope f p (S names (Y body)) = SY names <$> f (keepN s p) body -tightenScope f p (S names (N body)) = S names . N <$> f p body - -export -tightenDScope : {0 f : Nat -> Nat -> Type} -> - (forall m, n, k. OPE m n -> f n k -> Maybe (f m k)) -> - OPE m n -> Scoped s (f n) k -> Maybe (Scoped s (f m) k) -tightenDScope f p (S names (Y body)) = SY names <$> f p body -tightenDScope f p (S names (N body)) = S names . N <$> f p body - - -mutual - private - tightenT : OPE n1 n2 -> Term d n2 -> Maybe (Term d n1) - tightenT p s = - let Element s' _ = pushSubsts s in - tightenT' p $ assert_smaller s s' - - private - tightenE : OPE n1 n2 -> Elim d n2 -> Maybe (Elim d n1) - tightenE p e = - let Element e' _ = pushSubsts e in - tightenE' p $ assert_smaller e e' - - private - tightenT' : OPE n1 n2 -> (t : Term d n2) -> (0 nt : NotClo t) => - Maybe (Term d n1) - tightenT' p (TYPE l loc) = pure $ TYPE l loc - tightenT' p (IOState loc) = pure $ IOState loc - tightenT' p (Pi qty arg res loc) = - Pi qty <$> tightenT p arg <*> tightenS p res <*> pure loc - tightenT' p (Lam body loc) = - Lam <$> tightenS p body <*> pure loc - tightenT' p (Sig fst snd loc) = - Sig <$> tightenT p fst <*> tightenS p snd <*> pure loc - tightenT' p (Pair fst snd loc) = - Pair <$> tightenT p fst <*> tightenT p snd <*> pure loc - tightenT' p (Enum cases loc) = - pure $ Enum cases loc - tightenT' p (Tag tag loc) = - pure $ Tag tag loc - tightenT' p (Eq ty l r loc) = - Eq <$> tightenDS p ty <*> tightenT p l <*> tightenT p r <*> pure loc - tightenT' p (DLam body loc) = - DLam <$> tightenDS p body <*> pure loc - tightenT' p (NAT loc) = - pure $ NAT loc - tightenT' p (Nat n loc) = - pure $ Nat n loc - tightenT' p (Succ s loc) = - Succ <$> tightenT p s <*> pure loc - tightenT' p (STRING loc) = - pure $ STRING loc - tightenT' p (Str s loc) = - pure $ Str s loc - tightenT' p (BOX qty ty loc) = - BOX qty <$> tightenT p ty <*> pure loc - tightenT' p (Box val loc) = - Box <$> tightenT p val <*> pure loc - tightenT' p (Let qty rhs body loc) = - Let qty <$> assert_total tightenE p rhs <*> tightenS p body <*> pure loc - tightenT' p (E e) = - E <$> assert_total tightenE p e - - private - tightenE' : OPE n1 n2 -> (e : Elim d n2) -> (0 ne : NotClo e) => - Maybe (Elim d n1) - tightenE' p (F x u loc) = - pure $ F x u loc - tightenE' p (B i loc) = - B <$> tighten p i <*> pure loc - tightenE' p (App fun arg loc) = - App <$> tightenE p fun <*> tightenT p arg <*> pure loc - tightenE' p (CasePair qty pair ret body loc) = - CasePair qty <$> tightenE p pair - <*> tightenS p ret - <*> tightenS p body - <*> pure loc - tightenE' p (Fst pair loc) = - Fst <$> tightenE p pair <*> pure loc - tightenE' p (Snd pair loc) = - Snd <$> tightenE p pair <*> pure loc - tightenE' p (CaseEnum qty tag ret arms loc) = - CaseEnum qty <$> tightenE p tag - <*> tightenS p ret - <*> traverse (tightenT p) arms - <*> pure loc - tightenE' p (CaseNat qty qtyIH nat ret zero succ loc) = - CaseNat qty qtyIH - <$> tightenE p nat - <*> tightenS p ret - <*> tightenT p zero - <*> tightenS p succ - <*> pure loc - tightenE' p (CaseBox qty box ret body loc) = - CaseBox qty <$> tightenE p box - <*> tightenS p ret - <*> tightenS p body - <*> pure loc - tightenE' p (DApp fun arg loc) = - DApp <$> tightenE p fun <*> pure arg <*> pure loc - tightenE' p (Ann tm ty loc) = - Ann <$> tightenT p tm <*> tightenT p ty <*> pure loc - tightenE' p (Coe ty q0 q1 val loc) = - Coe <$> tightenDS p ty - <*> pure q0 <*> pure q1 - <*> tightenT p val - <*> pure loc - tightenE' p (Comp ty q0 q1 val r zero one loc) = - Comp <$> tightenT p ty - <*> pure q0 <*> pure q1 - <*> tightenT p val - <*> pure r - <*> tightenDS p zero - <*> tightenDS p one - <*> pure loc - tightenE' p (TypeCase ty ret arms def loc) = - TypeCase <$> tightenE p ty - <*> tightenT p ret - <*> traverse (tightenS p) arms - <*> tightenT p def - <*> pure loc - - export - tightenS : {s : Nat} -> OPE m n -> - ScopeTermN s f n -> Maybe (ScopeTermN s f m) - tightenS = assert_total $ tightenScope tightenT - - export - tightenDS : OPE m n -> DScopeTermN s f n -> Maybe (DScopeTermN s f m) - tightenDS = assert_total $ tightenDScope tightenT {f = \n, d => Term d n} - -export Tighten (Elim d) where tighten p e = tightenE p e -export Tighten (Term d) where tighten p t = tightenT p t - - -mutual - export - dtightenT : OPE d1 d2 -> Term d2 n -> Maybe (Term d1 n) - dtightenT p s = - let Element s' _ = pushSubsts s in - dtightenT' p $ assert_smaller s s' - - export - dtightenE : OPE d1 d2 -> Elim d2 n -> Maybe (Elim d1 n) - dtightenE p e = - let Element e' _ = pushSubsts e in - dtightenE' p $ assert_smaller e e' - - private - dtightenT' : OPE d1 d2 -> (t : Term d2 n) -> (0 nt : NotClo t) => - Maybe (Term d1 n) - dtightenT' p (TYPE l loc) = - pure $ TYPE l loc - dtightenT' p (IOState loc) = - pure $ IOState loc - dtightenT' p (Pi qty arg res loc) = - Pi qty <$> dtightenT p arg <*> dtightenS p res <*> pure loc - dtightenT' p (Lam body loc) = - Lam <$> dtightenS p body <*> pure loc - dtightenT' p (Sig fst snd loc) = - Sig <$> dtightenT p fst <*> dtightenS p snd <*> pure loc - dtightenT' p (Pair fst snd loc) = - Pair <$> dtightenT p fst <*> dtightenT p snd <*> pure loc - dtightenT' p (Enum cases loc) = - pure $ Enum cases loc - dtightenT' p (Tag tag loc) = - pure $ Tag tag loc - dtightenT' p (Eq ty l r loc) = - Eq <$> dtightenDS p ty <*> dtightenT p l <*> dtightenT p r <*> pure loc - dtightenT' p (DLam body loc) = - DLam <$> dtightenDS p body <*> pure loc - dtightenT' p (NAT loc) = - pure $ NAT loc - dtightenT' p (Nat n loc) = - pure $ Nat n loc - dtightenT' p (Succ s loc) = - Succ <$> dtightenT p s <*> pure loc - dtightenT' p (STRING loc) = - pure $ STRING loc - dtightenT' p (Str s loc) = - pure $ Str s loc - dtightenT' p (BOX qty ty loc) = - BOX qty <$> dtightenT p ty <*> pure loc - dtightenT' p (Box val loc) = - Box <$> dtightenT p val <*> pure loc - dtightenT' p (Let qty rhs body loc) = - Let qty <$> assert_total dtightenE p rhs <*> dtightenS p body <*> pure loc - dtightenT' p (E e) = - E <$> assert_total dtightenE p e - - export - dtightenE' : OPE d1 d2 -> (e : Elim d2 n) -> (0 ne : NotClo e) => - Maybe (Elim d1 n) - dtightenE' p (F x u loc) = - pure $ F x u loc - dtightenE' p (B i loc) = - pure $ B i loc - dtightenE' p (App fun arg loc) = - App <$> dtightenE p fun <*> dtightenT p arg <*> pure loc - dtightenE' p (CasePair qty pair ret body loc) = - CasePair qty <$> dtightenE p pair - <*> dtightenS p ret - <*> dtightenS p body - <*> pure loc - dtightenE' p (Fst pair loc) = - Fst <$> dtightenE p pair <*> pure loc - dtightenE' p (Snd pair loc) = - Snd <$> dtightenE p pair <*> pure loc - dtightenE' p (CaseEnum qty tag ret arms loc) = - CaseEnum qty <$> dtightenE p tag - <*> dtightenS p ret - <*> traverse (dtightenT p) arms - <*> pure loc - dtightenE' p (CaseNat qty qtyIH nat ret zero succ loc) = - CaseNat qty qtyIH - <$> dtightenE p nat - <*> dtightenS p ret - <*> dtightenT p zero - <*> dtightenS p succ - <*> pure loc - dtightenE' p (CaseBox qty box ret body loc) = - CaseBox qty <$> dtightenE p box - <*> dtightenS p ret - <*> dtightenS p body - <*> pure loc - dtightenE' p (DApp fun arg loc) = - DApp <$> dtightenE p fun <*> tighten p arg <*> pure loc - dtightenE' p (Ann tm ty loc) = - Ann <$> dtightenT p tm <*> dtightenT p ty <*> pure loc - dtightenE' p (Coe ty q0 q1 val loc) = - [|Coe (dtightenDS p ty) (tighten p q0) (tighten p q1) (dtightenT p val) - (pure loc)|] - dtightenE' p (Comp ty q0 q1 val r zero one loc) = - [|Comp (dtightenT p ty) (tighten p q0) (tighten p q1) - (dtightenT p val) (tighten p r) - (dtightenDS p zero) (dtightenDS p one) (pure loc)|] - dtightenE' p (TypeCase ty ret arms def loc) = - [|TypeCase (dtightenE p ty) (dtightenT p ret) - (traverse (dtightenS p) arms) (dtightenT p def) (pure loc)|] - - export - dtightenS : OPE d1 d2 -> ScopeTermN s d2 n -> Maybe (ScopeTermN s d1 n) - dtightenS = assert_total $ tightenDScope dtightenT {f = Term} - - export - dtightenDS : {s : Nat} -> OPE d1 d2 -> - DScopeTermN s d2 n -> Maybe (DScopeTermN s d1 n) - dtightenDS = assert_total $ tightenScope dtightenT - - -export Tighten (\d => Term d n) where tighten p t = dtightenT p t -export Tighten (\d => Elim d n) where tighten p e = dtightenE p e - - -parameters {auto _ : Tighten f} {s : Nat} - export - squeeze : Scoped s f n -> (BContext s, Either (f (s + n)) (f n)) - squeeze (S ns (N t)) = (ns, Right t) - squeeze (S ns (Y t)) = (ns, maybe (Left t) Right $ tightenN s t) - - export - squeeze' : Scoped s f n -> Scoped s f n - squeeze' t = let (ns, res) = squeeze t in S ns $ either Y N res - -parameters {0 f : Nat -> Nat -> Type} - {auto tt : Tighten (\d => f d n)} {s : Nat} - export - dsqueeze : Scoped s (\d => f d n) d -> - (BContext s, Either (f (s + d) n) (f d n)) - dsqueeze = squeeze - - export - dsqueeze' : Scoped s (\d => f d n) d -> Scoped s (\d => f d n) d - dsqueeze' = squeeze' - - --- versions of SY, etc, that try to tighten and use SN automatically - -public export %inline -ST : Tighten f => {s : Nat} -> BContext s -> f (s + n) -> Scoped s f n -ST names body = squeeze' $ SY names body - -public export %inline -DST : {s : Nat} -> BContext s -> Term (s + d) n -> DScopeTermN s d n -DST names body = dsqueeze' {f = Term} $ SY names body - -public export %inline -PiT : (qty : Qty) -> (x : BindName) -> - (arg : Term d n) -> (res : Term d (S n)) -> (loc : Loc) -> Term d n -PiT {qty, x, arg, res, loc} = Pi {qty, arg, res = ST [< x] res, loc} - -public export %inline -LamT : (x : BindName) -> (body : Term d (S n)) -> (loc : Loc) -> Term d n -LamT {x, body, loc} = Lam {body = ST [< x] body, loc} - -public export %inline -SigT : (x : BindName) -> (fst : Term d n) -> - (snd : Term d (S n)) -> (loc : Loc) -> Term d n -SigT {x, fst, snd, loc} = Sig {fst, snd = ST [< x] snd, loc} - -public export %inline -EqT : (i : BindName) -> (ty : Term (S d) n) -> - (l, r : Term d n) -> (loc : Loc) -> Term d n -EqT {i, ty, l, r, loc} = Eq {ty = DST [< i] ty, l, r, loc} - -public export %inline -DLamT : (i : BindName) -> (body : Term (S d) n) -> (loc : Loc) -> Term d n -DLamT {i, body, loc} = DLam {body = DST [< i] body, loc} - -public export %inline -CoeT : (i : BindName) -> (ty : Term (S d) n) -> - (p, q : Dim d) -> (val : Term d n) -> (loc : Loc) -> Elim d n -CoeT {i, ty, p, q, val, loc} = Coe {ty = DST [< i] ty, p, q, val, loc} - -public export %inline -typeCase1T : Elim d n -> Term d n -> - (k : TyConKind) -> BContext (arity k) -> Term d (arity k + n) -> - (loc : Loc) -> - {default (NAT loc) def : Term d n} -> - Elim d n -typeCase1T ty ret k ns body loc {def} = - typeCase ty ret [(k ** ST ns body)] def loc - - -public export %inline -CompH' : (ty : DScopeTerm d n) -> (p, q : Dim d) -> (val : Term d n) -> - (r : Dim d) -> (zero, one : DScopeTerm d n) -> (loc : Loc) -> Elim d n -CompH' {ty, p, q, val, r, zero, one, loc} = - let ty' = DST ty.names $ ty.term // (B VZ ty.name.loc ::: shift 2) in - Comp { - ty = dsub1 ty q, p, q, - val = E $ Coe ty p q val val.loc, r, - zero = DST zero.names $ E $ - Coe ty' (B VZ zero.loc) (weakD 1 q) zero.term zero.loc, - one = DST one.names $ E $ - Coe ty' (B VZ one.loc) (weakD 1 q) one.term one.loc, - loc - } - -||| heterogeneous composition, using Comp and Coe (and subst) -||| -||| comp [i ⇒ A] @p @q s @r { 0 j ⇒ t₀; 1 j ⇒ t₁ } -||| ≔ -||| comp [A‹q/i›] @p @q (coe [i ⇒ A] @p @q s) @r { -||| 0 j ⇒ coe [i ⇒ A] @j @q t₀; -||| 1 j ⇒ coe [i ⇒ A] @j @q t₁ -||| } -public export %inline -CompH : (i : BindName) -> (ty : Term (S d) n) -> - (p, q : Dim d) -> (val : Term d n) -> (r : Dim d) -> - (j0 : BindName) -> (zero : Term (S d) n) -> - (j1 : BindName) -> (one : Term (S d) n) -> - (loc : Loc) -> - Elim d n -CompH {i, ty, p, q, val, r, j0, zero, j1, one, loc} = - CompH' {ty = DST [< i] ty, p, q, val, r, - zero = DST [< j0] zero, one = DST [< j1] one, loc} diff --git a/lib/Quox/Var.idr b/lib/Quox/Var.idr index 732b012..5466542 100644 --- a/lib/Quox/Var.idr +++ b/lib/Quox/Var.idr @@ -2,7 +2,6 @@ module Quox.Var import public Quox.Loc import public Quox.Name -import Quox.OPE import Data.Nat import Data.List @@ -290,12 +289,3 @@ decEqFromBool i j = %transform "Var.decEq" varDecEq = decEqFromBool public export %inline DecEq (Var n) where decEq = varDecEq - - -export -Tighten Var where - tighten Id i = Just i - tighten (Drop p) VZ = Nothing - tighten (Drop p) (VS i) = tighten p i - tighten (Keep p) VZ = Just VZ - tighten (Keep p) (VS i) = VS <$> tighten p i diff --git a/lib/Quox/Whnf/Coercion.idr b/lib/Quox/Whnf/Coercion.idr index 91d94d2..b086fc3 100644 --- a/lib/Quox/Whnf/Coercion.idr +++ b/lib/Quox/Whnf/Coercion.idr @@ -14,7 +14,7 @@ coeScoped : {s : Nat} -> DScopeTerm d n -> Dim d -> Dim d -> Loc -> coeScoped ty p q loc (S names (N body)) = S names $ N $ E $ Coe ty p q body loc coeScoped ty p q loc (S names (Y body)) = - ST names $ E $ Coe (weakDS s ty) p q body loc + SY names $ E $ Coe (weakDS s ty) p q body loc where weakDS : (by : Nat) -> DScopeTerm d n -> DScopeTerm d (by + n) weakDS by (S names (Y body)) = S names $ Y $ weakT by body @@ -38,11 +38,11 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} let ctx1 = extendDim i ctx Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty (arg, res) <- tycasePi defs ctx1 ty - let s0 = CoeT i arg q p s s.loc + let s0 = CoeY i arg q p s s.loc body = E $ App (Ann val (ty // one p) val.loc) (E s0) loc - s1 = CoeT i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc) + s1 = CoeY i (arg // (BV 0 i.loc ::: shift 2)) (weakD 1 q) (BV 0 i.loc) (s // shift 1) s.loc - whnf defs ctx sg $ CoeT i (sub1 res s1) p q body loc + whnf defs ctx sg $ CoeY i (sub1 res s1) p q body loc ||| reduce a pair elimination `CasePair pi (Coe ty p q val) ret body loc` export covering @@ -63,13 +63,13 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty (tfst, tsnd) <- tycaseSig defs ctx1 ty let [< x, y] = body.names - a' = CoeT i (weakT 2 tfst) p q (BVT 1 x.loc) x.loc + a' = CoeY i (weakT 2 tfst) p q (BVT 1 x.loc) x.loc tsnd' = tsnd.term // - (CoeT i (weakT 2 $ tfst // (B VZ tsnd.loc ::: shift 2)) + (CoeY i (weakT 2 $ tfst // (B VZ tsnd.loc ::: shift 2)) (weakD 1 p) (B VZ i.loc) (BVT 1 tsnd.loc) y.loc ::: shift 2) - b' = CoeT i tsnd' p q (BVT 0 y.loc) y.loc + b' = CoeY i tsnd' p q (BVT 0 y.loc) y.loc whnf defs ctx sg $ CasePair qty (Ann val (ty // one p) val.loc) ret - (ST body.names $ body.term // (a' ::: b' ::: shift 2)) loc + (SY body.names $ body.term // (a' ::: b' ::: shift 2)) loc ||| reduce a pair projection `Fst (Coe ty p q val) loc` export covering @@ -85,7 +85,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty (tfst, _) <- tycaseSig defs ctx1 ty whnf defs ctx sg $ - Coe (ST [< i] tfst) p q + Coe (SY [< i] tfst) p q (E (Fst (Ann val (ty // one p) val.loc) val.loc)) loc ||| reduce a pair projection `Snd (Coe ty p q val) loc` @@ -103,8 +103,8 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty (tfst, tsnd) <- tycaseSig defs ctx1 ty whnf defs ctx sg $ - Coe (ST [< i] $ sub1 tsnd $ - Coe (ST [< !(fresh i)] $ tfst // (BV 0 i.loc ::: shift 2)) + Coe (SY [< i] $ sub1 tsnd $ + Coe (SY [< !(fresh i)] $ tfst // (BV 0 i.loc ::: shift 2)) (weakD 1 p) (BV 0 loc) (E (Fst (Ann (dweakT 1 val) ty val.loc) val.loc)) loc) p q @@ -142,9 +142,9 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} Element ty tynf <- whnf defs ctx1 SZero $ getTerm ty ta <- tycaseBOX defs ctx1 ty let xloc = body.name.loc - let a' = CoeT i (weakT 1 ta) p q (BVT 0 xloc) xloc + let a' = CoeY i (weakT 1 ta) p q (BVT 0 xloc) xloc whnf defs ctx sg $ CaseBox qty (Ann val (ty // one p) val.loc) ret - (ST body.names $ body.term // (a' ::: shift 1)) loc + (SY body.names $ body.term // (a' ::: shift 1)) loc -- new params block to call the above functions at different `n` @@ -195,12 +195,12 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} -- ∷ ((x : A) × B)‹q/𝑖› Sig tfst tsnd tyLoc => do let Pair fst snd sLoc = s - fst' = CoeT i tfst p q fst fst.loc + fst' = CoeY i tfst p q fst fst.loc fstInSnd = - CoeT !(fresh i) + CoeY !(fresh i) (tfst // (BV 0 loc ::: shift 2)) (weakD 1 p) (BV 0 loc) (dweakT 1 fst) fst.loc - snd' = CoeT i (sub1 tsnd fstInSnd) p q snd snd.loc + snd' = CoeY i (sub1 tsnd fstInSnd) p q snd snd.loc whnf defs ctx sg $ Ann (Pair (E fst') (E snd') sLoc) (ty // one q) loc diff --git a/lib/Quox/Whnf/Main.idr b/lib/Quox/Whnf/Main.idr index 1c3bcc4..cd340ca 100644 --- a/lib/Quox/Whnf/Main.idr +++ b/lib/Quox/Whnf/Main.idr @@ -206,25 +206,18 @@ CanWhnf Elim Interface.isRedexE where Element a anf <- whnf defs ctx SZero a pure $ Element (Ann s a annLoc) (ne `orNo` snf `orNo` anf) - whnfNoLog defs ctx sg (Coe sty p q val coeLoc) = - -- 𝑖 ∉ fv(A) - -- ------------------------------- - -- coe (𝑖 ⇒ A) @p @q s ⇝ s ∷ A - -- - -- [fixme] needs a real equality check between A‹0/𝑖› and A‹1/𝑖› - case dsqueeze sty {f = Term} of - ([< i], Left ty) => - case p `decEqv` q of - -- coe (𝑖 ⇒ A) @p @p s ⇝ (s ∷ A‹p/𝑖›) - Yes _ => whnf defs ctx sg $ Ann val (dsub1 sty p) coeLoc - No npq => do - Element ty tynf <- whnf defs (extendDim i ctx) SZero ty - case nchoose $ canPushCoe sg ty val of - Left pc => pushCoe defs ctx sg i ty p q val coeLoc - Right npc => pure $ Element (Coe (SY [< i] ty) p q val coeLoc) - (tynf `orNo` npc `orNo` notYesNo npq) - (_, Right ty) => - whnf defs ctx sg $ Ann val ty coeLoc + whnfNoLog defs ctx sg (Coe sty@(S [< i] ty) p q val coeLoc) = + -- reduction if A‹0/𝑖› = A‹1/𝑖› lives in Equal + case p `decEqv` q of + -- coe (𝑖 ⇒ A) @p @p s ⇝ (s ∷ A‹p/𝑖›) + Yes _ => whnf defs ctx sg $ Ann val (dsub1 sty p) coeLoc + No npq => do + let ty = getTerm ty + Element ty tynf <- whnf defs (extendDim i ctx) SZero ty + case nchoose $ canPushCoe sg ty val of + Left pc => pushCoe defs ctx sg i ty p q val coeLoc + Right npc => pure $ Element (Coe (SY [< i] ty) p q val coeLoc) + (tynf `orNo` npc `orNo` notYesNo npq) whnfNoLog defs ctx sg (Comp ty p q val r zero one compLoc) = case p `decEqv` q of diff --git a/lib/Quox/Whnf/TypeCase.idr b/lib/Quox/Whnf/TypeCase.idr index 9b3645f..c9ffde2 100644 --- a/lib/Quox/Whnf/TypeCase.idr +++ b/lib/Quox/Whnf/TypeCase.idr @@ -45,7 +45,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} arg = E $ typeCase1Y e ty KPi [< !narg, !nret] (BVT 1 loc) loc res' = typeCase1Y e (Arr Zero arg ty loc) KPi [< !narg, !nret] (BVT 0 loc) loc - res = ST [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc + res = SY [< !narg] $ E $ App (weakE 1 res') (BVT 0 loc) loc pure (arg, res) tycasePi t = throw $ ExpectedPi t.loc ctx.names t @@ -63,7 +63,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} fst = E $ typeCase1Y e ty KSig [< !nfst, !nsnd] (BVT 1 loc) loc snd' = typeCase1Y e (Arr Zero fst ty loc) KSig [< !nfst, !nsnd] (BVT 0 loc) loc - snd = ST [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc + snd = SY [< !nfst] $ E $ App (weakE 1 snd') (BVT 0 loc) loc pure (fst, snd) tycaseSig t = throw $ ExpectedSig t.loc ctx.names t @@ -93,7 +93,7 @@ parameters {auto _ : CanWhnf Term Interface.isRedexT} a0 = E $ typeCase1Y e ty KEq !names (BVT 4 loc) loc a1 = E $ typeCase1Y e ty KEq !names (BVT 3 loc) loc a' = typeCase1Y e (Eq0 ty a0 a1 loc) KEq !names (BVT 2 loc) loc - a = DST [< !(mnb "i" loc)] $ E $ DApp (dweakE 1 a') (B VZ loc) loc + a = SY [< !(mnb "i" loc)] $ E $ DApp (dweakE 1 a') (B VZ loc) loc l = E $ typeCase1Y e a0 KEq !names (BVT 1 loc) loc r = E $ typeCase1Y e a1 KEq !names (BVT 0 loc) loc pure (a0, a1, a, l, r) diff --git a/lib/quox-lib.ipkg b/lib/quox-lib.ipkg index f715226..85817f0 100644 --- a/lib/quox-lib.ipkg +++ b/lib/quox-lib.ipkg @@ -23,7 +23,6 @@ modules = Quox.Loc, Quox.Var, Quox.Scoped, - Quox.OPE, Quox.Pretty, Quox.Syntax, Quox.Syntax.Builtin, @@ -35,7 +34,6 @@ modules = Quox.Syntax.Term, Quox.Syntax.Term.TyConKind, Quox.Syntax.Term.Base, - Quox.Syntax.Term.Tighten, Quox.Syntax.Term.Pretty, Quox.Syntax.Term.Subst, Quox.FreeVars, diff --git a/tests/Tests/FromPTerm.idr b/tests/Tests/FromPTerm.idr index de7bd24..8f775a8 100644 --- a/tests/Tests/FromPTerm.idr +++ b/tests/Tests/FromPTerm.idr @@ -97,7 +97,7 @@ tests = "PTerm → Term" :- [ parseMatch term fromPTerm "λ w ⇒ w" `(Lam (S _ $ Y $ E $ B VZ _) _), parseMatch term fromPTerm "λ w ⇒ x" - `(Lam (S _ $ N $ E $ B (VS $ VS VZ) _) _), + `(Lam (S _ $ Y $ E $ B (VS $ VS $ VS VZ) _) _), parseMatch term fromPTerm "λ x ⇒ x" `(Lam (S _ $ Y $ E $ B VZ _) _), parseMatch term fromPTerm "λ a b ⇒ f a b" From 3ab86694040cf49f935cc32adec42b975354597b Mon Sep 17 00:00:00 2001 From: rhiannon morris Date: Tue, 28 May 2024 18:39:21 +0200 Subject: [PATCH 133/133] some refactoring in tests --- tests/Tests/FromPTerm.idr | 54 +++++++++++++++++---------------------- 1 file changed, 24 insertions(+), 30 deletions(-) diff --git a/tests/Tests/FromPTerm.idr b/tests/Tests/FromPTerm.idr index 8f775a8..2bbc059 100644 --- a/tests/Tests/FromPTerm.idr +++ b/tests/Tests/FromPTerm.idr @@ -16,11 +16,14 @@ import Derive.Prelude %hide TParser.Failure %hide TParser.ExpectedFail +PError = Parser.Error +FPError = FromParser.Error + public export data Failure = - ParseError Parser.Error - | FromParser FromParser.Error - | WrongResult String + ParseError PError + | FromParser FPError + | WrongResult String | ExpectedFail String %runElab derive "FileError" [Show] @@ -39,42 +42,33 @@ ToInfo Failure where parameters {c : Bool} {auto _ : Show b} (grm : FileName -> Grammar c a) - (fromP : a -> Either FromParser.Error b) + (fromP : a -> Either FPError b) (inp : String) - parameters {default (ltrim inp) label : String} - parsesWith : (b -> Bool) -> Test - parsesWith p = test label $ do - pres <- mapFst ParseError $ lexParseWith (grm "‹test›") inp - res <- mapFst FromParser $ fromP pres - unless (p res) $ Left $ WrongResult $ show res + parsesWith : String -> (b -> Bool) -> Test + parsesWith label p = test label $ do + pres <- mapFst ParseError $ lexParseWith (grm "‹test›") inp + res <- mapFst FromParser $ fromP pres + unless (p res) $ Left $ WrongResult $ show res - parses : Test - parses = parsesWith $ const True + %macro + parseMatch : {default (ltrim inp) label : String} -> TTImp -> Elab Test + parseMatch {label} pat = + parsesWith label <$> check `(\case ~(pat) => True; _ => False) - %macro - parseMatch : TTImp -> Elab Test - parseMatch pat = - parsesWith <$> check `(\case ~(pat) => True; _ => False) - - parsesAs : Eq b => b -> Test - parsesAs exp = parsesWith (== exp) - - parameters {default "\{ltrim inp} # fails" label : String} - parseFails : Test - parseFails = test label $ do - pres <- mapFst ParseError $ lexParseWith (grm "‹test›") inp - either (const $ Right ()) (Left . ExpectedFail . show) $ fromP pres + parseFails : {default "\{ltrim inp} # fails" label : String} -> Test + parseFails {label} = test label $ do + pres <- mapFst ParseError $ lexParseWith (grm "‹test›") inp + either (const $ Right ()) (Left . ExpectedFail . show) $ fromP pres -runFromParser : {default empty defs : Definitions} -> - Eff FromParserPure a -> Either FromParser.Error a -runFromParser = map val . fromParserPure [<] 0 defs initStack +runFromParser : Definitions -> Eff FromParserPure a -> Either FPError a +runFromParser defs = map val . fromParserPure [<] 0 defs initStack export tests : Test tests = "PTerm → Term" :- [ "dimensions" :- - let fromPDim = runFromParser . fromPDimWith [< "𝑖", "𝑗"] + let fromPDim = runFromParser empty . fromPDimWith [< "𝑖", "𝑗"] in [ note "dim ctx: [𝑖, 𝑗]", parseMatch dim fromPDim "𝑖" `(B (VS VZ) _), @@ -87,7 +81,7 @@ tests = "PTerm → Term" :- [ "terms" :- let defs = fromList [("f", mkDef GAny (^NAT) (^Zero))] -- doesn't have to be well typed yet, just well scoped - fromPTerm = runFromParser {defs} . + fromPTerm = runFromParser defs . fromPTermWith [< "𝑖", "𝑗"] [< "A", "x", "y", "z"] in [ note "dim ctx: [𝑖, 𝑗]; term ctx: [A, x, y, z]",